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
'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<X> -> SetOf<X>
;; 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)))