From e7f3e7905386bb7d8a50bc55647e69cac1be7ab7 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 24 Jan 2012 14:19:25 -0500 Subject: [PATCH] CPS-convert resolve-from-zone to expose network I/O actions. --- big-bang-driver.rkt | 16 +-- ground-udp-operations-unit.rkt | 14 --- network-query-sig.rkt | 3 - network-query-unit.rkt => network-query.rkt | 17 +-- proxy.rkt | 2 +- resolver-sig.rkt | 3 - resolver-test.rkt | 66 ++++++------ resolver-unit.rkt => resolver.rkt | 110 +++++++++++--------- simplified-driver.rkt | 14 +-- 9 files changed, 111 insertions(+), 134 deletions(-) delete mode 100644 ground-udp-operations-unit.rkt delete mode 100644 network-query-sig.rkt rename network-query-unit.rkt => network-query.rkt (95%) delete mode 100644 resolver-sig.rkt rename resolver-unit.rkt => resolver.rkt (73%) diff --git a/big-bang-driver.rkt b/big-bang-driver.rkt index d5ee24a..58460c0 100644 --- 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 diff --git a/ground-udp-operations-unit.rkt b/ground-udp-operations-unit.rkt deleted file mode 100644 index 4cd96e4..0000000 --- a/ground-udp-operations-unit.rkt +++ /dev/null @@ -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))) diff --git a/network-query-sig.rkt b/network-query-sig.rkt deleted file mode 100644 index 554f51b..0000000 --- a/network-query-sig.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang racket/signature - -network-query/addresses ;; Question CompiledZone NS-RR ListOf -> Maybe diff --git a/network-query-unit.rkt b/network-query.rkt similarity index 95% rename from network-query-unit.rkt rename to network-query.rkt index 503b964..900ab11 100644 --- a/network-query-unit.rkt +++ b/network-query.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): ;;
@@ -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 IPv4 Seconds ;; -> (or Maybe 'no-answer) diff --git a/proxy.rkt b/proxy.rkt index cdc6788..75e1ee9 100644 --- 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) diff --git a/resolver-sig.rkt b/resolver-sig.rkt deleted file mode 100644 index 4cf449f..0000000 --- a/resolver-sig.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang racket/signature - -resolve-from-zone ;; Question CompiledZone SOA-RR Boolean Set -> QuestionResult diff --git a/resolver-test.rkt b/resolver-test.rkt index 2a5a3a9..1be831d 100644 --- 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)) diff --git a/resolver-unit.rkt b/resolver.rkt similarity index 73% rename from resolver-unit.rkt rename to resolver.rkt index 80ee768..ae4b038 100644 --- a/resolver-unit.rkt +++ b/resolver.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 ;; 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))))))))) diff --git a/simplified-driver.rkt b/simplified-driver.rkt index 958671b..14a3216 100644 --- 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