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