scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

initial release for dnsd.

This commit is contained in:
nofreude 2006-11-12 18:15:12 +00:00
parent 4b9a16653a
commit 50df77a8a8
2 changed files with 1510 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

674
scheme/dnsd/database.scm Normal file
View File

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

836
scheme/dnsd/dnsd.scm Normal file
View File

@ -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)))))))