837 lines
28 KiB
Scheme
837 lines
28 KiB
Scheme
; ------------------
|
|
; --- 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)))))))
|
|
|