From faaa81b31088ab7b1781a43ffcfaae2ddbd46500 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 21 Dec 2011 17:00:12 -0500 Subject: [PATCH] Move (and generalise) resolver logic from server into zonedb.rkt for reuse by proxy. --- api.rkt | 11 +- proxy.rkt | 260 ++++++++++++++++++------------------------ simplified-driver.rkt | 118 ++++++------------- zonedb.rkt | 63 +++++++++- 4 files changed, 217 insertions(+), 235 deletions(-) diff --git a/api.rkt b/api.rkt index 264d8f3..8b5f40e 100644 --- a/api.rkt +++ b/api.rkt @@ -2,6 +2,7 @@ ;; Definitions for use in the API to the functionality of the library. (provide (struct-out question) + (struct-out question-result) (struct-out rr) (struct-out hinfo) @@ -18,9 +19,6 @@ (require "mapping.rkt") -;; A QueryResponder is a (Question -> Either, Failure>), a -;; function from DNS query to DNS response or failure. - ;; A DomainName is a ListOf, representing a domain name. The ;; head of the list is the leftmost label; for example, www.google.com ;; is represented as '(#"www" #"google" #"com"). @@ -41,6 +39,13 @@ ;; type and class?" (struct question (name type class) #:transparent) +;; A QuestionResult is a (question-result Question CompiledZone +;; SetOf SetOf SetOf), representing the results of +;; answering a Question in the context of a given RR database, +;; possibly after recursively asking other servers for answers. +(struct question-result (question knowledge answers authorities additional) + #:transparent) + ;; An RR is a (rr DomainName RRType RRClass Uint32 RData), ;; representing a resource record. (struct rr (name type class ttl rdata) #:transparent) diff --git a/proxy.rkt b/proxy.rkt index 5937613..8ebec94 100644 --- a/proxy.rkt +++ b/proxy.rkt @@ -11,6 +11,9 @@ (require "codec.rkt") (require "zonedb.rkt") (require "dump-bytes.rkt") +(require "simple-udp-service.rkt") + +(require racket/pretty) ;; Instantiated with a collection of trusted roots to begin its ;; searches from. Performs recursive queries. Doesn't yet cache @@ -75,171 +78,134 @@ ;; format, rather than to support crucial operations in the simplest ;; possible way. -(define (authoritativeness-for dn soa-rr) - (if (in-bailiwick? dn (rr-name soa-rr)) - 'authoritative - 'non-authoritative)) +;; An Address can be an (address String Uint16) or #f, where an +;; address struct represents nonlocal UDP sockets, and #f represents +;; the local socket. This way, we don't need to know the IP or port of +;; the local socket, and we can be "multihomed". +(struct address (host port) #:prefab) ;; a UDP IP/port-number combination + +(struct bad-dns-packet (detail source target reason) #:prefab) +(struct world-message (body source target) #:prefab) + +;; ServerState +(struct world (roots continuations) #:prefab) ;; start-proxy : UInt16 ListOf -> Void ;; Starts a proxy service that will answer questions received on the ;; given UDP port based on the NS RRs it is given. -(require racket/pretty) (define (start-proxy port-number raw-roots) ;; Compile the table of roots (define roots (compile-zone-db raw-roots)) (pretty-print roots) - ;; Set up the socket - (define s (udp-open-socket #f #f)) - (udp-bind! s #f port-number) + (define initial-world (world roots (make-immutable-hash))) - (define (service-loop) - (with-handlers ((exn:break? (lambda (e) (raise e))) - (exn? (lambda (e) - (display "Error in DNS proxy handler:") (newline) - (write e) - (newline) - (newline)))) - (read-and-process-request)) - (service-loop)) + (start-udp-service + port-number + udp-packet->message + outbound-message? + message->udp-packet + (message-handlers old-world + [(? bad-dns-packet? p) + (pretty-print p) + (values '() old-world)] + [(? request-from-downstream? r) + (handle-request r old-world)] + [(? reply-from-upstream? r) + (handle-reply r old-world)]) + (lambda (unhandled state) + (error 'dns-server "Unhandled packet ~v" unhandled)) + initial-world + #:packet-size-limit 512)) - (define (read-and-process-request) - (define buffer (make-bytes 512)) - (define-values (packet-length source-hostname source-port) - (udp-receive! s buffer)) +(define (udp-packet->message packet) + (match-define (udp-packet body host port) packet) + (define a (address host port)) + (with-handlers ((exn? (lambda (e) (bad-dns-packet body a #f 'unparseable)))) + (define message (packet->dns-message body)) + (world-message message a #f))) - (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 'recursion-available - error-response-code '() '() '() '())))) - (else - ;; We don't even have enough information in the packet to reply. - (void)))) +(define (message->udp-packet m) + (match-define (world-message body _ (address host port)) m) + (udp-packet (dns-message->packet body) host port)) - (display "----------------------------------------") (newline) - (write (subbytes buffer 0 packet-length)) (newline) - (dump-bytes! buffer packet-length) - (flush-output) +(define (local-address? a) + (eq? a #f)) - (define request-message - (with-handlers ((exn? (lambda (e) - (send-error 'format-error) - (raise e)))) - (packet->dns-message (subbytes buffer 0 packet-length)))) +(define (remote-address? a) + (address? a)) - ;;(write request-message) (newline) +(define (outbound-message? m) + (and (world-message? m) + (local-address? (world-message-source m)) + (remote-address? (world-message-target m)))) - (define (make-reply name send-name-error? answers authorities additional) - (dns-message (dns-message-id request-message) - 'response - 'query - (authoritativeness-for name soa-rr) - 'not-truncated - (dns-message-recursion-desired request-message) - 'recursion-available - (if send-name-error? 'name-error 'no-error) - (dns-message-questions request-message) - (set->list answers) - (set->list authorities) - (set->list additional))) +(define (inbound-message? m) + (and (world-message? m) + (remote-address? (world-message-source m)) + (local-address? (world-message-target m)))) - (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)))))) +(define (request-from-downstream? m) + (and (inbound-message? m) + (eq? (dns-message-direction (world-message-body m)) 'request) + (eq? (dns-message-opcode (world-message-body m)) 'query))) - ;; TODO: Truncation - (when reply-packet - (udp-send-to s source-hostname source-port reply-packet))) +(define (reply-from-upstream? m) + (and (inbound-message? m) + (eq? (dns-message-direction (world-message-body m)) 'response) + (eq? (dns-message-opcode (world-message-body m)) 'query))) - (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 - #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)))))) +(define (handle-request r old-world) + (match-define (world-message (struct* dns-message + ([id query-id] + [recursion-desired recursion-desired] + [questions questions])) + request-source + request-target) + r) - (service-loop)) + (let loop ((remaining-questions questions) + (outbound-messages '()) + (w old-world) + (temporary-cache (world-roots old-world))) + (if (null? remaining-questions) + (values outbound-messages w) + (let ((q (car remaining-questions))) + (define-values (answer new-w new-cache) (answer-question q w temporary-cache)) + (loop (cdr remaining-questions) + (if answer + (cons answer outbound-messages) + outbound-messages) + new-w + new-cache))))) -(start-server 5555 - (rr '(#"example") 'soa 'in 30 - (soa '(#"ns" #"example") - '(#"tonyg" #"example") - 1 - 24 - 24 - 30 - 10)) - (list (rr '(#"localhost" #"example") 'a 'in 30 '#(127 0 0 1)) - (rr '(#"example") 'mx 'in 30 (mx 5 '(#"localhost" #"example"))) - (rr '(#"example") 'mx 'in 30 (mx 10 '(#"subns" #"example"))) - (rr '(#"google" #"example") 'cname 'in 30 '(#"www" #"google" #"com")) - (rr '(#"roar" #"example") 'a 'in 30 '#(192 168 1 1)) - (rr '(#"ns" #"example") 'a 'in 30 '#(127 0 0 1)) - (rr '(#"hello" #"example") 'txt 'in 30 '(#"Hello CRASH")) - (rr '(#"subzone" #"example") 'ns 'in 30 '(#"subns" #"example")) - (rr '(#"subns" #"example") 'a 'in 30 '#(127 0 0 2)))) +;; TODO: OMG this is a total toy proxy implementation. Pays attention +;; to NONE of the sensible guidelines or even the rules for +;; implementing DNS. It's pushing it and in slightly bad taste to even +;; call this DNS. +(define (answer-question q w cache) + (match-define (struct* question ([name name])) q) + + + (values ( (world-message (dns-message query-id + 'response + 'query + 'non-authoritative + 'not-truncated + recursion-desired + 'recursion-available + 'no-error + questions + (list) + (list) + (list)) + #f + request-source)) + old-world)) + +(define (handle-reply r old-world) + (error 'handle-reply "Unimplemented")) + +(start-proxy 5555 + (list (rr '() 'ns 'in 30 '(#"google-public-dns-a" #"google" #"com")) + (rr '(#"google-public-dns-a" #"google" #"com") 'a 'in 30 '#(8 8 8 8)))) diff --git a/simplified-driver.rkt b/simplified-driver.rkt index d754c0b..7ad30ea 100644 --- a/simplified-driver.rkt +++ b/simplified-driver.rkt @@ -26,36 +26,6 @@ ;; determines subzones based on the RRs it is configured with at ;; startup. -(define (authoritativeness-for dn soa-rr) - (if (in-bailiwick? dn (rr-name soa-rr)) - 'authoritative - 'non-authoritative)) - -;; ASSUMPTION: r1 and r2 are both DNS replies to the same query. -;; ASSUMPTION: no response-codes other than no-error or name-error are in use. -(define (merge-replies r1 r2) - (dns-message (dns-message-id r1) - 'response - 'query - (if (and (eqv? (dns-message-authoritative r1) 'authoritative) - (eqv? (dns-message-authoritative r2) 'authoritative)) - 'authoritative - 'non-authoritative) - 'not-truncated - (dns-message-recursion-desired r1) - 'no-recursion-available - (if (and (eqv? (dns-message-response-code r1) 'name-error) - (eqv? (dns-message-response-code r2) 'name-error)) - 'name-error - 'no-error) - (dns-message-questions r1) - (listset-union (dns-message-answers r1) (dns-message-answers r2)) - (listset-union (dns-message-authorities r1) (dns-message-authorities r2)) - (listset-union (dns-message-additional r1) (dns-message-additional r2)))) - -(define (listset-union xs1 xs2) - (set->list (set-union (list->set xs1) (list->set xs2)))) - (struct bad-dns-packet (detail host port reason) #:prefab) (struct dns-request (message host port) #:prefab) (struct dns-reply (message host port) #:prefab) @@ -116,7 +86,7 @@ (dns-message (dns-message-id request-message) 'response 'query - (authoritativeness-for name soa-rr) + (if (in-bailiwick? name (rr-name soa-rr)) 'authoritative 'non-authoritative) 'not-truncated (dns-message-recursion-desired request-message) 'no-recursion-available @@ -127,59 +97,39 @@ (set->list additional))) (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 - #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)))))) + ;; 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. + (define (build-referral q ns-rrset) + (question-result q + zone + ns-rrset + (set soa-rr) + (additional-section/a zone (set-map ns-rrset rr-rdata)))) + (match (resolve q soa-rr zone build-referral) + [#f + (make-reply (question-name q) + (in-bailiwick? (question-name q) (rr-name soa-rr)) + (set) + (set) + (set))] + [(question-result _ _ answers authorities additional) + (make-reply (question-name q) + #f + answers + authorities + additional)])) ;; TODO: check opcode and direction in request ;; TODO: think again about multiple questions in one packet diff --git a/zonedb.rkt b/zonedb.rkt index 8c2f4d2..4e5c52e 100644 --- a/zonedb.rkt +++ b/zonedb.rkt @@ -3,6 +3,7 @@ ;; Noddy representation of a zone, and various zone and RRSet utilities. (require racket/set) +(require racket/match) (require "api.rkt") (require "codec.rkt") @@ -12,7 +13,9 @@ filter-by-type referral-for additional-section/a - filter-rrs) + filter-rrs + + resolve) ;; A CompiledZone is a Hash>, representing a ;; collection of DNS RRSets indexed by DomainName. @@ -52,6 +55,7 @@ (define (filter-by-type rrset type) (set-filter (lambda (rr) (eqv? (rr-type rr) type)) rrset)) +;; TODO: Make limit maybe #f?? Representing no limit, for DNS roots?? (define (referral-for name soa-rr zone) (define limit (rr-name soa-rr)) (let search ((name name)) @@ -100,3 +104,60 @@ ((*) filtered-by-type) (else (set-filter (lambda (rr) (eqv? (rr-class rr) qclass)) filtered-by-type)))) filtered-by-type-and-class) + +;; QuestionResult Maybe -> QuestionResult +;; Add the supporting facts from r2 into r1, keeping r1's +;; question. Replaces the knowledge from r1 with the knowledge from +;; r2. Suitable for use when r2 is answering some sub-question of +;; r1's question. +(define (merge-replies r1 r2) + (match r2 + [#f r1] + [(question-result _ k2 n2 u2 d2) ;; a normal result + (match-define (question-result q1 k1 n1 u1 d1) r1) + (question-result q1 + k2 + (set-union n1 n2) + (set-union u1 u2) + (set-union d1 d2))])) + +(define (resolve q soa-rr knowledge recursive-resolver) + ;; Extract the pieces of the question: + (match-define (question name qtype qclass) q) + ;; Examine knowledgebase: + (cond + [(hash-ref knowledge name #f) => + ;; The full name matches in our collection of trusted facts. + (lambda (rrset) + (define filtered-rrs (filter-rrs rrset qtype qclass)) + (define cnames (filter-by-type rrset 'cname)) + (define base-reply (question-result q + knowledge + (set-union cnames filtered-rrs) + (if (in-bailiwick? name (rr-name soa-rr)) + (set soa-rr) + (set)) + (set))) + ;; Algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a. + (if (and (not (set-empty? cnames)) + (not (eqv? qtype 'cname))) + (foldl (lambda (cname-rr current-reply) + (merge-replies current-reply + (resolve (question (rr-rdata cname-rr) qtype qclass) + soa-rr + (question-result-knowledge current-reply) + recursive-resolver))) + base-reply + (set->list cnames)) + base-reply))] + [(referral-for name soa-rr knowledge) => + ;; No full name match, but a referral to somewhere beneath our SOA + ;; but within the knowledge we have. + (lambda (ns-rrset) + (recursive-resolver q ns-rrset))] + [else + ;; Neither a full name match nor a referral is available. Answer + ;; that we have no relevant information in the zone. It's up to + ;; the caller to decide whether this means NXDOMAIN or simply an + ;; empty reply. + #f]))