675 lines
22 KiB
Scheme
675 lines
22 KiB
Scheme
;; ---------------------
|
|
;; --- dnsd-database ---
|
|
;; ---------------------
|
|
|
|
; A simple database for dnsd.scm
|
|
|
|
; This file is part of the Scheme Untergrund Networking package
|
|
|
|
; Copyright (c) 2005/2006 by Norbert Freudemann
|
|
; <nofreude@informatik.uni-tuebingen.de>
|
|
|
|
; For copyright information, see the file COPYING which comes with
|
|
; the distribution.
|
|
|
|
; Naming-Scheme:
|
|
; --------------
|
|
|
|
; dbi- == No locks (should not be exported)
|
|
; db- == With locks
|
|
|
|
; Lock-Safe Database-Interface:
|
|
; -----------------------------
|
|
|
|
; (db-clear-database)
|
|
; (db-clear-zone name class)
|
|
; (db-update-zone zone-list)
|
|
; (db-get-zone name class)
|
|
; (db-get-zone-for-axfr name class)
|
|
; (db-get-zone-soa-rr name class)
|
|
; (db-pretty-print)
|
|
|
|
; Query/Database-Interface
|
|
; ------------------------
|
|
|
|
; (db-lookup-rec qname class type)
|
|
|
|
; Database Structure:
|
|
; -------------------
|
|
; db-class-table: hash-table to db-zones
|
|
; |
|
|
; |-->db-zones-table: hash-table to db-zone
|
|
; |
|
|
; |-->db-zone: hash-table to db-rr
|
|
; |
|
|
; |-->db-rr-table: hash-table to lists of resource-records
|
|
; of a given message-type
|
|
|
|
|
|
;; Some stuff:
|
|
;; -----------
|
|
|
|
;; Should be a dnsd-option?
|
|
(define *debug-info* #t)
|
|
|
|
|
|
;; Make a key for the database:
|
|
;; TYPE: string -> string
|
|
(define (make-key-name name)
|
|
(let ((last-char (string-ref name (- (string-length name) 1))))
|
|
(string-downcase (if (not (char=? #\. last-char))
|
|
(string-append name ".")
|
|
name))))
|
|
|
|
;; Compare the first string with the rear of the second string.
|
|
;; TYPE: string x string -> boolean
|
|
(define (string-ci-zone-name=? zone name)
|
|
(let ((l1 (string-length zone))
|
|
(l2 (string-length name)))
|
|
(if (<= l1 l2) (string-ci=? zone (substring name (- l2 l1) l2)) #f)))
|
|
|
|
;; Search a list of resource-records for the soa-rr:
|
|
;; TYPE: list-of-rrs -> soa-rr or #f
|
|
(define (maybe-get-soa-rr l)
|
|
(let loop ((l l))
|
|
(if (null? l)
|
|
#f
|
|
(let ((e (car l)))
|
|
(if (resource-record-data-soa?
|
|
(resource-record-data e))
|
|
e
|
|
(loop (cdr l)))))))
|
|
|
|
|
|
;; Get the name of a zone from a soa-rr within a zone-list:
|
|
;; TYPE: list-of-rrs -> zone-name or #f
|
|
(define (maybe-get-soa-rr-name l)
|
|
(and-let* ((soa-rr (maybe-get-soa-rr l)))
|
|
(resource-record-name soa-rr)))
|
|
|
|
|
|
;; TYPE : list-or-rrs -> list-of-rrs
|
|
(define (get-zone-list-w/o-soa l)
|
|
(fold-right
|
|
(lambda (e l)
|
|
(if (resource-record-data-soa? (resource-record-data e)) l (cons e l)))
|
|
'() l))
|
|
|
|
;; TODO: Do this different...
|
|
(define display-debug
|
|
(lambda args
|
|
(if *debug-info*
|
|
(begin
|
|
(display "dnsd: ")
|
|
(map (lambda (e) (display e) (display " ")) args)
|
|
(newline))
|
|
#f)))
|
|
|
|
;; Duplicate a resource-record: (Needed for wildcard-replies)
|
|
(define (duplicate-rr name rr)
|
|
(make-resource-record name
|
|
(resource-record-type rr)
|
|
(resource-record-class rr)
|
|
(resource-record-ttl rr)
|
|
(resource-record-data rr)))
|
|
|
|
|
|
; ---------------------------
|
|
; --- Database definition ---
|
|
; ---------------------------
|
|
|
|
; Record-types:
|
|
; -------------
|
|
|
|
; db-rr-table stores the resource-records of ONE domain-name.
|
|
; hash-table is a symbol-table with 'message-type' as keys
|
|
; and a list of resource-record of the key-message-type as data.
|
|
; glue-data stores the information (as boolean) if the given domain-name
|
|
; is for glue-data or official.
|
|
(define-record-type db-rr-table :db-rr-table
|
|
(really-make-db-rr-table hash-table glue-data)
|
|
db-rr-table?
|
|
(hash-table db-rr-table-hash-table)
|
|
(glue-data db-rr-table-glue-data? set-db-rr-table-glue-data?!))
|
|
|
|
(define (make-db-rr-table) (really-make-db-rr-table (make-symbol-table) #f))
|
|
|
|
|
|
; db-zone stores data (in form of db-rr-tables) for an entire zone
|
|
; as given by e.g. a masterfile
|
|
; hash-table a string-table. Keys are the domain-names of the zone
|
|
; to link to db-rr-tables.
|
|
; name the name of the zone.
|
|
; soa-rr for easy-access :-)
|
|
(define-record-type db-zone :db-zone
|
|
(really-make-db-zone hash-table name soa-rr)
|
|
db-zone?
|
|
(hash-table db-zone-table)
|
|
(name db-zone-name)
|
|
(soa-rr get-db-zone-soa-rr))
|
|
|
|
(define (make-db-zone name soa-rr)
|
|
(let ((primary-name (resource-record-data-soa-mname
|
|
(resource-record-data soa-rr))))
|
|
(really-make-db-zone (make-string-table) name soa-rr)))
|
|
|
|
|
|
; db-zones-table stores all zones of a given message-class
|
|
; hash-table key is the zone-name.
|
|
(define-record-type db-zones-table :db-zones-table
|
|
(really-make-db-zones-table hash-table)
|
|
db-zones-table?
|
|
(hash-table db-zones-table-hash-table))
|
|
|
|
(define (make-db-zones-table) (really-make-db-zones-table (make-string-table)))
|
|
|
|
|
|
; db-class-table entry-point for the db.
|
|
; hash-table key is the message-class (e.g. in) data are db-zones-tables
|
|
; r/w-lock lock for exclusive-write-access.
|
|
(define-record-type db-class-table :db-class-table
|
|
(really-make-db-class-table hash-table r/w-lock)
|
|
db-class-table?
|
|
(hash-table db-class-table-hash-table set-db-class-table-hash-table!)
|
|
(r/w-lock db-class-table-r/w-lock))
|
|
|
|
(define *database* (really-make-db-class-table (make-symbol-table)
|
|
(make-r/w-lock)))
|
|
|
|
|
|
; Predicates:
|
|
; -----------
|
|
|
|
; Check if there is data for a given message-class:
|
|
; TYPE: message-class -> boolean
|
|
(define (dbi-class? class)
|
|
(if (table-ref (db-class-table-hash-table *database*)
|
|
(message-class-name class))
|
|
#t #f))
|
|
|
|
|
|
;; Modifiers:
|
|
;; ----------
|
|
|
|
;; Delete the whole data in the database:
|
|
(define (db-clear-database)
|
|
(with-r/W-lock
|
|
(db-class-table-r/w-lock *database*)
|
|
(lambda ()
|
|
(set-db-class-table-hash-table! *database* (make-symbol-table)))))
|
|
|
|
|
|
;; Delete a zone (if present) with name 'name' from the database:
|
|
;; TYPE: string x message-class -> boolean
|
|
(define (db-clear-zone name class)
|
|
(with-r/W-lock
|
|
(db-class-table-r/w-lock *database*)
|
|
(lambda ()
|
|
(and-let* ((whatever (dbi-class? class))
|
|
(class-table (db-class-table-hash-table *database*))
|
|
(zones-type (table-ref class-table (message-class-name class)))
|
|
(zones-table (db-zones-table-hash-table zones-type))
|
|
(key-name (make-key-name name))
|
|
(whatever (table-ref zones-table key-name)))
|
|
(table-set! zones-table key-name #f)))))
|
|
|
|
|
|
;; Stuff for db-add-zone:
|
|
|
|
;; Add a new class (if not already present) to the database:
|
|
;; TYPE: message-class -> unspecific
|
|
(define (dbi-maybe-add-class class)
|
|
(if (not (dbi-class? class))
|
|
(table-set! (db-class-table-hash-table *database*)
|
|
(message-class-name class)
|
|
(make-db-zones-table))))
|
|
|
|
|
|
|
|
;; --- Detection of Zone-Rules ---
|
|
|
|
|
|
;; Detect and mark glue data (domains with NS and all of their subdomains)
|
|
;; Give a warning, if the zone-tree is broken
|
|
;; TYPE: db-def-table x string -> unspecific
|
|
(define (dbi-mark-glue-in-zone def-table zone-name)
|
|
(let ((tree (db-zone-table def-table)))
|
|
(table-walk
|
|
(lambda (key element)
|
|
(if (table-ref (db-rr-table-hash-table element)
|
|
(message-type-name (message-type a)))
|
|
(let loop ((name key))
|
|
(if (string-ci=? name zone-name)
|
|
#t
|
|
(let ((zone-entry (table-ref tree name)))
|
|
(if zone-entry
|
|
(if (table-ref (db-rr-table-hash-table zone-entry)
|
|
(message-type-name (message-type ns)))
|
|
(set-db-rr-table-glue-data?! element #t)
|
|
(loop (cut-name name)))
|
|
;; Be tolerant if the domain tree is broken...
|
|
(begin
|
|
(dnsd-log (syslog-level info)
|
|
"Warning (re)loading zone ~S. Broken tree: Domain ~S is missing!"
|
|
zone-name name)
|
|
(loop (cut-name name)))))))
|
|
#t))
|
|
tree)))
|
|
|
|
|
|
;; Ensures the min. TTL from the soa-rr of the zone. Has to be called
|
|
;; after dbi-mark-glue-in-zone!
|
|
;; TYPE: db-def-table x soa-rr -> unspecific
|
|
(define (dbi-ensure-min-ttl def-table soa-rr)
|
|
(let ((min-ttl (resource-record-data-soa-minimum
|
|
(resource-record-data soa-rr))))
|
|
(table-walk
|
|
(lambda (key element)
|
|
(if (not (db-rr-table-glue-data? element))
|
|
(table-walk
|
|
(lambda (tkey telement)
|
|
(table-set! (db-rr-table-hash-table element)
|
|
tkey
|
|
(map (lambda (e)
|
|
(let ((rr-ttl (resource-record-ttl e)))
|
|
(make-resource-record
|
|
(resource-record-name e)
|
|
(resource-record-type e)
|
|
(resource-record-class e)
|
|
(if (< rr-ttl min-ttl)
|
|
min-ttl rr-ttl)
|
|
(resource-record-data e))))
|
|
telement)))
|
|
(db-rr-table-hash-table element))))
|
|
(db-zone-table def-table))))
|
|
|
|
|
|
;; Give a warning, if a Zone with a CNAME-RR contains other stuff...
|
|
;; TYPE: db-def-table -> unspecific
|
|
(define (dbi-cname-warning def-table zone-name)
|
|
(table-walk
|
|
(lambda (key element)
|
|
(let ((rr-table (db-rr-table-hash-table element))
|
|
(cname (message-type-name (message-type cname))))
|
|
(if (table-ref rr-table cname)
|
|
(table-walk
|
|
(lambda (k e)
|
|
(if (not (eq? k cname))
|
|
(dnsd-log (syslog-level info)
|
|
"Warning (re)loading zone ~S. Domain ~S contains a CNAME-RR and other RRs at the same time."
|
|
zone-name key)
|
|
(if (not (= 1 (length e)))
|
|
(dnsd-log (syslog-level info)
|
|
"Warning (re)loading zone ~S. Domain ~S contains 2 or more CNAME-RRs!"
|
|
zone-name key))))
|
|
rr-table))))
|
|
(db-zone-table def-table)))
|
|
|
|
|
|
;; This functions have to be called in the given order:
|
|
;; TYPE: db-def-table x string x soa-rr -> unspecific
|
|
(define (dbi-set-zone-requirements def-table zone-name soa-rr)
|
|
(dbi-mark-glue-in-zone def-table zone-name)
|
|
(dbi-ensure-min-ttl def-table soa-rr)
|
|
(dbi-cname-warning def-table zone-name))
|
|
|
|
|
|
;; Adds a list of resource-records to a zone-definition-table:
|
|
(define (dbi-add-zone-list def-table rr-list)
|
|
(let ((tree (db-zone-table def-table)))
|
|
(for-each
|
|
(lambda (e)
|
|
(let* ((domain-key (make-key-name (resource-record-name e)))
|
|
(type-key (message-type-name (resource-record-type e)))
|
|
(rr-type (table-ref tree domain-key)))
|
|
;; Create & link a new rr-table for the first entry of the rr-type:
|
|
(if (not (db-rr-table? rr-type))
|
|
(begin (set! rr-type (make-db-rr-table))
|
|
(table-set! tree domain-key rr-type)))
|
|
(let* ((rr-table (db-rr-table-hash-table rr-type))
|
|
(entry (table-ref rr-table type-key)))
|
|
(if entry
|
|
(table-set! rr-table type-key (cons e entry))
|
|
(table-set! rr-table type-key (cons e '()))))))
|
|
rr-list)))
|
|
|
|
|
|
;; Adds a zone to the database which is given as a list of resource-records.
|
|
;; Notes: * db-add-zone doesn't overwrite existing zones.
|
|
;; * Just for internal use.
|
|
;; TYPE: list-of-rrs -> boolean
|
|
(define (db-add-zone zone-list)
|
|
(with-r/W-lock
|
|
(db-class-table-r/w-lock *database*)
|
|
(lambda ()
|
|
(and-let* ((soa-rr (maybe-get-soa-rr zone-list))
|
|
(zone-name (resource-record-name soa-rr))
|
|
(zone-key (make-key-name zone-name))
|
|
(zone-class (resource-record-class soa-rr)))
|
|
;; Add another class to the database?
|
|
(dbi-maybe-add-class zone-class)
|
|
;; Get the zone-stuff to insert the zone into together:
|
|
(let* ((zone-table (db-zones-table-hash-table
|
|
(table-ref (db-class-table-hash-table *database*)
|
|
(message-class-name zone-class)))))
|
|
;; Don't overwrite an existing zone
|
|
(if (table-ref zone-table zone-key) #f
|
|
;; Add the zone to the db & ensure data integrity:
|
|
(let* ((zone-dtable (make-db-zone zone-key soa-rr)))
|
|
(table-set! zone-table zone-key zone-dtable)
|
|
(dbi-add-zone-list zone-dtable zone-list)
|
|
(dbi-set-zone-requirements zone-dtable zone-name soa-rr))))))))
|
|
|
|
|
|
;; Update a zone if the serial of the new soa isn't the same or less.
|
|
;; TYPE: list-of-rrs -> boolean
|
|
(define (db-update-zone zone-list)
|
|
(and-let* ((new-soa-rr (maybe-get-soa-rr zone-list))
|
|
(new-serial (resource-record-data-soa-serial
|
|
(resource-record-data new-soa-rr)))
|
|
(zone-name (make-key-name (resource-record-name new-soa-rr)))
|
|
(zone-class (resource-record-class new-soa-rr)))
|
|
(let ((old-soa-rr (db-get-zone-soa-rr zone-name zone-class)))
|
|
(cond
|
|
((or (not old-soa-rr)
|
|
(and old-soa-rr
|
|
(> new-serial (resource-record-data-soa-serial
|
|
(resource-record-data old-soa-rr)))))
|
|
(db-clear-zone zone-name zone-class)
|
|
(db-add-zone zone-list))
|
|
((= new-serial (resource-record-data-soa-serial
|
|
(resource-record-data old-soa-rr)))
|
|
#t) ;; !!! If the serial hasn't changed it's considered successfull.
|
|
(else #f)))))
|
|
|
|
|
|
; Get all resource records for a zone.
|
|
; TYPE: string x message-class -> list-of-rrs or #f
|
|
(define (db-get-zone name class)
|
|
(with-R/w-lock
|
|
(db-class-table-r/w-lock *database*)
|
|
(lambda ()
|
|
(and-let* ((zone-type (table-ref (db-class-table-hash-table *database*)
|
|
(message-class-name class)))
|
|
(the-zone-type (table-ref (db-zones-table-hash-table zone-type)
|
|
(make-key-name name)))
|
|
(zone-tree-tree (db-zone-table the-zone-type))
|
|
(res-list '()))
|
|
(table-walk
|
|
(lambda (k e)
|
|
(if e
|
|
(table-walk (lambda (k1 e1)
|
|
(set! res-list (append e1 res-list)))
|
|
(db-rr-table-hash-table e))))
|
|
zone-tree-tree)
|
|
res-list))))
|
|
|
|
|
|
; ; Get the timestamp for a zone.
|
|
; ; TYPE: string x message-class -> number or #f
|
|
; (define (db-get-zone-timestamp name class)
|
|
; (with-R/w-lock
|
|
; (db-class-table-r/w-lock *database*)
|
|
; (lambda ()
|
|
; (and-let* ((zone-type (table-ref (db-class-table-hash-table *database*)
|
|
; (message-class-name class)))
|
|
; (the-zone-type (table-ref (db-zones-table-hash-table zone-type)
|
|
; (make-key-name name))))
|
|
; (get-db-zone-timestamp the-zone-type)))))
|
|
|
|
|
|
;; Get the soa-rr of a zone.
|
|
;; TYPE: string x message-class -> soa-rr or #f
|
|
(define (db-get-zone-soa-rr name class)
|
|
(with-R/w-lock
|
|
(db-class-table-r/w-lock *database*)
|
|
(lambda ()
|
|
(and-let* ((zone-type (table-ref (db-class-table-hash-table *database*)
|
|
(message-class-name class)))
|
|
(the-zone-type (table-ref (db-zones-table-hash-table zone-type)
|
|
(make-key-name name))))
|
|
(get-db-zone-soa-rr the-zone-type)))))
|
|
|
|
|
|
; Get all rrs of a zone in an AXFR-ready list: '(soa-rr rr rr ... rr soa-rr)
|
|
; TYPE: string x message-class -> list-of-rrs or #f
|
|
(define (db-get-zone-for-axfr name class)
|
|
(and-let* ((zone-list (db-get-zone name class))
|
|
(soa-l (list (maybe-get-soa-rr zone-list)))
|
|
(rest-l (get-zone-list-w/o-soa zone-list)))
|
|
(append soa-l rest-l soa-l)))
|
|
|
|
|
|
;; Look for the zone in which 'name' is a subdomain or the domain of the
|
|
;; given zones. Returns the zone which is the nearest ancestor to 'name'.
|
|
;; TYPE: name x message-class -> db-zone-record-type or #f
|
|
(define (dbi-lookup-zone-for-name name class)
|
|
(and-let* ((zone-record (table-ref (db-class-table-hash-table *database*)
|
|
(message-class-name class)))
|
|
(zone-table (db-zones-table-hash-table zone-record))
|
|
(ancestors '())
|
|
(zone-key ""))
|
|
;; Look for zones who are ancestors to key:
|
|
(table-walk (lambda (k e)
|
|
(if (string-ci-zone-name=? k (make-key-name name))
|
|
(set! ancestors (cons k ancestors))))
|
|
zone-table)
|
|
(cond
|
|
((null? ancestors) #f)
|
|
((= 1 (length ancestors)) (set! zone-key (car ancestors)))
|
|
;; If more ancestors are found get the closest one:
|
|
(else (set! zone-key (fold-right (lambda (a b) (if (< (string-length a)
|
|
(string-length b))
|
|
b a))
|
|
"" ancestors))))
|
|
(table-ref zone-table zone-key)))
|
|
|
|
|
|
; Look for the entries of type 'type' in a given db-rr-table
|
|
; TYPE: db-rr-table-rec-type x message-type -> list-of-rrs
|
|
(define (dbi-lookup-rrs rr-record-type type)
|
|
(let ((rr-table (db-rr-table-hash-table rr-record-type)))
|
|
(cond
|
|
((eq? (message-type *) type) ; ... return all records.
|
|
(let ((res '())) (table-walk (lambda (k e) (set! res (cons e res)))
|
|
rr-table)
|
|
res))
|
|
(else (let ((res (table-ref rr-table (message-type-name type))))
|
|
(if res res '()))))))
|
|
|
|
|
|
;; Look for the entries of type 'type' in a given db-rr-table
|
|
;; TYPE: db-rr-table-rec-type x messag-type -> list-of-rrs or #f
|
|
(define (dbi-lookup-rrs? rr-record-type type)
|
|
(let ((res (dbi-lookup-rrs rr-record-type type)))
|
|
(if (null? res) #f res)))
|
|
|
|
|
|
;; --------------------------------
|
|
;; --- Query/Database Interface ---
|
|
;; --------------------------------
|
|
|
|
;; Requests for mailbox-related resource-records will be handled as mx requests:
|
|
;; TYPE: string x type x class ->
|
|
;; '(list-of-answers-rrs list-of-nameservers-rrs list-of-additional-rrs boolean)
|
|
(define (db-lookup-rec qname class type)
|
|
(obtain-R/w-lock (db-class-table-r/w-lock *database*))
|
|
(receive
|
|
(anli auli adli aufl)
|
|
(dbi-lookup-rec-int qname class (if (eq? type (message-type mailb))
|
|
(message-type mx)
|
|
type) ; Mailb == mx query
|
|
'())
|
|
(release-R/w-lock (db-class-table-r/w-lock *database*))
|
|
(values anli auli adli aufl)))
|
|
|
|
|
|
;; Main part of the algorithm as described in RFC 1034. Returns found rrs and
|
|
;; a flag, indicating if the answer is authoritative.
|
|
;; The flag ist needed, because of glue-data, that could be part of the
|
|
;; response. The operand 'c-list' is used to detect and avoid cname-loops.
|
|
;; TYPE: string x type x class x c-list ->
|
|
;; '(list-of-answers-rrs list-of-nameservers-rrs list-of-additional-rrs boolean)
|
|
(define (dbi-lookup-rec-int qname class type c-list)
|
|
(let ((zone (dbi-lookup-zone-for-name qname class)))
|
|
(if (not zone)
|
|
(values '() '() '() #f) ; no zone in db
|
|
(let ((zone-name (db-zone-name zone)))
|
|
;; loop over the labels of the name. eg. my.example. / example. / .
|
|
;; keep track of the iterations (mostly for wildcard-match support)
|
|
(let loop ((name qname) (loop-count 0))
|
|
(let ((rr-table (table-ref (db-zone-table zone)
|
|
(make-key-name name))))
|
|
(if rr-table
|
|
(cond
|
|
;; A wildcard match
|
|
((= 1 loop-count)
|
|
;; Set the name of the rrs from * to qname.
|
|
(values (map (lambda (e) (duplicate-rr qname e))
|
|
(dbi-lookup-rrs rr-table type)) '() '() #t))
|
|
;; Direct match (0) or glue-data match (>1)
|
|
((or (= 0 loop-count) (< 1 loop-count))
|
|
(cond ;c2
|
|
;; Found glue data.
|
|
((and (dbi-lookup-rrs? rr-table (message-type ns))
|
|
(not (string-ci=? name zone-name))
|
|
(not (eq? (message-type ns) type)))
|
|
(let* ((ns-rr-list (dbi-lookup-rrs?
|
|
rr-table (message-type ns)))
|
|
(res-l
|
|
(fold-right
|
|
(lambda (e l)
|
|
(receive
|
|
(anli auli adli aufl)
|
|
(dbi-lookup-rec-int
|
|
(resource-record-data-ns-name
|
|
(resource-record-data e))
|
|
class (message-type a) c-list)
|
|
(list (car l) (cadr l)
|
|
(append anli (caddr l)) #f)))
|
|
'(() () () #t) ns-rr-list)))
|
|
(values (car res-l) (append ns-rr-list (cadr res-l))
|
|
(caddr res-l) #f)))
|
|
;; Looking for correct information (direct match)
|
|
((= 0 loop-count)
|
|
(cond ;c3
|
|
;; CNAME: Causes an additional lookup
|
|
((dbi-lookup-rrs? rr-table (message-type cname))
|
|
=> (lambda (cname-rr-list)
|
|
(let ((cname-rr (car cname-rr-list)))
|
|
(if (eq? (message-type cname) type)
|
|
(values (list cname-rr) '() '() #t)
|
|
(begin
|
|
(if (fold-right
|
|
(lambda (e b)
|
|
(or (string-ci=? e name) b))
|
|
#f c-list)
|
|
(begin
|
|
;; Problem?: The loop will be send
|
|
;; as a response... .
|
|
(display-debug " Found cname-loop")
|
|
(values '() '() '() #t))
|
|
(receive
|
|
(anli auli adli aufl)
|
|
(dbi-lookup-rec-int
|
|
(resource-record-data-cname-name
|
|
(resource-record-data cname-rr))
|
|
class type (cons name c-list))
|
|
(values (append (list cname-rr) anli)
|
|
auli adli
|
|
(and aufl #t)))))))))
|
|
;; MX: Causes an additional lookup
|
|
((eq? (message-type mx) type)
|
|
(let* ((mx-rrs (dbi-lookup-rrs rr-table type))
|
|
(res-l
|
|
(fold-right
|
|
(lambda (e l)
|
|
(receive
|
|
(anli auli adli aufl)
|
|
(dbi-lookup-rec-int
|
|
(resource-record-data-mx-exchanger
|
|
(resource-record-data e))
|
|
class (message-type a) c-list)
|
|
(list (car l) (cadr l)
|
|
(append anli (caddr l))
|
|
(and #t (cadddr l)))))
|
|
'(() () () #t) mx-rrs)))
|
|
(values (append mx-rrs (car res-l)) (cadr res-l)
|
|
(caddr res-l) (and #t (cadddr res-l)))))
|
|
;; Glue-Data entries aren't authoritative:
|
|
((db-rr-table-glue-data? rr-table)
|
|
(values (dbi-lookup-rrs rr-table type) '() '() #f))
|
|
;; Found a match with no additional lookups.
|
|
(else
|
|
(values (dbi-lookup-rrs rr-table type) '() '() #t))))
|
|
;; Got a dns-name-error (RCODE=3)
|
|
(else (values '() '() '() #t)))))
|
|
;; Found no match for the current name.
|
|
(cond
|
|
((> (string-length zone-name) (string-length name))
|
|
(error "Woh, found a bug... ")) ; Just for safety...
|
|
;; Search for wildcards in the first iteration:
|
|
((= 0 loop-count)
|
|
(loop (string-append "*." (cut-name name)) 1))
|
|
(else (loop (cut-name name) (+ 1 loop-count)))))))))))
|
|
|
|
|
|
;; ------------------------------
|
|
;; --- Database pretty-print: ---
|
|
;; ------------------------------
|
|
|
|
(define (pretty-print-record-type rt)
|
|
(cond
|
|
((db-class-table? rt)
|
|
(table-walk
|
|
(lambda (k e)
|
|
(newline)
|
|
(display "DB-Class: ")
|
|
(display k)(newline)
|
|
(pretty-print-record-type e))
|
|
(db-class-table-hash-table rt)))
|
|
((db-zones-table? rt)
|
|
(table-walk
|
|
(lambda (k e)
|
|
(display " DB-Zone: ")
|
|
(display k)
|
|
(newline)
|
|
(pretty-print-record-type e))
|
|
(db-zones-table-hash-table rt)))
|
|
((db-zone? rt)
|
|
(table-walk
|
|
(lambda (k e)
|
|
(display " DB-Zone-Entries: ")
|
|
(display k)
|
|
(newline)
|
|
(pretty-print-record-type e))
|
|
(db-zone-table rt)))
|
|
((db-rr-table? rt)
|
|
(table-walk
|
|
(lambda (k e)
|
|
(display " DB-RR-Table: ")
|
|
(display k)
|
|
(newline)
|
|
(display " Glue-data: ")
|
|
(display (db-rr-table-glue-data? rt))
|
|
(newline)
|
|
(newline)
|
|
(pretty-print-record-type e))
|
|
(db-rr-table-hash-table rt)))
|
|
((list? rt)
|
|
(for-each
|
|
(lambda (e)
|
|
(pretty-print-dns-message e)
|
|
(newline))
|
|
rt))
|
|
(else (newline))))
|
|
|
|
(define (db-pretty-print)
|
|
(with-R/w-lock
|
|
(db-class-table-r/w-lock *database*)
|
|
(lambda ()
|
|
(newline)
|
|
(display "DNS-Server-Database:")(newline)
|
|
(display "--------------------")(newline)
|
|
(pretty-print-record-type *database*))))
|