Steps toward a working proxy. Next: another stab at the resolution algorithm

proxy.rkt

@@ -90,6 +90,42 @@
 ;; ServerState
 (struct world (roots continuations) #:prefab)
 
+(define action-prompt (make-continuation-prompt-tag 'world-action))
+
+;; TODO: Avoid attack amplification by not starting work on questions
+;; that are already underway
+
+;; TODO: Timeouts!!
+
+(define (send/suspend outbound-messages awaken-key)
+  (call-with-composable-continuation
+   (lambda (k)
+     (abort-current-continuation action-prompt
+       (lambda () (values (lambda (w k)
+			    (values outbound-messages
+				    (struct-copy world w
+						 [continuations (hash-set (world-continuations w)
+									  awaken-key
+									  k)])))
+			  k))))
+   action-prompt))
+
+;; ( -> X) ServerState -> X ServerState
+;; In this specific instance, X is likely to be ListOf<WorldMessage>.
+(define (run-inferior boot world)
+  (call-with-continuation-barrier ;; TODO: ???
+   (lambda ()
+     (define-values (computation-step-result computation-step-continuation)
+       (call-with-continuation-prompt (lambda () (values (boot) #f)) action-prompt))
+     (cond
+      ((eq? computation-step-continuation #f)
+       ;; The computation is finished, and has yielded a result.
+       (values computation-step-result world))
+      (else
+       ;; The computation is not finished, but is waiting for an
+       ;; action to complete.
+       (computation-step-result world computation-step-continuation))))))
+
 ;; start-proxy : UInt16 ListOf<RR> -> Void
 ;; Starts a proxy service that will answer questions received on the
 ;; given UDP port based on the NS RRs it is given.
@@ -163,45 +199,71 @@
 			       request-source
 			       request-target)
 		r)
+  (if (null? questions)
+      (values '() old-world)
+      ;; TODO: ignoring all but the car - good? bad? hmm?
+      (answer-question (car questions) old-world (world-roots old-world)
+		       query-id recursion-desired request-source)))
 
-  (let loop ((remaining-questions questions)
-	     (outbound-messages '())
-	     (w old-world)
-	     (temporary-cache (world-roots old-world)))
-    (if (null? remaining-questions)
-	(values outbound-messages w)
-	(let ((q (car remaining-questions)))
-	  (define-values (answer new-w new-cache) (answer-question q w temporary-cache))
-	  (loop (cdr remaining-questions)
-		(if answer
-		    (cons answer outbound-messages)
-		    outbound-messages)
-		new-w
-		new-cache)))))
+;; resolve-iteratively : Question SetOf<RR> -> QuestionResult
+;; Follows a chain of referrals until it finds an answer to its
+;; question.
+(define (resolve-iteratively q ns-rrset)
+  (let search ((seen (set))
+	       (remaining (set->list ns-rrset)))
+    (cond
+     [(null? remaining) #f] ;; no answer available
+     [(set-member? (car remaining) seen) (search seen (cdr remaining))]
+     [else
+      (define first-ns-rr (car remaining))
+      (define ns-name (rr-name first-ns-rr))
+      (define ns-addr 
+	.......
+	Should the main algorithm iterate to solution/fixpoint instead of recursing?
+	If so, how should it treat cnames?
+  (pretty-print 'resolve-iteratively)
+  (define sub-query-id (random 65536)
+  (define sub-query (dns-message sub-query-id
+				 'request
+				 'query
+				 'non-authoritative
+				 'not-truncated
+				 #f
+				 'no-recursion-available
+				 'no-error
+				 (list q)
+				 (list)
+				 (list)
+				 (list)))
+  (pretty-print `(back with ,(send/suspend 
+			      
+  (error 'resolve-iteratively "Gah!"))
 
-;; TODO: OMG this is a total toy proxy implementation. Pays attention
-;; to NONE of the sensible guidelines or even the rules for
-;; implementing DNS. It's pushing it and in slightly bad taste to even
-;; call this DNS.
-(define (answer-question q w cache)
-  (match-define (struct* question ([name name])) q)
-  
-
-  (values ( (world-message (dns-message query-id
-					    'response
-					    'query
-					    'non-authoritative
-					    'not-truncated
-					    recursion-desired
-					    'recursion-available
-					    'no-error
-					    questions
-					    (list)
-					    (list)
-					    (list))
-			       #f
-			       request-source))
-	  old-world))
+;; TODO: Make sure we follow the guidelines and rules for implementing
+;; DNS proxies more strictly.
+(define (answer-question q w cache query-id recursion-desired request-source)
+  (define (make-answer ns us ds)
+    (list (world-message (dns-message query-id
+				      'response
+				      'query
+				      'non-authoritative
+				      'not-truncated
+				      recursion-desired
+				      'recursion-available
+				      'no-error
+				      (list q)
+				      ns
+				      us
+				      ds)
+			 #f
+			 request-source)))
+  (run-inferior (lambda ()
+		  (match (resolve-from-zone q #f cache resolve-iteratively)
+		    [#f
+		     (make-answer '() '() '())]
+		    [(question-result _ new-cache answers authorities additional)
+		     (make-answer answers authorities additional)]))
+		w))
 
 (define (handle-reply r old-world)
   (error 'handle-reply "Unimplemented"))

simplified-driver.rkt

@@ -79,6 +79,11 @@
   (match-define (dns-reply message host port) r)
   (udp-packet (dns-message->packet message) host port))
 
+(define (first-only xs)
+  (if (null? xs)
+      xs
+      (cons (car xs) '())))
+
 (define (handle-request soa-rr zone request)
   (match-define (dns-request request-message request-host request-port) request)
 
@@ -111,13 +116,9 @@
     ;;
     ;; TODO: We support returning out-of-bailiwick records (glue)
     ;; here. Reexamine the rules for doing so.
-    (define (build-referral q ns-rrset)
-      (question-result q
-		       zone
-		       ns-rrset
-		       (set soa-rr)
-		       (additional-section/a zone (set-map ns-rrset rr-rdata))))
-    (match (resolve q soa-rr zone build-referral)
+    (match (resolve-from-zone q soa-rr zone
+			      (lambda (q ns-rrset)
+				(build-referral q soa-rr zone ns-rrset)))
       [#f
        (make-reply (question-name q)
 		   (in-bailiwick? (question-name q) (rr-name soa-rr))
@@ -135,7 +136,7 @@
   ;; TODO: think again about multiple questions in one packet
   (map (lambda (q)
 	 (dns-reply (answer-question q make-reply) request-host request-port))
-       (dns-message-questions request-message)))
+       (first-only (dns-message-questions request-message))))
 
 (require "test-rrs.rkt")
 (start-server 5555 test-soa-rr test-rrs)

zonedb.rkt

@@ -16,7 +16,8 @@
 	 filter-rrs
 	 rr-set->list
 
-	 resolve)
+	 resolve-from-zone
+	 build-referral)
 
 ;; A CompiledZone is a Hash<DomainName,SetOf<RR>>, representing a
 ;; collection of DNS RRSets indexed by DomainName.
@@ -57,11 +58,10 @@
   (set-filter (lambda (rr) (eqv? (rr-type rr) type)) rrset))
 
 ;; TODO: Make limit maybe #f?? Representing no limit, for DNS roots??
-(define (referral-for name soa-rr zone)
-  (define limit (rr-name soa-rr))
+(define (referral-for name limit zone)
   (let search ((name name))
     (cond
-     ((or (null? name) (equal? name limit))
+     ((equal? name limit)
       ;; We've walked up the tree to the top of the zone. No referrals
       ;; are possible.
       #f)
@@ -74,8 +74,12 @@
 	    (search (cdr name)) ;; no NS records for this suffix. Keep looking.
 	    ns-rrset)))
      (else
-      ;; Nothing for this suffix. Keep lookup.
-      (search (cdr name))))))
+      ;; Nothing for this suffix.
+      (if (null? name)
+	  ;; No further possibilities, and we've already checked the root.
+	  #f
+	  ;; Remove a label and keep looking.
+	  (search (cdr name)))))))
 
 ;; additional-section/a : CompiledZone ListOf<DomainName>
 ;; Implements the "additional section" rules from RFC 1035 (and the
@@ -129,7 +133,7 @@
 		      (set-union u1 u2)
 		      (set-union d1 d2))]))
 
-(define (resolve q soa-rr knowledge recursive-resolver)
+(define (resolve-from-zone q soa-rr knowledge recursive-resolver)
   ;; Extract the pieces of the question:
   (match-define (question name qtype qclass) q)
   ;; Examine knowledgebase:
@@ -142,7 +146,7 @@
       (define base-reply (question-result q
 					  knowledge
 					  (set-union cnames filtered-rrs)
-					  (if (in-bailiwick? name (rr-name soa-rr))
+					  (if (and soa-rr (in-bailiwick? name (rr-name soa-rr)))
 					      (set soa-rr)
 					      (set))
 					  (set)))
@@ -151,14 +155,15 @@
 	       (not (eqv? qtype 'cname)))
 	  (foldl (lambda (cname-rr current-reply)
 		   (merge-replies current-reply
-				  (resolve (question (rr-rdata cname-rr) qtype qclass)
-					   soa-rr
-					   (question-result-knowledge current-reply)
-					   recursive-resolver)))
+				  (resolve-from-zone
+				   (question (rr-rdata cname-rr) qtype qclass)
+				   soa-rr
+				   (question-result-knowledge current-reply)
+				   recursive-resolver)))
 		 base-reply
 		 (set->list cnames))
 	  base-reply))]
-   [(referral-for name soa-rr knowledge) =>
+   [(referral-for name (and soa-rr (rr-name soa-rr)) knowledge) =>
     ;; No full name match, but a referral to somewhere beneath our SOA
     ;; but within the knowledge we have.
     (lambda (ns-rrset)
@@ -169,3 +174,13 @@
     ;; the caller to decide whether this means NXDOMAIN or simply an
     ;; empty reply.
     #f]))
+
+;; build-referral : Question RR CompiledZone SetOf<RR> -> QuestionResult
+;; Used when servers choose iterative referral over recursive
+;; resolution. The RRs in ns-rrset must be NS RRs.
+(define (build-referral q soa-rr zone ns-rrset)
+  (question-result q
+		   zone
+		   ns-rrset
+		   (and soa-rr (set soa-rr))
+		   (additional-section/a zone (set-map ns-rrset rr-rdata))))