diff --git a/driver.rkt b/driver.rkt index 93532e6..df19347 100644 --- a/driver.rkt +++ b/driver.rkt @@ -37,6 +37,64 @@ ((null? dn) #f) (else (in-bailiwick? (cdr dn) root)))) +(define (authoritativeness-for dn soa-rr) + (if (in-bailiwick? dn (rr-name soa-rr)) + 'authoritative + 'non-authoritative)) + +(define (referral-for name soa-rr zone) + (define limit (rr-name soa-rr)) + (let search ((name name)) + (cond + ((equal? name limit) + ;; We've walked up the tree to the top of the zone. No referrals + ;; are possible. + #f) + ((hash-ref zone name #f) => + ;; 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)) + (if (set-empty? ns-rrset) + (search (cdr name)) ;; no NS records for this suffix. Keep looking. + ns-rrset))) + (else + ;; Nothing for this suffix. Keep lookup. + (search (cdr name)))))) + +(define (additional-section/a zone names) + ;; RFC 3596 (section 3) requires that we process AAAA here as well + ;; as A. + (foldl (lambda (name section) + (set-union section + (set-filter (lambda (rr) (and (memv (rr-type rr) '(a aaaa)) + (eqv? (rr-class rr) 'in))) + (hash-ref zone name)))) + (set) + names)) + +;; set-filter : (X -> Boolean) SetOf -> SetOf +;; Retains only those elements of its argument for which the predicate +;; answers #t. +(define (set-filter predicate in) + (for/set ([x (in-set in)] + #:when (predicate x)) + x)) + +;; filter-rrs : SetOf QueryType QueryClass +;; Returns a set like its argument with RRs not matching the given +;; type and class removed. +(define (filter-rrs rrs qtype qclass) + (define filtered-by-type + (case qtype + ((*) rrs) + (else (set-filter (lambda (rr) (eqv? (rr-type rr) qtype)) rrs)))) + (define filtered-by-type-and-class + (case qclass + ((*) filtered-by-type) + (else (set-filter (lambda (rr) (eqv? (rr-class rr) qclass)) filtered-by-type)))) + filtered-by-type-and-class) + ;; start-server : UInt16 RR ListOf -> Void ;; Starts a server that will answer questions received on the given ;; UDP port based on the RRs it is given and the zone origin specified @@ -91,22 +149,44 @@ ;; 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: referral for subzones - (define (answer-question q) (define name (question-name q)) - (let ((rrset (hash-ref zone name #f))) - (if (false? rrset) - (reply! 'authoritative - 'name-error - (set) - (set) - (set)) - (reply! (if (in-bailiwick? name (rr-name soa-rr)) 'authoritative 'non-authoritative) - 'no-error - rrset - (set soa-rr) - (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. + (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))))) ;;(display "----------------------------------------") ;;(newline)