Referrals.

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