Catch errors in service; dump-bytes! utility
This commit is contained in:
Tony Garnock-Jones
parent
7bc67b0c7f
commit
50f52c6b6d
191
driver.rkt
191
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<RR> -> Hash<DomainName,ListSetOf<RR>>
|
||||
;; 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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
Loading…
Reference in New Issue