diff --git a/driver.rkt b/driver.rkt index 4748d70..5dbba8f 100644 --- a/driver.rkt +++ b/driver.rkt @@ -2,12 +2,14 @@ ;; Simple imperative DNS server. +(require racket/match) (require racket/udp) (require racket/set) (require racket/bool) (require (planet tonyg/bitsyntax)) (require "api.rkt") (require "codec.rkt") +(require "dump-bytes.rkt") ;; Instantiated with a SOA record for the zone it is serving as well ;; as a zone's worth of DNS data which is used to answer queries @@ -22,6 +24,10 @@ ;; determines subzones based on the RRs it is configured with at ;; startup. +;; TODO: maybe store domain names big-end first? It'd make bailiwick +;; and subzone checks into prefix rather than suffix checks. It makes +;; domain names into paths through the DNS DB tree. + ;; compile-db : ListOf -> Hash> ;; Builds an immutable hash table from the given RRs, suitable for ;; quickly looking up answers to queries. @@ -138,16 +144,45 @@ (define s (udp-open-socket #f #f)) (udp-bind! s #f port-number) - (let service-loop () + (define (service-loop) + (with-handlers ((exn? (lambda (e) + (display "Error in DNS service handler:") (newline) + (write e) + (newline) + (newline)))) + (read-and-process-request)) + (service-loop)) - (define buffer - (make-bytes 512)) + (define (read-and-process-request) + (define buffer (make-bytes 512)) (define-values (packet-length source-hostname source-port) (udp-receive! s buffer)) - (define request-message - (packet->dns-message (sub-bit-string buffer 0 (* 8 packet-length)))) - ;; TODO: check opcode in request + (define (send-error error-response-code) + (bit-string-case buffer + ([ (id :: bits 16) (:: binary) ] + (udp-send-to s source-hostname source-port + (dns-message->packet + (dns-message id 'response 'query + 'non-authoritative 'not-truncated + 'no-recursion-desired 'no-recursion-available + error-response-code '() '() '() '())))) + (else + ;; We don't even have enough information in the packet to reply. + (void)))) + + (display "----------------------------------------") (newline) + (write (subbytes buffer 0 packet-length)) (newline) + (dump-bytes! buffer packet-length) + (flush-output) + + (define request-message + (with-handlers ((exn? (lambda (e) + (send-error 'format-error) + (raise e)))) + (packet->dns-message (subbytes buffer 0 packet-length)))) + + ;;(write request-message) (newline) (define (make-reply name send-name-error? answers authorities additional) (dns-message (dns-message-id request-message) @@ -163,84 +198,82 @@ (set->list authorities) (set->list additional))) - ;; TODO: what if there are multiple questions in one request - ;; packet? Single reply, or multiple replies? djbdns looks like - ;; it handles exactly one question per request... + (define reply-packet + (with-handlers ((exn? (lambda (e) + (send-error 'server-failure) + (raise e)))) + ;; TODO: check opcode and direction in request + (define questions (dns-message-questions request-message)) + (if (null? questions) + #f ;; No questions -> don't send any replies + (begin + ;; TODO: what if there are multiple questions in one + ;; request packet? Single reply, or multiple replies? + ;; Process the additional questions, or ignore them? + ;; djbdns looks like it handles exactly one question per + ;; request, ignoring any excess... + (dns-message->packet (answer-question (car questions) make-reply)))))) ;; TODO: Truncation + (when reply-packet + (udp-send-to s source-hostname source-port reply-packet))) - ;; TODO: maybe store domain names big-end first? It'd make - ;; bailiwick and subzone checks into prefix rather than suffix - ;; checks. It makes domain names into paths through the DNS DB - ;; tree. - - (define (answer-question q) - (let resolve ((name (question-name q))) - ;; Notice that we claim to be authoritative for our configured - ;; zone. If we ever answer name-error, that means there are no - ;; RRs *at all* for the queried name. If there are RRs for the - ;; queried name, but they happen not to be the ones asked for, - ;; name-error must *not* be returned: instead, a normal - ;; no-error reply is sent with an empty answer section. - ;; - ;; If we wanted to support caching of negative replies, we'd - ;; follow the guidelines in section 4.3.4 "Negative response - ;; caching" of RFC1034, adding our zone SOA with an - ;; appropriate TTL to the additional section of the reply. - ;; - ;; TODO: We support returning out-of-bailiwick records (glue) - ;; here. Reexamine the rules for doing so. - (cond - ((hash-ref zone name #f) => - ;; The full name matches in our zone database. - (lambda (rrset) - (define filtered-rrs (filter-rrs rrset (question-type q) (question-class q))) - (define cnames (filter-by-type rrset 'cname)) - (define base-reply (make-reply name - #f - (set-union cnames filtered-rrs) - (set soa-rr) - (set))) - ;; Algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a. - (if (and (not (set-empty? cnames)) - (not (eqv? (question-type q) 'cname))) - (foldl (lambda (cname-rr current-reply) - (merge-replies current-reply - (resolve (rr-rdata cname-rr)))) - base-reply - (set->list cnames)) - base-reply))) - ((referral-for name soa-rr zone) => - ;; No full name match, but a referral to somewhere beneath our - ;; SOA but within our zone. - (lambda (ns-rrset) - (make-reply name - #f - ns-rrset - (set soa-rr) - (additional-section/a zone (set-map ns-rrset rr-rdata))))) - (else - ;; Neither a full name match nor a referral is - ;; available. Answer name-error (NXDOMAIN) if the queried - ;; name is in-bailiwick, or a normal no-error otherwise. + (define (answer-question q make-reply) + (let resolve ((name (question-name q))) + ;; Notice that we claim to be authoritative for our configured + ;; zone. If we ever answer name-error, that means there are no + ;; RRs *at all* for the queried name. If there are RRs for the + ;; queried name, but they happen not to be the ones asked for, + ;; name-error must *not* be returned: instead, a normal + ;; no-error reply is sent with an empty answer section. + ;; + ;; If we wanted to support caching of negative replies, we'd + ;; follow the guidelines in section 4.3.4 "Negative response + ;; caching" of RFC1034, adding our zone SOA with an + ;; appropriate TTL to the additional section of the reply. + ;; + ;; TODO: We support returning out-of-bailiwick records (glue) + ;; here. Reexamine the rules for doing so. + (cond + ((hash-ref zone name #f) => + ;; The full name matches in our zone database. + (lambda (rrset) + (define filtered-rrs (filter-rrs rrset (question-type q) (question-class q))) + (define cnames (filter-by-type rrset 'cname)) + (define base-reply (make-reply name + #f + (set-union cnames filtered-rrs) + (set soa-rr) + (set))) + ;; Algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a. + (if (and (not (set-empty? cnames)) + (not (eqv? (question-type q) 'cname))) + (foldl (lambda (cname-rr current-reply) + (merge-replies current-reply + (resolve (rr-rdata cname-rr)))) + base-reply + (set->list cnames)) + base-reply))) + ((referral-for name soa-rr zone) => + ;; No full name match, but a referral to somewhere beneath our + ;; SOA but within our zone. + (lambda (ns-rrset) (make-reply name - (in-bailiwick? name (rr-name soa-rr)) - (set) - (set) - (set)))))) + #f + ns-rrset + (set soa-rr) + (additional-section/a zone (set-map ns-rrset rr-rdata))))) + (else + ;; Neither a full name match nor a referral is + ;; available. Answer name-error (NXDOMAIN) if the queried + ;; name is in-bailiwick, or a normal no-error otherwise. + (make-reply name + (in-bailiwick? name (rr-name soa-rr)) + (set) + (set) + (set)))))) - ;;(display "----------------------------------------") - ;;(newline) - ;;(write request-message) (newline) - - ;; TODO: properly deal with multiple questions - (for-each (lambda (q) - (define reply-message (answer-question q)) - ;;(write reply-message) (newline) - (udp-send-to s source-hostname source-port (dns-message->packet reply-message))) - (dns-message-questions request-message)) - - (service-loop))) + (service-loop)) (start-server 5555 (rr '(#"example") 'soa 'in 30 diff --git a/dump-bytes.rkt b/dump-bytes.rkt new file mode 100644 index 0000000..6b568ef --- /dev/null +++ b/dump-bytes.rkt @@ -0,0 +1,45 @@ +#lang racket/base + +(provide dump-bytes!) + +(define (hex width n) + (define s (number->string n 16)) + (define slen (string-length s)) + (cond + ((< slen width) (string-append (make-string (- width slen) #\0) s)) + ((= slen width) s) + ((> slen width) (substring s 0 width)))) + +(define (dump-bytes! bs requested-count) + (define count (min requested-count (bytes-length bs))) + (define clipped (subbytes bs 0 count)) + (define (dump-hex i) + (if (< i count) + (display (hex 2 (bytes-ref clipped i))) + (display " ")) + (display #\space)) + (define (dump-char i) + (if (< i count) + (let ((ch (bytes-ref clipped i))) + (if (<= 32 ch 127) + (display (integer->char ch)) + (display #\.))) + (display #\space))) + (define (for-each-between f low high) + (do ((i low (+ i 1))) + ((= i high)) + (f i))) + (define (dump-line i) + (display (hex 8 i)) + (display #\space) + (for-each-between dump-hex i (+ i 8)) + (display ": ") + (for-each-between dump-hex (+ i 8) (+ i 16)) + (display #\space) + (for-each-between dump-char i (+ i 8)) + (display " : ") + (for-each-between dump-char (+ i 8) (+ i 16)) + (newline)) + (do ((i 0 (+ i 16))) + ((>= i count)) + (dump-line i)))