Cope with excessive gluelessness.

api.rkt

@@ -8,6 +8,8 @@
 
 	 (struct-out question)
 	 question-cyclic?
+	 question-restarted?
+	 restart-question
 
 	 (struct-out answered-question)
 	 (struct-out rr)
@@ -60,11 +62,15 @@
 ;; is represented as (vector #x20 #x01 #x0d #xb8 #x85 #xa3 #x00 #x00
 ;; #x00 #x00 #x8a #x2e #x03 #x70 #x73 #x34).
 
-;; A Question is a (question DomainName QueryType QueryClass Maybe<Question>),
-;; representing a DNS question: "What are the RRs for the given name,
-;; type and class?" as well as a possible parent question that the
-;; answer to this question is to contribute to the answer to. The
-;; context is needed to break cycles in the DNS database.
+;; A Question is a (question DomainName QueryType QueryClass (or
+;; Question #f 'restart)), representing a DNS question: "What are the
+;; RRs for the given name, type and class?" as well as a possible
+;; parent question that the answer to this question is to contribute
+;; to the answer to. The context is needed to break cycles in the DNS
+;; database. If the context is 'restart, then the question results
+;; from an excessively-glueless subquestion, and should *not* in turn
+;; be considered for gluelessness-restarting: this is needed to avoid
+;; a different kind of infinite loop.
 (struct question (name type class context) #:transparent)
 
 ;; An AnsweredQuestion is an (answered-question Question
@@ -229,6 +235,23 @@
   (match-define (question name type class parent) q)
   (let search ((ancestor parent))
     (match ancestor
-      [#f #f] ;; no further parents -> definitely not cyclic
       [(question (== name) (== type) (== class) _) #t] ;; uh-oh! A cycle!
-      [(question _ _ _ ancestor-parent) (search ancestor-parent)]))) ;; recursive case
+      [(question _ _ _ ancestor-parent) (search ancestor-parent)] ;; recursive case
+      [_ #f]))) ;; no further parents -> definitely not cyclic
+
+;; Question -> Boolean
+;; #t iff this question is being asked in the context of some
+;; excessively glueless subquestion.
+(define (question-restarted? q)
+  (match-define (question name type class parent) q)
+  (let search ((ancestor parent))
+    (match ancestor
+      [(question _ _ _ ancestor-parent) (search ancestor-parent)]
+      ['restart #t]
+      [_ #f])))
+
+;; Question -> Question
+;; Returns a question equivalent to q, but in a 'restart context, for
+;; retracing from the roots in cases of excessive gluelessness.
+(define (restart-question q)
+  (struct-copy question q [context 'restart]))

proxy.rkt

@@ -23,9 +23,9 @@
 ;; For discarding retransmitted requests that we're still working on.
 (struct active-request (source id) #:transparent)
 
-;; start-proxy : UInt16 CompiledZone -> Void
+;; start-proxy : UInt16 CompiledZone CompiledZone -> Void
 (require racket/pretty)
-(define (start-proxy port-number zone)
+(define (start-proxy port-number zone roots-only)
 
   (define boot-server
     (os-big-bang 'no-state/boot-server
@@ -54,7 +54,7 @@
 	   (spawn (dns-read-driver c))
 	   (spawn (dns-write-driver c))
 	   (spawn (packet-dispatcher s))
-	   (spawn (question-dispatcher zone c)))])))
+	   (spawn (question-dispatcher zone roots-only c)))])))
 
   (ground-vm (os-big-bang (void)
 	       ;;(spawn udp-spy)
@@ -144,15 +144,45 @@
 	      (unsubscribe wait-id)
 	      (send-message (answer->reply original-question answer)))])))]))
 
-(define (question-dispatcher zone0 client-sock)
+(define (question-too-glueless? q)
+  ;; If we're looking up a nameserver's address,
+  ;; in order to look up a nameserver's address,
+  ;; in order to answer some question,
+  ;; that came from the outside world, then that's too glueless.
+  ;; See http://cr.yp.to/djbdns/notes.html in the sections
+  ;; "Gluelessness" and "Expiring glue".
+  (match q
+    [(question _ _ _ (question _ _ _ (question _ _ _ _)))
+     ;; We're (at least) at the right nesting level: now see if this
+     ;; question was already the result of a restart. If so, we grimly
+     ;; press on with it unchanged.
+     (not (question-restarted? q))]
+    [_ #f]))
+
+(define (glueless-question-handler roots-only-zone q client-sock)
+  ;; Restart q, an overly-glueless question, from the roots.
+  (define restarted-question (restart-question q))
+  (os-big-bang 'no-state
+    (subscribe/fresh relay
+      (message-handlers w
+	[(answered-question (== restarted-question) ans)
+	 ;; We got the answer to our restarted question; now transform
+	 ;; it into an answer to the original question, to unblock the
+	 ;; original questioner.
+	 (transition w
+	   (unsubscribe relay)
+	   (send-message (answered-question q ans)))]))
+    (spawn (question-handler roots-only-zone restarted-question client-sock))))
+
+(define (question-dispatcher seed-zone roots-only client-sock)
   (define (transition-and-set-timers new-zone timers)
     (transition new-zone
       (for/list ([timerspec timers])
 	(match-define (cons name ttl) timerspec)
 	(send-message (set-timer (list 'check-dns-expiry name) (* ttl 1000) 'relative)))))
+  (define-values (cleaned-seed-zone initial-timers) (zone-expire seed-zone))
   (os-big-bang/transition
-   (extend-transition (let-values (((expired-zone timers) (zone-expire zone0)))
-			(transition-and-set-timers expired-zone timers))
+   (extend-transition (transition-and-set-timers cleaned-seed-zone initial-timers)
      ;; TODO: consider deduping questions here too?
      (subscribe 'question-handler-factory
        (message-handlers zone
@@ -176,11 +206,15 @@
 	  zone]
 	 [(? question? q)
 	  (transition zone
-	    (if (question-cyclic? q)
-		(begin (begin (write `(Cyclic question ,q))
-			      (newline))
-		       (send-message (answered-question q (empty-complete-answer))))
-		(spawn (question-handler zone q client-sock))))]
+	    (cond
+	     [(question-cyclic? q)
+	      (begin (write `(Cyclic question ,q)) (newline))
+	      (send-message (answered-question q (empty-complete-answer)))]
+	     [(question-too-glueless? q)
+	      (begin (write `(Overly-glueless question ,q)) (newline))
+	      (spawn (glueless-question-handler roots-only q client-sock))]
+	     [else
+	      (spawn (question-handler zone q client-sock))]))]
 	 [(network-reply _ answer)
 	  (define-values (new-zone timers) (incorporate-complete-answer answer zone))
 	  (transition-and-set-timers new-zone timers)]
@@ -273,4 +307,5 @@
 (start-proxy (test-port-number)
 	     (if (file-exists? "zone-proxy.zone")
 		 (bit-string->zone (file->bytes "zone-proxy.zone"))
-		 (compile-zone-db test-roots)))
+		 (compile-zone-db test-roots))
+	     (compile-zone-db test-roots))