syndicate-lang
/
racket-dns-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Steps toward proper handling of CNAMEs

This commit is contained in:
Tony Garnock-Jones 2011-09-19 14:36:32 -04:00
parent 127601c357
commit 0d015c6e9c
1 changed files with 109 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

171
driver.rkt
View File

@ -42,11 +42,14 @@
'authoritative 'authoritative
'non-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 (referral-for name soa-rr zone)
(define limit (rr-name soa-rr)) (define limit (rr-name soa-rr))
(let search ((name name)) (let search ((name name))
(cond (cond
((equal? name limit) ((or (null? name) (equal? name limit))
;; We've walked up the tree to the top of the zone. No referrals ;; We've walked up the tree to the top of the zone. No referrals
;; are possible. ;; are possible.
#f) #f)
@ -54,7 +57,7 @@
;; There's an entry for this suffix of the original name. Check ;; There's an entry for this suffix of the original name. Check
;; to see if it has an NS record indicating a subzone. ;; to see if it has an NS record indicating a subzone.
(lambda (rrset) (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) (if (set-empty? ns-rrset)
(search (cdr name)) ;; no NS records for this suffix. Keep looking. (search (cdr name)) ;; no NS records for this suffix. Keep looking.
ns-rrset))) ns-rrset)))
@ -73,6 +76,31 @@
(set) (set)
names)) 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<X> -> SetOf<X> ;; set-filter : (X -> Boolean) SetOf<X> -> SetOf<X>
;; Retains only those elements of its argument for which the predicate ;; Retains only those elements of its argument for which the predicate
;; answers #t. ;; answers #t.
@ -88,7 +116,7 @@
(define filtered-by-type (define filtered-by-type
(case qtype (case qtype
((*) rrs) ((*) rrs)
(else (set-filter (lambda (rr) (eqv? (rr-type rr) qtype)) rrs)))) (else (filter-by-type rrs qtype))))
(define filtered-by-type-and-class (define filtered-by-type-and-class
(case qclass (case qclass
((*) filtered-by-type) ((*) filtered-by-type)
@ -121,77 +149,96 @@
;; TODO: check opcode in request ;; TODO: check opcode in request
(define (reply! authoritativeness response-code answers authorities additional) (define (make-reply name send-name-error? answers authorities additional)
(define reply-message (dns-message (dns-message-id request-message) (dns-message (dns-message-id request-message)
'response 'response
'query 'query
authoritativeness (authoritativeness-for name soa-rr)
'not-truncated 'not-truncated
(dns-message-recursion-desired request-message) (dns-message-recursion-desired request-message)
'no-recursion-available 'no-recursion-available
response-code (if send-name-error? 'name-error 'no-error)
(dns-message-questions request-message) (dns-message-questions request-message)
(set->list answers) (set->list answers)
(set->list authorities) (set->list authorities)
(set->list additional))) (set->list additional)))
;;(write reply-message) (newline)
(udp-send-to s source-hostname source-port (dns-message->packet reply-message)))
;; TODO: what if there are multiple questions in one request ;; TODO: what if there are multiple questions in one request
;; packet? Single reply, or multiple replies? djbdns looks like ;; packet? Single reply, or multiple replies? djbdns looks like
;; it handles exactly one question per request... ;; it handles exactly one question per request...
;; TODO: what if a question is out-of-bailiwick? No answer, ;; TODO: Truncation
;; non-authoritative NXDOMAIN (doesn't seem right), or 'refused
;; response-code?
;; TODO: maybe store domain names big-end first? ;; TODO: maybe store domain names big-end first? It'd make
;; It'd make bailiwick and subzone checks into prefix rather than suffix checks. ;; bailiwick and subzone checks into prefix rather than suffix
;; It makes domain names into paths through the DNS DB tree. ;; checks. It makes domain names into paths through the DNS DB
;; tree.
(define (answer-question q) (define (answer-question q)
(define name (question-name q)) (let resolve ((name (question-name q)))
;; Notice that we claim to be authoritative for our configured ;; Notice that we claim to be authoritative for our configured
;; zone. If we ever answer name-error, that means there are no ;; 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 ;; 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, ;; queried name, but they happen not to be the ones asked for,
;; name-error must *not* be returned: instead, a normal no-error ;; name-error must *not* be returned: instead, a normal
;; reply is sent with an empty answer section. ;; no-error reply is sent with an empty answer section.
;; ;;
;; If we wanted to support caching of negative replies, we'd ;; If we wanted to support caching of negative replies, we'd
;; follow the guidelines in section 4.3.4 "Negative response ;; follow the guidelines in section 4.3.4 "Negative response
;; caching" of RFC1034, adding our zone SOA with an appropriate ;; caching" of RFC1034, adding our zone SOA with an
;; TTL to the additional section of the reply. ;; appropriate TTL to the additional section of the reply.
;; ;;
;; TODO: We support returning out-of-bailiwick records (glue) ;; TODO: We support returning out-of-bailiwick records (glue)
;; here. Reexamine the rules for doing so. ;; here. Reexamine the rules for doing so.
(cond (cond
((hash-ref zone name #f) => ((hash-ref zone name #f) =>
;; The full name matches in our zone database. ;; The full name matches in our zone database.
(lambda (rrset) (lambda (rrset)
(reply! (authoritativeness-for name soa-rr) (define filtered-rrs (filter-rrs rrset (question-type q) (question-class q)))
'no-error (define cnames (filter-by-type rrset 'cname))
(filter-rrs rrset (question-type q) (question-class q)) (define base-reply (make-reply name
(set soa-rr) #f
(set)))) (set-union cnames filtered-rrs)
((referral-for name soa-rr zone) => (set soa-rr)
;; No full name match, but a referral to somewhere beneath our (set)))
;; SOA but within our zone. ;; Algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a.
(lambda (ns-rrset) (if (and (not (set-empty? cnames))
(reply! (authoritativeness-for name soa-rr) (not (eqv? (question-type q) 'cname)))
'no-error (foldl (lambda (cname-rr current-reply)
ns-rrset (merge-replies current-reply
(set soa-rr) (resolve (rr-rdata cname-rr))))
(additional-section/a zone (set-map ns-rrset rr-rdata))))) base-reply
(else (set->list cnames))
;; Neither a full name match nor a referral is base-reply)))
;; available. Answer name-error (NXDOMAIN). ((referral-for name soa-rr zone) =>
(reply! 'authoritative 'name-error (set) (set) (set))))) ;; 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 "----------------------------------------") ;;(display "----------------------------------------")
;;(newline) ;;(newline)
;;(write request-message) (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))) (service-loop)))