;; --------------------- ;; --- 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 ; ; 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*))))