From 0d015c6e9c75f9027876f308a9fb3686ff8de267 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 19 Sep 2011 14:36:32 -0400 Subject: [PATCH] Steps toward proper handling of CNAMEs --- driver.rkt | 171 ++++++++++++++++++++++++++++++++++------------------- 1 file changed, 109 insertions(+), 62 deletions(-) diff --git a/driver.rkt b/driver.rkt index df19347..4748d70 100644 --- a/driver.rkt +++ b/driver.rkt @@ -42,11 +42,14 @@ 'authoritative 'non-authoritative)) +(define (filter-by-type rrset type) + (set-filter (lambda (rr) (eqv? (rr-type rr) type)) rrset)) + (define (referral-for name soa-rr zone) (define limit (rr-name soa-rr)) (let search ((name name)) (cond - ((equal? name limit) + ((or (null? name) (equal? name limit)) ;; We've walked up the tree to the top of the zone. No referrals ;; are possible. #f) @@ -54,7 +57,7 @@ ;; There's an entry for this suffix of the original name. Check ;; to see if it has an NS record indicating a subzone. (lambda (rrset) - (define ns-rrset (set-filter (lambda (rr) (eqv? (rr-type rr) 'ns)) rrset)) + (define ns-rrset (filter-by-type rrset 'ns)) (if (set-empty? ns-rrset) (search (cdr name)) ;; no NS records for this suffix. Keep looking. ns-rrset))) @@ -73,6 +76,31 @@ (set) names)) +;; 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-authoritative r1) 'name-error) + (eqv? (dns-message-authoritative 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)))) + ;; set-filter : (X -> Boolean) SetOf -> SetOf ;; Retains only those elements of its argument for which the predicate ;; answers #t. @@ -88,7 +116,7 @@ (define filtered-by-type (case qtype ((*) rrs) - (else (set-filter (lambda (rr) (eqv? (rr-type rr) qtype)) rrs)))) + (else (filter-by-type rrs qtype)))) (define filtered-by-type-and-class (case qclass ((*) filtered-by-type) @@ -121,77 +149,96 @@ ;; TODO: check opcode in request - (define (reply! authoritativeness response-code answers authorities additional) - (define reply-message (dns-message (dns-message-id request-message) - 'response - 'query - authoritativeness - 'not-truncated - (dns-message-recursion-desired request-message) - 'no-recursion-available - response-code - (dns-message-questions request-message) - (set->list answers) - (set->list authorities) - (set->list additional))) - ;;(write reply-message) (newline) - (udp-send-to s source-hostname source-port (dns-message->packet reply-message))) + (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) + 'no-recursion-available + (if send-name-error? 'name-error 'no-error) + (dns-message-questions request-message) + (set->list answers) + (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... - ;; TODO: what if a question is out-of-bailiwick? No answer, - ;; non-authoritative NXDOMAIN (doesn't seem right), or 'refused - ;; response-code? + ;; TODO: Truncation -;; 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. + ;; 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) - (define 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) - (reply! (authoritativeness-for name soa-rr) - 'no-error - (filter-rrs rrset (question-type q) (question-class q)) - (set soa-rr) - (set)))) - ((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) - (reply! (authoritativeness-for name soa-rr) - 'no-error - 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). - (reply! 'authoritative 'name-error (set) (set) (set))))) + (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)))))) ;;(display "----------------------------------------") ;;(newline) ;;(write request-message) (newline) - (for-each answer-question (dns-message-questions request-message)) + + ;; 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)))