CPS-convert resolve-from-zone to expose network I/O actions.

2012-01-24 14:19:25 -05:00 · 2012-01-24 14:19:25 -05:00 · e7f3e79053
parent f07495520e
commit e7f3e79053
9 changed files with 111 additions and 134 deletions
--- a/big-bang-driver.rkt
+++ b/big-bang-driver.rkt
@ -2,7 +2,6 @@

 ;; DNS server using os-big-bang.rkt and os-udp.rkt.

-(require racket/unit)
 (require racket/match)
 (require racket/set)
 (require racket/bool)
@ -10,22 +9,13 @@
 (require "api.rkt")
 (require "codec.rkt")
 (require "zonedb.rkt")
-(require "network-query-sig.rkt")
-(require "resolver-unit.rkt")
+(require "network-query.rkt")
+(require "resolver.rkt")
 (require "dump-bytes.rkt")
 (require "os.rkt")
 (require "os-big-bang.rkt")
 (require "os-udp.rkt")

-(define-unit network-query@
-  (import)
-  (export network-query^)
-  (define (network-query/addresses q db ns-rr addresses)
-    (error 'network-query/addresses "Forbidden to invoke resolver in server")))
-
-(define-values/invoke-unit/infer
-  (link resolver@ network-query@))
-
 ;; Instantiated with a SOA record for the zone it is serving as well
 ;; as a zone's worth of DNS data which is used to answer queries
 ;; authoritatively. Never caches information, never performs recursive
@ -151,7 +141,7 @@
    ;;
    ;; TODO: We support returning out-of-bailiwick records (glue)
    ;; here. Reexamine the rules for doing so.
-    (match (resolve-from-zone q zone soa-rr #f (set))
+    (match (resolve-from-zone q zone soa-rr #f (set) values)
      [#f
       (make-reply (question-name q)
 		   #t
--- a/ground-udp-operations-unit.rkt
+++ b/ground-udp-operations-unit.rkt
@ -1,14 +0,0 @@
-#lang racket/unit
-
-(require (prefix-in r: racket/udp))
-(require "udp-operations-sig.rkt")
-
-(import)
-(export udp-operations^)
-
-(define udp-open-socket r:udp-open-socket)
-(define udp-close r:udp-close)
-(define udp-bind! r:udp-bind!)
-(define udp-send-to r:udp-send-to)
-(define (udp-receive/timeout s buffer timeout-seconds)
-  (sync/timeout timeout-seconds (r:udp-receive!-evt s buffer)))
--- a/network-query-sig.rkt
+++ b/network-query-sig.rkt
@ -1,3 +0,0 @@
-#lang racket/signature
-
-network-query/addresses ;; Question CompiledZone NS-RR ListOf<IPv4> -> Maybe<CompiledZone>
--- a/network-query-unit.rkt
+++ b/network-query-unit.rkt
@ -1,20 +1,16 @@
-#lang racket/unit
-
-(require racket/pretty)
+#lang racket/base

 (require racket/match)
+(require racket/udp)
 (require "api.rkt")
 (require "codec.rkt")
 (require "zonedb.rkt")
-(require "udp-operations-sig.rkt")
-(require "network-query-sig.rkt")

-(import udp-operations^)
-(export network-query^)
+(provide network-query/addresses)

 ;; DJB's rules for handling DNS responses. Some of these are handled
 ;; here (specifically, rules 2 through 5, in the action of
-;; incorporate-dns-reply), some are handled in resolver-unit.rkt (rule
+;; incorporate-dns-reply), some are handled in resolver.rkt (rule
 ;; 1, in the action of answer-from-zone):

 ;; <blockquote>
@ -153,6 +149,11 @@
 	  ['no-answer (search (cdr remaining-ips))]
 	  [result result]))))

+(define (udp-receive/timeout s buffer timeout-seconds)
+  (sync/timeout timeout-seconds (udp-receive!-evt s buffer)))
+
+(require racket/pretty) ;; TODO: remove
+
 ;; network-query/address/timeout :
 ;;   UdpSocket Question CompiledZone RR<NS> IPv4 Seconds
 ;;   -> (or Maybe<CompiledZone> 'no-answer)
--- a/proxy.rkt
+++ b/proxy.rkt
@ -203,7 +203,7 @@
 			 #f
 			 request-source)))
  (run-inferior (lambda ()
-		  (match (resolve-from-zone q #f cache resolve-iteratively)
+		  (match (resolve-from-zone q #f cache resolve-iteratively values)
 		    [#f
 		     (make-answer '() '() '())]
 		    [(question-result _ new-cache answers authorities additional)
--- a/resolver-sig.rkt
+++ b/resolver-sig.rkt
@ -1,3 +0,0 @@
-#lang racket/signature
-
-resolve-from-zone ;; Question CompiledZone SOA-RR Boolean Set<NS-RR> -> QuestionResult
--- a/resolver-test.rkt
+++ b/resolver-test.rkt
@ -9,12 +9,8 @@
 (require "api.rkt")
 (require "codec.rkt")
 (require "zonedb.rkt")
-(require "ground-udp-operations-unit.rkt")
-(require "network-query-unit.rkt")
-(require "resolver-unit.rkt")
-
-(define-values/invoke-unit/infer
-  (link resolver@ network-query@ ground-udp-operations@))
+(require "network-query.rkt")
+(require "resolver.rkt")

 ;; (require racket/trace)
 ;; (trace ;;resolve-from-zone
@ -31,27 +27,37 @@
 ;;        ;;in-bailiwick?
 ;;        )

-(pretty-print
- (resolve-from-zone (question
-		     ;;'(#"www" #"google" #"com")
-		     ;;'(#"foo" #"rallyx" #"ccs" #"neu" #"edu")
-		     ;;'(#"rallyx" #"ccs" #"neu" #"edu")
-		     '(#"www" #"eighty-twenty" #"org")
-		     'a
-		     'in)
-		    (compile-zone-db
-		     ;; (list (rr '() 'ns 'in 30 '(#"google-public-dns-a" #"google" #"com"))
-		     ;; 	  (rr '(#"google-public-dns-a" #"google" #"com") 'a 'in 30 '#(8 8 8 8)))
-		     (list (rr '() 'ns 'in 30 '(#"f" #"root-servers" #"net"))
-			   (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(198 41 0 4))
-			   (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 228 79 201))
-			   (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 33 4 12))
-			   (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 203 230 10))
-			   (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 112 36 4))
-			   (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(128 63 2 53))
-			   (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 58 128 30))
-			   (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(193 0 14 129)))
-		     )
-		    #f
-		    #t
-		    (set)))
+(define (drive-resolver qr)
+  (match qr
+    [(resolver-network-query q zone ns-rr addresses k)
+     (write `(INTERMEDIATE ,q ,ns-rr (,(length addresses) addresses))) (newline)
+     (drive-resolver (k (network-query/addresses q zone ns-rr addresses)))]
+    [_ qr]))
+
+(define (run-question name qtype)
+  (drive-resolver
+   (resolve-from-zone (question name qtype 'in)
+		      (compile-zone-db
+		       ;; (list (rr '() 'ns 'in 30 '(#"google-public-dns-a" #"google" #"com"))
+		       ;; 	  (rr '(#"google-public-dns-a" #"google" #"com") 'a 'in 30 '#(8 8 8 8)))
+		       (list (rr '() 'ns 'in 30 '(#"f" #"root-servers" #"net"))
+			     (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(198 41 0 4))
+			     (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 228 79 201))
+			     (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 33 4 12))
+			     (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 203 230 10))
+			     (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 112 36 4))
+			     (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(128 63 2 53))
+			     (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 58 128 30))
+			     (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(193 0 14 129)))
+		       )
+		      #f
+		      #t
+		      (set)
+		      values)))
+
+;;(pretty-print (run-question '(#"www" #"google" #"com") 'a))
+;;(pretty-print (run-question '(#"vapour" #"eighty-twenty" #"org") 'a))
+;;(pretty-print (run-question '(#"eighty-twenty" #"org") 'a))
+(pretty-print (run-question '(#"www" #"eighty-twenty" #"org") 'a))
+;;(pretty-print (run-question '(#"foo" #"rallyx" #"ccs" #"neu" #"edu") 'a))
+;;(pretty-print (run-question '(#"rallyx" #"ccs" #"neu" #"edu") 'a))
--- a/resolver-unit.rkt
+++ b/resolver-unit.rkt
@ -1,4 +1,4 @@
-#lang racket/unit
+#lang racket/base

 (require racket/pretty)

@ -7,11 +7,11 @@
 (require "api.rkt")
 (require "codec.rkt")
 (require "zonedb.rkt")
-(require "network-query-sig.rkt")
-(require "resolver-sig.rkt")

-(import network-query^)
-(export resolver^)
+(provide (struct-out resolver-network-query)
+	 resolve-from-zone)
+
+(struct resolver-network-query (q zone ns-rr addresses k) #:transparent)

 ;; Rules:
 ;;
@ -56,7 +56,7 @@
 		      (set-union u1 u2)
 		      (set-union d1 d2))]))

-(define (answer-from-zone q zone start-of-authority recursion-desired? kf)
+(define (answer-from-zone q zone start-of-authority recursion-desired? ks kf)
  (match-define (question name qtype qclass) q)
  (define rrset (hash-ref zone name set))
  (define filtered-rrs (filter-rrs rrset qtype qclass))
@ -69,23 +69,25 @@
 					  (set start-of-authority)
 					  (set))
 				      (set)))
+  (define (k qr)
+    (if (set-empty? (question-result-answers qr))
+	(kf)
+	(ks qr)))
  ;; Algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a.
-  (define expanded-reply
-    (if (and (not (set-empty? cnames)) (not (eqv? qtype 'cname)))
-	(foldl (lambda (cname-rr current-reply)
-		 (merge-replies current-reply
-				(resolve-from-zone
-				 (question (rr-rdata cname-rr) qtype qclass)
-				 zone
-				 start-of-authority
-				 recursion-desired?
-				 (set))))
-	       base-reply
-	       (set->list cnames))
-	base-reply))
-  (if (set-empty? (question-result-answers expanded-reply))
-      (kf)
-      expanded-reply))
+  (if (and (not (set-empty? cnames)) (not (eqv? qtype 'cname)))
+      (let loop ((cnames (set->list cnames))
+		 (reply base-reply))
+	(if (null? cnames)
+	    (k reply)
+	    (let ((cname-rr (car cnames)))
+	      (resolve-from-zone
+	       (question (rr-rdata cname-rr) qtype qclass)
+	       zone
+	       start-of-authority
+	       recursion-desired?
+	       (set)
+	       (lambda (qr) (loop (cdr cnames) (merge-replies reply qr)))))))
+      (k base-reply)))

 (define (closest-nameservers name zone)
  (let search ((name name))
@ -139,24 +141,28 @@
 (define (random-element a-nonempty-list)
  (car a-nonempty-list))

-(define (network-query q zone ns-rr)
+(define (network-query q zone ns-rr k)
  (define ns-name (rr-rdata ns-rr))
  ;; ^ the rr-name is the subzone origin; the rr-rdata is the
  ;; nameserver for the subzone
-  (match (resolve-from-zone (question ns-name 'a 'in) ;; TODO: 'aaaa ?
-			    zone
-			    #f
-			    #t
-			    (set))
-    [#f zone] ;; Can't find the address of the nameserver!
-    [(question-result _ enhanced-zone answers _ _)
-     (define address-rrs (filter-by-type answers 'a))
-     (if (set-empty? address-rrs)
-	 zone ;; Again, no addresses for the nameserver!
-	 (network-query/addresses q
-				  enhanced-zone
-				  ns-rr
-				  (map rr-rdata (set->list address-rrs))))]))
+  (resolve-from-zone
+   (question ns-name 'a 'in) ;; TODO: 'aaaa ?
+   zone
+   #f
+   #t
+   (set)
+   (lambda (qr)
+     (match qr
+       [#f (k zone)] ;; Can't find the address of the nameserver!
+       [(question-result _ enhanced-zone answers _ _)
+	(define address-rrs (filter-by-type answers 'a))
+	(if (set-empty? address-rrs)
+	    (k zone) ;; Again, no addresses for the nameserver!
+	    (resolver-network-query q
+				    enhanced-zone
+				    ns-rr
+				    (map rr-rdata (set->list address-rrs))
+				    k))]))))

 ;; additional-section/a : CompiledZone ListOf<DomainName>
 ;; Implements the "additional section" rules from RFC 1035 (and the
@ -183,22 +189,26 @@
 		   (and start-of-authority (set start-of-authority))
 		   (additional-section/a zone (set-map ns-rrset rr-rdata))))

-(define (resolve-from-zone q zone start-of-authority recursion-desired? nameservers-tried)
+(define (resolve-from-zone q zone start-of-authority recursion-desired? nameservers-tried k)
  (answer-from-zone q zone start-of-authority recursion-desired?
+   k
   (lambda ()
     (let ((best-nameservers (closest-untried-nameservers q zone nameservers-tried)))
       (if (null? best-nameservers)
-	   (empty-answer q zone start-of-authority)
+	   (k (empty-answer q zone start-of-authority))
 	   (if recursion-desired?
 	       (let ((best-nameserver (random-element best-nameservers)))
-		 (define enhanced-zone (network-query q zone best-nameserver))
-		 (if (eq? enhanced-zone #f)
-		     ;; name-error received!
-		     #f
-		     ;; we presumably learned something that might help us
-		     (resolve-from-zone q
-					enhanced-zone
-					start-of-authority
-					recursion-desired?
-					(set-add nameservers-tried best-nameserver))))
-	       (build-referral q zone start-of-authority (list->set best-nameservers))))))))
+		 (network-query q zone best-nameserver
+				(lambda (enhanced-zone)
+				  (write `(BACK-FROM-NETWORK-QUERY (original-question ,q) (best-nameserver ,best-nameserver) (qr ,enhanced-zone))) (newline)
+				  (if (eq? enhanced-zone #f)
+				      ;; name-error received!
+				      (k #f)
+				      ;; we presumably learned something that might help us
+				      (resolve-from-zone q
+							 enhanced-zone
+							 start-of-authority
+							 recursion-desired?
+							 (set-add nameservers-tried best-nameserver)
+							 k)))))
+	       (k (build-referral q zone start-of-authority (list->set best-nameservers)))))))))
--- a/simplified-driver.rkt
+++ b/simplified-driver.rkt
@ -10,20 +10,10 @@
 (require "api.rkt")
 (require "codec.rkt")
 (require "zonedb.rkt")
-(require "network-query-sig.rkt")
-(require "resolver-unit.rkt")
+(require "resolver.rkt")
 (require "dump-bytes.rkt")
 (require "simple-udp-service.rkt")

-(define-unit network-query@
-  (import)
-  (export network-query^)
-  (define (network-query/addresses q db ns-rr addresses)
-    (error 'network-query/addresses "Forbidden to invoke resolver in server")))
-
-(define-values/invoke-unit/infer
-  (link resolver@ network-query@))
-
 ;; Instantiated with a SOA record for the zone it is serving as well
 ;; as a zone's worth of DNS data which is used to answer queries
 ;; authoritatively. Never caches information, never performs recursive
@ -127,7 +117,7 @@
    ;;
    ;; TODO: We support returning out-of-bailiwick records (glue)
    ;; here. Reexamine the rules for doing so.
-    (match (resolve-from-zone q zone soa-rr #f (set))
+    (match (resolve-from-zone q zone soa-rr #f (set) values)
      [#f
       (make-reply (question-name q)
 		   #t