initial release for dnsd.
This commit is contained in:
nofreude
parent
4b9a16653a
commit
50df77a8a8
|
|
@ -0,0 +1,674 @@
|
|||
;; ---------------------
|
||||
;; --- 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*))))
|
||||
|
|
@ -0,0 +1,836 @@
|
|||
; ------------------
|
||||
; --- DNS-Server ---
|
||||
; ------------------
|
||||
|
||||
; A DNS-Server based on the RFCs: 1034 / 1035
|
||||
|
||||
; This file is (maybe) 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.
|
||||
|
||||
; TODO:
|
||||
; -----
|
||||
|
||||
; Testing, testing, testing...
|
||||
|
||||
; Nice stuff to have:
|
||||
; * IXFR
|
||||
; * IPv6-Support
|
||||
; * Support more types (& other classes)
|
||||
; * Masterfile-parser: $GENERATE ...
|
||||
; * Some accurate way to limit the cache to a certain mem-size?
|
||||
; * Better syslog interaction.
|
||||
|
||||
; Doc-TODO:
|
||||
; - Master-File-Parser
|
||||
; - Cache
|
||||
; - Database
|
||||
; - dnsd messages
|
||||
; - dnsd-options
|
||||
|
||||
; Message Example (Query):
|
||||
; ------------------------
|
||||
|
||||
; (define *query-example*
|
||||
; (make-message (make-header 0815 (make-flags 1 0 #f #f #f #f 0 0) 1 0 0 0)
|
||||
; (list (make-question "uni-tuebingen.de."
|
||||
; (message-type a)
|
||||
; (message-class in)))
|
||||
; '() '() '() '()))
|
||||
|
||||
|
||||
;; Assignment procedures for messages (basically dns.scm extension)
|
||||
;; ----------------------------------------------------------------
|
||||
|
||||
;; Set the truncation bit of an octet-message (for UDP):
|
||||
;; TYPE: message x boolean -> message
|
||||
(define (octet-msg-change-truncation msg bool)
|
||||
(let* ((id (take msg 2))
|
||||
(rest (drop msg 3))
|
||||
(flag (char->ascii (caddr msg)))
|
||||
(flag-RD (if (even? flag) 0 1))
|
||||
(flag-shift (arithmetic-shift flag -2)))
|
||||
(append id (list (ascii->char
|
||||
(+ flag-RD (arithmetic-shift
|
||||
(+ (if bool 1 0)
|
||||
(arithmetic-shift flag-shift 1)) 1))))
|
||||
rest)))
|
||||
|
||||
|
||||
;; Interpreting the results of db-lookup-rec. Is there a zone in the db:
|
||||
;; TYPE: '(list-of-ans list-of-aut list-of-add boolean) -> boolean
|
||||
(define (no-zone? res-l)
|
||||
(and (null? (car res-l)) (null? (cadr res-l))
|
||||
(null? (caddr res-l)) (not (cadddr res-l))))
|
||||
|
||||
|
||||
;; A reply is chacheworthy if it contains no errors and is authoritative.
|
||||
;; TYPE: message -> boolean
|
||||
(define (msg-cachable? msg)
|
||||
(and (eq? 'dns-no-error (flags-response-code
|
||||
(header-flags (message-header msg))))
|
||||
(flags-authoritative? (header-flags (message-header msg)))))
|
||||
|
||||
|
||||
;; ------------
|
||||
;; --- AXFR ---
|
||||
;; ------------
|
||||
|
||||
;; AXFR is triggered by the zone-management-thread below:
|
||||
;; TYPE: rr x string x message-class x dnsd-options -> boolean
|
||||
(define (axfr-update soa-rr zone-name class dnsd-options dnsddb-options)
|
||||
|
||||
;; Search for the primary nameserver (msg) & get the soa-rr (msg2)
|
||||
;; TYPE: string x string x message-class x dnsd-options -> soa-rr x ns-ip
|
||||
(define (receive-soa-message ns-name name class dnsd-options dnsddb-options)
|
||||
(let* ((ip? (dnsddb-options-master-ip dnsddb-options))
|
||||
;; Lookup the IP or use dnsddb-options-master-ip
|
||||
(nameserver
|
||||
(if (and ip? (ip-string? ip?))
|
||||
(ip-string->address32 ip?)
|
||||
(let* ((msg (dnsd-ask-resolver-rec
|
||||
(make-simple-query-message ns-name
|
||||
(message-type a) class)
|
||||
(network-protocol udp) dnsd-options))
|
||||
(error-cond (flags-response-code
|
||||
(header-flags
|
||||
(message-header msg)))))
|
||||
(if (eq? 'dns-no-error error-cond)
|
||||
(resource-record-data-a-ip
|
||||
(resource-record-data
|
||||
(car (message-answers msg))))
|
||||
(begin
|
||||
(dnsd-log (syslog-level debug)
|
||||
"AXFR: Error (~S) during rec.-lookup for the address of the primary NS for zone ~S."
|
||||
error-cond
|
||||
name)
|
||||
#f))))))
|
||||
(if nameserver
|
||||
(let* ((msg2 (dnsd-ask-resolver-direct
|
||||
(make-simple-query-message name (message-type soa)
|
||||
class)
|
||||
(list nameserver) (network-protocol udp) dnsd-options))
|
||||
(error-cond (flags-response-code
|
||||
(header-flags (message-header msg2)))))
|
||||
(if (eq? 'dns-no-error error-cond)
|
||||
(values (car (message-answers msg2)) nameserver)
|
||||
(begin
|
||||
(dnsd-log (syslog-level debug)
|
||||
"AXFR: Error (~S) during rec.-lookup for the SOA-record of the primary NS for zone ~S."
|
||||
error-cond
|
||||
name)
|
||||
(values #f #f))))
|
||||
(values #f #f))))
|
||||
|
||||
;; Try to receive an zone with an AXFR-request:
|
||||
(define (receive-axfr-message name class nameserver dnsd-options)
|
||||
(let* ((msg (dnsd-ask-resolver-direct
|
||||
(make-simple-query-message name (message-type axfr) class)
|
||||
nameserver (network-protocol tcp) dnsd-options))
|
||||
(error-cond (flags-response-code (header-flags
|
||||
(message-header msg)))))
|
||||
(if (eq? error-cond 'dns-no-error)
|
||||
(message-answers msg)
|
||||
(begin
|
||||
(dnsd-log (syslog-level debug)
|
||||
"AXFR: Error (~S) during AXFR-request for zone ~S"
|
||||
error-cond
|
||||
name)
|
||||
#f))))
|
||||
|
||||
(let* ((soa-data (resource-record-data soa-rr))
|
||||
(zone-mname (resource-record-data-soa-mname soa-data))
|
||||
(zone-serial (resource-record-data-soa-serial soa-data)))
|
||||
(dnsd-log (syslog-level info)
|
||||
"AXFR: Starting AXFR-Update for zone ~S"
|
||||
(resource-record-name soa-rr))
|
||||
(receive
|
||||
(new-soa nameserver)
|
||||
(receive-soa-message zone-mname zone-name class dnsd-options dnsddb-options)
|
||||
(if (not new-soa)
|
||||
#f
|
||||
;; Compare the serials of the local and remote soa-rrs to decide
|
||||
;; if an update is neccessary.
|
||||
(if (< zone-serial (resource-record-data-soa-serial
|
||||
(resource-record-data new-soa)))
|
||||
;; Try an (AXFR)-Update...
|
||||
(let ((axfr-zone (receive-axfr-message zone-name class
|
||||
(list nameserver)
|
||||
dnsd-options)))
|
||||
(if axfr-zone
|
||||
(begin
|
||||
(let ((first (resource-record-data (car axfr-zone)))
|
||||
(last (resource-record-data
|
||||
(list-ref axfr-zone
|
||||
(- (length axfr-zone) 1)))))
|
||||
(if (and (resource-record-data-soa? first)
|
||||
(resource-record-data-soa? last))
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"AXFR: Received AXFR-Reply for zone ~S. Starting database-update."
|
||||
zone-name)
|
||||
(db-update-zone (cdr axfr-zone)))
|
||||
#f)))
|
||||
#f))
|
||||
#t)))))
|
||||
|
||||
|
||||
;; ---------------------------------------------
|
||||
;; --- Query-lookup in database and/or cache ---
|
||||
;; ---------------------------------------------
|
||||
|
||||
;; Currently supported types:
|
||||
;; TYPE: message-type -> boolean
|
||||
(define (dnsd-supported-type? type)
|
||||
(not (null? (filter (lambda (e) (eq? type e))
|
||||
(list (message-type a)
|
||||
(message-type ns)
|
||||
(message-type cname)
|
||||
(message-type soa)
|
||||
(message-type ptr)
|
||||
(message-type hinfo)
|
||||
(message-type mx)
|
||||
(message-type txt)
|
||||
(message-type axfr)
|
||||
(message-type mailb); Mailbox-related rrs. Here: mx
|
||||
(message-type *))))))
|
||||
|
||||
|
||||
;; TODO: Find out how to handle a standard query with multiple questions?
|
||||
;; Should that be allowed at all?
|
||||
|
||||
|
||||
;; Main algorithm for incoming queries. Responsibilities:
|
||||
;; - decides if the query-type is implemented
|
||||
;; - decides if and when to use cache/db-lookup/recursive lookup
|
||||
;; TYPE: message x dnsd-options -> message
|
||||
(define (lookup-query query dnsd-options)
|
||||
(let ((query-flags (header-flags (message-header query))))
|
||||
;; What OPCODE do we have here?
|
||||
(cond
|
||||
;; * [1] standard query (the only supported so far)
|
||||
((= 0 (flags-opcode query-flags))
|
||||
(let* ((question (car (message-questions query)))
|
||||
(qname (question-name question))
|
||||
(qclass (question-class question))
|
||||
(qtype (question-type question)))
|
||||
;; What kind of QTYPE do we have?
|
||||
(cond
|
||||
;; AXFR (252): A zone transfer... .
|
||||
((and (eq? (message-type axfr) qtype)
|
||||
(dnsd-options-use-axfr? dnsd-options))
|
||||
(let ((zone (db-get-zone-for-axfr qname qclass)))
|
||||
;; TODO: Is it okay to send the whole zone?
|
||||
;; Maybe there should be checked who is asking?
|
||||
(make-response query (list zone '() '() #t) dnsd-options)))
|
||||
;; Supported QTYPES:
|
||||
((dnsd-supported-type? qtype)
|
||||
;; Try to get a database reply
|
||||
(let ((res-l (if (dnsd-options-use-db? dnsd-options)
|
||||
(receive
|
||||
(anli auli adli aufl)
|
||||
(db-lookup-rec qname qclass qtype)
|
||||
(list anli auli adli aufl))
|
||||
(list '() '() '() #f))))
|
||||
;; Use recursion for local-result: '(() () () #f)
|
||||
(if (and (dnsd-options-use-recursion? dnsd-options)
|
||||
(no-zone? res-l)
|
||||
(flags-recursion-desired? query-flags))
|
||||
(dnsd-ask-resolver-rec query (network-protocol udp) dnsd-options)
|
||||
(make-response query res-l dnsd-options))))
|
||||
;; Unsupported QTYPEs:
|
||||
(else (msg-set-rcode! query 4) query))))
|
||||
;; This kind of queries are not implemented:
|
||||
;; * [2] inverse query (not really used anymore (see RFC 3425))
|
||||
;; * [3] server status request (marked experimental in RFC 1035)
|
||||
;; * [4-15] reserved for future use (RFC 1035)
|
||||
(else (msg-set-rcode! query 4) query))))
|
||||
|
||||
|
||||
;; --------------
|
||||
;; --- Server ---
|
||||
;; --------------
|
||||
|
||||
;; Management of a zone:
|
||||
;; ---------------------
|
||||
|
||||
;; Management consists of periodically checking the local files for
|
||||
;; new information for primary-zones and to trigger AXFR-Updates for secondary
|
||||
;; zones.
|
||||
;; TYPE channel x channel x dnsd-options x dnsddb-options -> new-thread
|
||||
(define (dnsd-zone-mgt-thread ch-usr1 ch-usr2 dnsd-options dnsddb-options)
|
||||
|
||||
(define (wait-thread zone-refresh ch-wakeup dnsd-options)
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let ((refresh (* zone-refresh 1000)))
|
||||
(if (< refresh (dnsd-options-retry-interval dnsd-options))
|
||||
(sleep (dnsd-options-retry-interval dnsd-options))
|
||||
(sleep refresh))
|
||||
(sync (send-rv ch-wakeup #t))))))
|
||||
|
||||
(let* ((dnsd-options dnsd-options)
|
||||
(ch-wakeup (make-channel))
|
||||
(zone-name (dnsddb-options-name dnsddb-options))
|
||||
(type (dnsddb-options-type dnsddb-options))
|
||||
(primary? (or (string-ci=? type "master")
|
||||
(string-ci=? type "primary")))
|
||||
(class (dnsddb-options-class dnsddb-options)))
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let refresh-loop ()
|
||||
(let* ((soa-data (resource-record-data
|
||||
(db-get-zone-soa-rr zone-name class)))
|
||||
(zone-refresh (resource-record-data-soa-refresh soa-data))
|
||||
(retry-val (resource-record-data-soa-retry soa-data))
|
||||
(expire-val (resource-record-data-soa-expire soa-data)))
|
||||
;; Start thread for wakeup-channel:
|
||||
(wait-thread zone-refresh ch-wakeup dnsd-options)
|
||||
(let inner-loop ()
|
||||
(sync
|
||||
(choose
|
||||
;; Set new dnsd-options:
|
||||
(wrap (receive-rv ch-usr1)
|
||||
(lambda (new-dnsd-options)
|
||||
(set! dnsd-options new-dnsd-options)
|
||||
(inner-loop)))
|
||||
;; Terminate the thread if a reload is signaled:
|
||||
(wrap (receive-rv ch-usr2)
|
||||
(lambda (ignore) #t))
|
||||
;; Try a refresh:
|
||||
(wrap (receive-rv ch-wakeup)
|
||||
(lambda (ignore)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Reloading zone ~S"
|
||||
zone-name)
|
||||
;; Primary or secondary zone?
|
||||
(if (if primary?
|
||||
(not
|
||||
(dnsd-reload-zone dnsd-options dnsddb-options))
|
||||
(axfr-update (db-get-zone-soa-rr zone-name class)
|
||||
zone-name class dnsd-options
|
||||
dnsddb-options))
|
||||
;; Case the refresh didn't work:
|
||||
(if (< expire-val 0)
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"Zone ~S expired. Deleting from db!"
|
||||
zone-name)
|
||||
(db-clear-zone zone-name class)
|
||||
(inner-loop)) ;; Wait for termination...
|
||||
(begin
|
||||
(set! expire-val (- expire-val retry-val))
|
||||
(wait-thread retry-val ch-wakeup dnsd-options)
|
||||
(set! retry-val (* 2 retry-val))
|
||||
(inner-loop)))
|
||||
(refresh-loop)))))))))))))
|
||||
|
||||
|
||||
;; Reload options from dnsd-options.scm:
|
||||
;; -------------------------------------
|
||||
|
||||
;; If an error occures (malformed file etc.) the old options are used as the
|
||||
;; return value.
|
||||
;; TYPE: dnsd-options -> dnsd-options
|
||||
(define (dnsd-reload-options dnsd-options)
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while reloading dnsd-options.scm")
|
||||
;(dnsd-log (syslog-level debug)"Above condition is: ~A" condition)
|
||||
dnsd-options)
|
||||
(lambda ()
|
||||
(let ((path (dnsd-options-dir dnsd-options)))
|
||||
(dnsd-log (syslog-level info)
|
||||
"Reloading dnsd-options.scm with path: ~S"
|
||||
path)
|
||||
(let* ((port (if (file-name-directory? path)
|
||||
(open-input-file (string-append path "dnsd-options.scm"))
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"Bad path (~S) in dnsd-options. Trying ./dnsd-options.scm"
|
||||
path)
|
||||
(open-input-file "./dnsd-options.scm"))))
|
||||
(options? (read port)))
|
||||
(close-input-port port)
|
||||
(make-options-from-list options? dnsd-options))))))
|
||||
|
||||
|
||||
;; (Re)load zones from dnsd-zones.scm:
|
||||
;; -----------------------------------
|
||||
|
||||
;; Make a fake secondary zone for the management thread:
|
||||
;; TYPE: dnsddb-options -> list-of-rrs
|
||||
(define (make-sec-zone dnsddb-options)
|
||||
(list
|
||||
(dns-rr-soa (dnsddb-options-name dnsddb-options)
|
||||
(message-class in)
|
||||
0
|
||||
(list
|
||||
(dnsddb-options-master-name dnsddb-options)
|
||||
"unknown.mail-adress."
|
||||
0 ;; smallest serial possible
|
||||
5 ;; fast first fetch
|
||||
(* 60 10) ;; fast retry
|
||||
(* 60 60 24 7) ;; expires
|
||||
0)))) ;; min TTL
|
||||
|
||||
|
||||
;; Reload a zone...
|
||||
;; TYPE: zone x string x dnsd-options -> boolean
|
||||
(define (dnsd-reload-zone dnsd-options dnsddb-options)
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while reloading a zone.")
|
||||
;(dnsd-log (syslog-level debug) "Above condition is: ~A" condition)
|
||||
#f)
|
||||
(lambda ()
|
||||
(let* ((path (dnsd-options-dir dnsd-options))
|
||||
(file (dnsddb-options-file dnsddb-options))
|
||||
(zone-name (dnsddb-options-name dnsddb-options)))
|
||||
;; Handle secondary zones...
|
||||
(if (dnsddb-options-master-name dnsddb-options)
|
||||
(db-update-zone (make-sec-zone dnsddb-options))
|
||||
;; handle primary zones
|
||||
(and-let* ((zone-list (if (string-ci=?
|
||||
(dnsddb-options-filetype dnsddb-options)
|
||||
"rfc")
|
||||
(parse-mf file dnsd-options)
|
||||
(load (string-append path file))))
|
||||
(soa-zone-name (maybe-get-soa-rr-name zone-list)))
|
||||
(if (string-ci=? zone-name soa-zone-name)
|
||||
(db-update-zone zone-list)
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"Zone names doesn't fit between file (%S) and dnsd-zones (%S)"
|
||||
soa-zone-name zone-name)
|
||||
(error " ")))))))))
|
||||
|
||||
|
||||
;; Initialize // reload the zones which are defined in dnsd-zones.scm
|
||||
;; TYPE: channel x channel x dnsd-options -> unspecific
|
||||
(define (dnsd-reload-dnsd-zones ch-usr1 ch-usr2 dnsd-options)
|
||||
(let ((usr1-channel-list '())
|
||||
(usr2-channel-list '())
|
||||
(dnsd-options dnsd-options))
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(sync
|
||||
(choose
|
||||
(wrap (receive-rv ch-usr1)
|
||||
(lambda (new-dnsd-options)
|
||||
(set! dnsd-options new-dnsd-options)
|
||||
(for-each (lambda (e) (sync (send-rv e new-dnsd-options)))
|
||||
usr1-channel-list)
|
||||
(loop)))
|
||||
(wrap
|
||||
(receive-rv ch-usr2)
|
||||
(lambda (ignore)
|
||||
;; Terminate all old management-threads:
|
||||
(for-each (lambda (e) (sync (send-rv e 'terminate)))
|
||||
usr2-channel-list)
|
||||
(set! usr1-channel-list '())
|
||||
(set! usr2-channel-list '())
|
||||
;; Clear database:
|
||||
(db-clear-database)
|
||||
(if (dnsd-options-use-db? dnsd-options)
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while reloading dnsd-zones.scm")
|
||||
#f)
|
||||
(lambda ()
|
||||
(let* ((path (dnsd-options-dir dnsd-options))
|
||||
(port (if (file-name-directory? path)
|
||||
(open-input-file
|
||||
(string-append path "dnsd-zones.scm"))
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"Bad path (~S) in dnsd-zones. Trying ./dnsd-zones.scm"
|
||||
path)
|
||||
(open-input-file "./dnsd-zones.scm"))))
|
||||
(zone-l (read port)))
|
||||
(close-input-port port)
|
||||
(if (list? zone-l)
|
||||
(for-each
|
||||
(lambda (e)
|
||||
(let ((dnsddb-options (make-db-options-from-list e))
|
||||
(ch-usr1-thread (make-channel))
|
||||
(ch-usr2-thread (make-channel)))
|
||||
(if (dnsd-reload-zone dnsd-options dnsddb-options)
|
||||
(begin
|
||||
(dnsd-zone-mgt-thread ch-usr1-thread
|
||||
ch-usr2-thread
|
||||
dnsd-options
|
||||
dnsddb-options)
|
||||
(set! usr1-channel-list
|
||||
(cons ch-usr1-thread
|
||||
usr1-channel-list))
|
||||
(set! usr2-channel-list
|
||||
(cons ch-usr2-thread
|
||||
usr2-channel-list))))))
|
||||
zone-l)
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"Bad sytax in dnsd-zones.scm.")
|
||||
#f)))))
|
||||
#f)
|
||||
(loop))))))))))
|
||||
|
||||
|
||||
;; Management of the datastructures (Cache / SLIST / Blacklist)
|
||||
;; ------------------------------------------------------------
|
||||
|
||||
;; Clean dnsd-cache/slist every now and then.
|
||||
;; TYPE: channel x dnsd-options -> unspecific
|
||||
(define (dnsd-management-thread ch-usr1 dnsd-options)
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let ((ch-wait (make-channel))
|
||||
(dnsd-options dnsd-options))
|
||||
(let loop ()
|
||||
(let ((time-in-sec (dnsd-options-cleanup-interval dnsd-options)))
|
||||
;; Starting this thread to wait on ch-wait:
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(sleep (* time-in-sec 1000))
|
||||
(sync (send-rv ch-wait 'whatever))))
|
||||
(sync
|
||||
(choose
|
||||
(wrap (receive-rv ch-wait)
|
||||
(lambda (ignore)
|
||||
(if (dnsd-options-use-cache? dnsd-options)
|
||||
(dnsd-cache-clean!))
|
||||
(dnsd-slist-clean!)
|
||||
;; deprecated (dnsd-blacklist-clean! dnsd-options)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Cleaned CACHE and SLIST. Current interval is ~D seconds."
|
||||
time-in-sec)
|
||||
#t))
|
||||
(wrap (receive-rv ch-usr1)
|
||||
(lambda (value) (set! dnsd-options value)))))
|
||||
(loop)))))))
|
||||
|
||||
|
||||
;; Pre- and post-processing of messages:
|
||||
;; -------------------------------------
|
||||
|
||||
(define (dnsd-pre message socket-addr dnsd-options)
|
||||
(dnsd-pre/post message socket-addr dnsd-options "dnsd-pre.scm"))
|
||||
|
||||
(define (dnsd-post message socket-addr dnsd-options)
|
||||
(dnsd-pre/post message socket-addr dnsd-options "dnsd-post.scm"))
|
||||
|
||||
;; Load the pre- and post-processing files...
|
||||
;; TYPE: msg x socket-addr x dnsd-options x string -> msg x dnsd-options
|
||||
(define (dnsd-pre/post message socket-addr dnsd-options file)
|
||||
(if (dnsd-options-use-pre/post dnsd-options)
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(values message dnsd-options))
|
||||
(lambda ()
|
||||
(let* ((dir (dnsd-options-dir dnsd-options))
|
||||
(path (if (file-name-directory? dir)
|
||||
(string-append dir file)
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"Bad dir (~S) in options. Trying ./~S"
|
||||
dir file)
|
||||
(string-append "./" file)))))
|
||||
((load path) message socket-addr dnsd-options))))
|
||||
(values message dnsd-options)))
|
||||
|
||||
|
||||
;; UDP thread:
|
||||
;; -----------
|
||||
|
||||
;; Starts the main UDP-loop:
|
||||
;; TYPE: socket x channel x dnsd-options -> unspecific
|
||||
(define (dnsd-server-loop-udp socket ch-usr1 dnsd-options)
|
||||
(let ((ch-receive (make-channel))
|
||||
(max-con (make-semaphore (dnsd-options-max-connections dnsd-options)))
|
||||
(dnsd-options dnsd-options))
|
||||
;; Thread for incoming UDP-messages:
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while processing a UDP-query.")
|
||||
;(dnsd-log (syslog-level debug) "Above condition is: ~A" condition)
|
||||
;(loop))
|
||||
decline)
|
||||
(lambda ()
|
||||
(semaphore-wait max-con)
|
||||
(receive
|
||||
(msg addr)
|
||||
(receive-message/partial socket 512)
|
||||
(sync (send-rv ch-receive (cons msg addr)))
|
||||
(loop)))))))
|
||||
;; Choose between user-interrupt or query-processing
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(sync
|
||||
(choose
|
||||
(wrap (receive-rv ch-receive)
|
||||
(lambda (value)
|
||||
(udp-processing-thread (car value) (cdr value)
|
||||
socket max-con dnsd-options)))
|
||||
(wrap (receive-rv ch-usr1)
|
||||
(lambda (value)
|
||||
(set! dnsd-options value)
|
||||
(set-semaphore! max-con (dnsd-options-max-connections
|
||||
dnsd-options))))))
|
||||
(loop))))))
|
||||
|
||||
|
||||
;; Start the thread for processing a UDP-query.
|
||||
;; TYPE: message x address x socket x dnsd-options -> unspecific
|
||||
(define (udp-processing-thread msg addr socket max-con dnsd-options)
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while processing a UDP-query.")
|
||||
;(dnsd-log (syslog-level debug) "Above condition is: ~A" condition)
|
||||
(semaphore-post max-con)
|
||||
;#f)
|
||||
decline)
|
||||
(lambda ()
|
||||
(let ((msg (parse (string->list msg))))
|
||||
(if (not msg)(error "Couldn't parse the message."))
|
||||
;; Preprocess the message...
|
||||
(receive
|
||||
(msg dnsd-options)
|
||||
(dnsd-pre msg addr dnsd-options)
|
||||
(if (not msg) (semaphore-post max-con)
|
||||
(let* ((msg-header (message-header msg))
|
||||
(msg-flags (header-flags msg-header))
|
||||
(msg-trunc? (flags-truncated? msg-flags)))
|
||||
(if msg-trunc? (error "Couldn't process truncated query."))
|
||||
(let ((reply (lookup-query msg dnsd-options)))
|
||||
(if (not reply) (error "Lookup produced no reply."))
|
||||
;; Postprocessing the message:
|
||||
(receive
|
||||
(reply dnsd-options)
|
||||
(dnsd-post reply addr dnsd-options)
|
||||
(if (not reply) (semaphore-post max-con)
|
||||
(let* ((octet-list (mc-message->octets reply))
|
||||
(l (length octet-list)))
|
||||
(if (> l 512) ; Use message-truncation?
|
||||
(let* ((msg (octet-msg-change-truncation
|
||||
octet-list #t))
|
||||
(to-send (list->string (take msg 512))))
|
||||
(receive
|
||||
(host-addr port)
|
||||
(socket-address->internet-address addr)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Sending truncated UDP-response to: ~A"
|
||||
(address32->ip-string host-addr))
|
||||
(send-message socket to-send 0 511 0 addr)))
|
||||
(begin
|
||||
(send-message socket (list->string octet-list)
|
||||
0 l 0
|
||||
addr)))
|
||||
(semaphore-post max-con))))))))))))))
|
||||
|
||||
|
||||
|
||||
;; TCP thread:
|
||||
;; -----------
|
||||
|
||||
;; Main TCP-loop:
|
||||
;; TYPE: socket x channel x dnsd-options -> unspecific
|
||||
(define (dnsd-server-loop-tcp socket ch-usr1 dnsd-options)
|
||||
(let ((ch-receive (make-channel))
|
||||
(max-con (make-semaphore (dnsd-options-max-connections dnsd-options)))
|
||||
(dnsd-options dnsd-options))
|
||||
;; Thread for incoming TCP-messages:
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while processing a TCP-query.")
|
||||
;(dnsd-log (syslog-level debug) "Above condition is: ~A" condition)
|
||||
(loop))
|
||||
;decline)
|
||||
(lambda ()
|
||||
(semaphore-wait max-con)
|
||||
(receive
|
||||
(private-socket addr)
|
||||
(accept-connection socket)
|
||||
(sync (send-rv ch-receive (cons private-socket addr)))
|
||||
(loop)))))))
|
||||
;; Choose between user-interrupt or query-processing
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(sync
|
||||
(choose
|
||||
(wrap (receive-rv ch-receive)
|
||||
(lambda (value)
|
||||
(tcp-processing-thread (car value) (cdr value)
|
||||
max-con dnsd-options)))
|
||||
(wrap (receive-rv ch-usr1)
|
||||
(lambda (value)
|
||||
(set! dnsd-options value)
|
||||
(set-semaphore! max-con (dnsd-options-max-connections
|
||||
dnsd-options))))))
|
||||
(loop))))))
|
||||
|
||||
|
||||
;; Start the thread for processing a TCP-query:
|
||||
;; TYPE: address x socket x dnsd-options -> unspecific
|
||||
(define (tcp-processing-thread socket addr max-con dnsd-options)
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while processing a TCP-query.")
|
||||
;(dnsd-log (syslog-level debug) "Above condition is: ~A" condition)
|
||||
(semaphore-post max-con)
|
||||
(close-socket socket) #f)
|
||||
(lambda ()
|
||||
(let* ((inport (socket:inport socket))
|
||||
(outport (socket:outport socket))
|
||||
;; A tcp-message has a 2-octet-length size tag:
|
||||
(front (read-char inport))
|
||||
(rear (read-char inport))
|
||||
(size-tag (octet-pair->number front rear))
|
||||
(octet-msg (read-string size-tag inport))
|
||||
(msg (parse (string->list octet-msg))))
|
||||
(if (not msg)(error "Couldn't parse the message"))
|
||||
;; Preprocessing:
|
||||
(receive
|
||||
(msg dnsd-options)
|
||||
(dnsd-pre msg addr dnsd-options)
|
||||
(if (not msg)
|
||||
(begin
|
||||
(semaphore-post max-con)
|
||||
(close-socket socket))
|
||||
(let* ((msg-header (message-header msg))
|
||||
(msg-flags (header-flags msg-header))
|
||||
(msg-trunc? (flags-truncated? msg-flags)))
|
||||
(if msg-trunc? (error "Couldn't process truncated query."))
|
||||
(let ((reply (lookup-query msg dnsd-options)))
|
||||
(if (not reply) (error "Lookup produced no reply."))
|
||||
;; Postprocessing:
|
||||
(receive
|
||||
(reply dnsd-options)
|
||||
(dnsd-post reply addr dnsd-options)
|
||||
(if (not reply)
|
||||
(begin
|
||||
(semaphore-post max-con)
|
||||
(close-socket socket))
|
||||
(let* ((reply (mc-message->octets reply))
|
||||
(l (number->octet-pair (length reply))))
|
||||
(write-string (list->string (append l reply)) outport)
|
||||
(semaphore-post max-con)
|
||||
(close-socket socket))))))))))))))
|
||||
|
||||
|
||||
;; Initialize and start UDP and TCP threads:
|
||||
;; TYPE: dnsd-options -> unspecific
|
||||
(define (init-dnsd dnsd-options)
|
||||
(let ((ch-usr1-udp (make-channel))
|
||||
(ch-usr1-tcp (make-channel))
|
||||
(ch-usr1-mgt (make-channel))
|
||||
(ch-usr1-zones (make-channel))
|
||||
(ch-usr2-zones (make-channel))
|
||||
(dnsd-options dnsd-options))
|
||||
(call-with-current-continuation
|
||||
(lambda (escape)
|
||||
;; Maybe load the options from file:
|
||||
(set! dnsd-options (dnsd-reload-options dnsd-options))
|
||||
;; Initializing signal-handler(s)
|
||||
;; * USR1 (reload dnsd-options.scm)
|
||||
;; Log debug-level in syslog?
|
||||
(with-syslog-destination
|
||||
(string-append "dnsd (" (number->string (pid)) ")")
|
||||
#f
|
||||
#f
|
||||
(if (dnsd-options-debug-mode dnsd-options)
|
||||
(syslog-mask-upto (syslog-level info))
|
||||
#f)
|
||||
(lambda ()
|
||||
(set-interrupt-handler
|
||||
interrupt/usr1
|
||||
(lambda (ignore)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Interrupt/USR1: Reloading options.")
|
||||
(set! dnsd-options (dnsd-reload-options dnsd-options))
|
||||
(fork-thread
|
||||
(lambda () (sync (send-rv ch-usr1-udp dnsd-options))))
|
||||
(fork-thread
|
||||
(lambda () (sync (send-rv ch-usr1-tcp dnsd-options))))
|
||||
(fork-thread
|
||||
(lambda () (sync (send-rv ch-usr1-mgt dnsd-options))))
|
||||
(fork-thread
|
||||
(lambda () (sync (send-rv ch-usr1-zones dnsd-options))))))
|
||||
;; * USR2 (reload dnsd-zones.scm)
|
||||
(set-interrupt-handler
|
||||
interrupt/usr2
|
||||
(lambda (ignore)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Interrupt/USR2: Reloading zones.")
|
||||
(sync (send-rv ch-usr2-zones 'ignore))))
|
||||
;; Initializing cleanup thread:
|
||||
(dnsd-management-thread ch-usr1-mgt dnsd-options)
|
||||
;; Initialize & load the database:
|
||||
(dnsd-reload-dnsd-zones ch-usr1-zones ch-usr2-zones dnsd-options)
|
||||
(sync (send-rv ch-usr2-zones 'ignore))
|
||||
;; Initializing tcp/upd sockets & start thread:
|
||||
(let* ((the-port (dnsd-options-port dnsd-options))
|
||||
(udp-socket (create-socket protocol-family/internet
|
||||
socket-type/datagram))
|
||||
(tcp-socket (create-socket protocol-family/internet
|
||||
socket-type/stream))
|
||||
(socket-addr (internet-address->socket-address
|
||||
internet-address/any the-port)))
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Coudn't start dnsd. Port ~D is already in use."
|
||||
the-port)
|
||||
(close-socket udp-socket)
|
||||
(close-socket tcp-socket)
|
||||
(escape 'douh!))
|
||||
(lambda ()
|
||||
(dnsd-log (syslog-level info)
|
||||
"Starting the service on port: ~D"
|
||||
the-port)
|
||||
(bind-socket udp-socket socket-addr)
|
||||
(bind-socket tcp-socket socket-addr)
|
||||
(listen-socket tcp-socket 10))) ; TODO: How big should the queue be?
|
||||
;; Start the UDP-Loop:
|
||||
(fork-thread (lambda () (dnsd-server-loop-udp udp-socket ch-usr1-udp
|
||||
dnsd-options)))
|
||||
;; Start the TCP-Loop:
|
||||
(fork-thread (lambda () (dnsd-server-loop-tcp tcp-socket ch-usr1-tcp
|
||||
dnsd-options))))))))))
|
||||
|
||||
;; Entry-Point for run-dnsd
|
||||
;; ------------------------
|
||||
|
||||
(define (dnsd-start . dir)
|
||||
(with-syslog-destination
|
||||
(string-append "dnsd (" (number->string (pid)) ")") #f #f #f
|
||||
(lambda ()
|
||||
(if (null? dir)
|
||||
(init-dnsd (make-default-dnsd-options))
|
||||
(init-dnsd (with-dir
|
||||
(file-name-as-directory (car dir))
|
||||
(make-default-dnsd-options)))))))
|
||||
|
||||
Loading…
Reference in New Issue