CPS-convert resolve-from-zone to expose network I/O actions.
This commit is contained in:
parent
f07495520e
commit
e7f3e79053
|
@ -2,7 +2,6 @@
|
||||||
|
|
||||||
;; DNS server using os-big-bang.rkt and os-udp.rkt.
|
;; DNS server using os-big-bang.rkt and os-udp.rkt.
|
||||||
|
|
||||||
(require racket/unit)
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/bool)
|
(require racket/bool)
|
||||||
|
@ -10,22 +9,13 @@
|
||||||
(require "api.rkt")
|
(require "api.rkt")
|
||||||
(require "codec.rkt")
|
(require "codec.rkt")
|
||||||
(require "zonedb.rkt")
|
(require "zonedb.rkt")
|
||||||
(require "network-query-sig.rkt")
|
(require "network-query.rkt")
|
||||||
(require "resolver-unit.rkt")
|
(require "resolver.rkt")
|
||||||
(require "dump-bytes.rkt")
|
(require "dump-bytes.rkt")
|
||||||
(require "os.rkt")
|
(require "os.rkt")
|
||||||
(require "os-big-bang.rkt")
|
(require "os-big-bang.rkt")
|
||||||
(require "os-udp.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
|
;; 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
|
;; as a zone's worth of DNS data which is used to answer queries
|
||||||
;; authoritatively. Never caches information, never performs recursive
|
;; authoritatively. Never caches information, never performs recursive
|
||||||
|
@ -151,7 +141,7 @@
|
||||||
;;
|
;;
|
||||||
;; TODO: We support returning out-of-bailiwick records (glue)
|
;; TODO: We support returning out-of-bailiwick records (glue)
|
||||||
;; here. Reexamine the rules for doing so.
|
;; 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
|
[#f
|
||||||
(make-reply (question-name q)
|
(make-reply (question-name q)
|
||||||
#t
|
#t
|
||||||
|
|
|
@ -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)))
|
|
|
@ -1,3 +0,0 @@
|
||||||
#lang racket/signature
|
|
||||||
|
|
||||||
network-query/addresses ;; Question CompiledZone NS-RR ListOf<IPv4> -> Maybe<CompiledZone>
|
|
|
@ -1,20 +1,16 @@
|
||||||
#lang racket/unit
|
#lang racket/base
|
||||||
|
|
||||||
(require racket/pretty)
|
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
(require racket/udp)
|
||||||
(require "api.rkt")
|
(require "api.rkt")
|
||||||
(require "codec.rkt")
|
(require "codec.rkt")
|
||||||
(require "zonedb.rkt")
|
(require "zonedb.rkt")
|
||||||
(require "udp-operations-sig.rkt")
|
|
||||||
(require "network-query-sig.rkt")
|
|
||||||
|
|
||||||
(import udp-operations^)
|
(provide network-query/addresses)
|
||||||
(export network-query^)
|
|
||||||
|
|
||||||
;; DJB's rules for handling DNS responses. Some of these are handled
|
;; DJB's rules for handling DNS responses. Some of these are handled
|
||||||
;; here (specifically, rules 2 through 5, in the action of
|
;; 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):
|
;; 1, in the action of answer-from-zone):
|
||||||
|
|
||||||
;; <blockquote>
|
;; <blockquote>
|
||||||
|
@ -153,6 +149,11 @@
|
||||||
['no-answer (search (cdr remaining-ips))]
|
['no-answer (search (cdr remaining-ips))]
|
||||||
[result result]))))
|
[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 :
|
;; network-query/address/timeout :
|
||||||
;; UdpSocket Question CompiledZone RR<NS> IPv4 Seconds
|
;; UdpSocket Question CompiledZone RR<NS> IPv4 Seconds
|
||||||
;; -> (or Maybe<CompiledZone> 'no-answer)
|
;; -> (or Maybe<CompiledZone> 'no-answer)
|
|
@ -203,7 +203,7 @@
|
||||||
#f
|
#f
|
||||||
request-source)))
|
request-source)))
|
||||||
(run-inferior (lambda ()
|
(run-inferior (lambda ()
|
||||||
(match (resolve-from-zone q #f cache resolve-iteratively)
|
(match (resolve-from-zone q #f cache resolve-iteratively values)
|
||||||
[#f
|
[#f
|
||||||
(make-answer '() '() '())]
|
(make-answer '() '() '())]
|
||||||
[(question-result _ new-cache answers authorities additional)
|
[(question-result _ new-cache answers authorities additional)
|
||||||
|
|
|
@ -1,3 +0,0 @@
|
||||||
#lang racket/signature
|
|
||||||
|
|
||||||
resolve-from-zone ;; Question CompiledZone SOA-RR Boolean Set<NS-RR> -> QuestionResult
|
|
|
@ -9,12 +9,8 @@
|
||||||
(require "api.rkt")
|
(require "api.rkt")
|
||||||
(require "codec.rkt")
|
(require "codec.rkt")
|
||||||
(require "zonedb.rkt")
|
(require "zonedb.rkt")
|
||||||
(require "ground-udp-operations-unit.rkt")
|
(require "network-query.rkt")
|
||||||
(require "network-query-unit.rkt")
|
(require "resolver.rkt")
|
||||||
(require "resolver-unit.rkt")
|
|
||||||
|
|
||||||
(define-values/invoke-unit/infer
|
|
||||||
(link resolver@ network-query@ ground-udp-operations@))
|
|
||||||
|
|
||||||
;; (require racket/trace)
|
;; (require racket/trace)
|
||||||
;; (trace ;;resolve-from-zone
|
;; (trace ;;resolve-from-zone
|
||||||
|
@ -31,27 +27,37 @@
|
||||||
;; ;;in-bailiwick?
|
;; ;;in-bailiwick?
|
||||||
;; )
|
;; )
|
||||||
|
|
||||||
(pretty-print
|
(define (drive-resolver qr)
|
||||||
(resolve-from-zone (question
|
(match qr
|
||||||
;;'(#"www" #"google" #"com")
|
[(resolver-network-query q zone ns-rr addresses k)
|
||||||
;;'(#"foo" #"rallyx" #"ccs" #"neu" #"edu")
|
(write `(INTERMEDIATE ,q ,ns-rr (,(length addresses) addresses))) (newline)
|
||||||
;;'(#"rallyx" #"ccs" #"neu" #"edu")
|
(drive-resolver (k (network-query/addresses q zone ns-rr addresses)))]
|
||||||
'(#"www" #"eighty-twenty" #"org")
|
[_ qr]))
|
||||||
'a
|
|
||||||
'in)
|
(define (run-question name qtype)
|
||||||
(compile-zone-db
|
(drive-resolver
|
||||||
;; (list (rr '() 'ns 'in 30 '(#"google-public-dns-a" #"google" #"com"))
|
(resolve-from-zone (question name qtype 'in)
|
||||||
;; (rr '(#"google-public-dns-a" #"google" #"com") 'a 'in 30 '#(8 8 8 8)))
|
(compile-zone-db
|
||||||
(list (rr '() 'ns 'in 30 '(#"f" #"root-servers" #"net"))
|
;; (list (rr '() 'ns 'in 30 '(#"google-public-dns-a" #"google" #"com"))
|
||||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(198 41 0 4))
|
;; (rr '(#"google-public-dns-a" #"google" #"com") 'a 'in 30 '#(8 8 8 8)))
|
||||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 228 79 201))
|
(list (rr '() 'ns 'in 30 '(#"f" #"root-servers" #"net"))
|
||||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 33 4 12))
|
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(198 41 0 4))
|
||||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 203 230 10))
|
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 228 79 201))
|
||||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 112 36 4))
|
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 33 4 12))
|
||||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(128 63 2 53))
|
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 203 230 10))
|
||||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 58 128 30))
|
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 112 36 4))
|
||||||
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(193 0 14 129)))
|
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(128 63 2 53))
|
||||||
)
|
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 58 128 30))
|
||||||
#f
|
(rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(193 0 14 129)))
|
||||||
#t
|
)
|
||||||
(set)))
|
#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))
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
#lang racket/unit
|
#lang racket/base
|
||||||
|
|
||||||
(require racket/pretty)
|
(require racket/pretty)
|
||||||
|
|
||||||
|
@ -7,11 +7,11 @@
|
||||||
(require "api.rkt")
|
(require "api.rkt")
|
||||||
(require "codec.rkt")
|
(require "codec.rkt")
|
||||||
(require "zonedb.rkt")
|
(require "zonedb.rkt")
|
||||||
(require "network-query-sig.rkt")
|
|
||||||
(require "resolver-sig.rkt")
|
|
||||||
|
|
||||||
(import network-query^)
|
(provide (struct-out resolver-network-query)
|
||||||
(export resolver^)
|
resolve-from-zone)
|
||||||
|
|
||||||
|
(struct resolver-network-query (q zone ns-rr addresses k) #:transparent)
|
||||||
|
|
||||||
;; Rules:
|
;; Rules:
|
||||||
;;
|
;;
|
||||||
|
@ -56,7 +56,7 @@
|
||||||
(set-union u1 u2)
|
(set-union u1 u2)
|
||||||
(set-union d1 d2))]))
|
(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)
|
(match-define (question name qtype qclass) q)
|
||||||
(define rrset (hash-ref zone name set))
|
(define rrset (hash-ref zone name set))
|
||||||
(define filtered-rrs (filter-rrs rrset qtype qclass))
|
(define filtered-rrs (filter-rrs rrset qtype qclass))
|
||||||
|
@ -69,23 +69,25 @@
|
||||||
(set start-of-authority)
|
(set start-of-authority)
|
||||||
(set))
|
(set))
|
||||||
(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.
|
;; 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)))
|
||||||
(if (and (not (set-empty? cnames)) (not (eqv? qtype 'cname)))
|
(let loop ((cnames (set->list cnames))
|
||||||
(foldl (lambda (cname-rr current-reply)
|
(reply base-reply))
|
||||||
(merge-replies current-reply
|
(if (null? cnames)
|
||||||
(resolve-from-zone
|
(k reply)
|
||||||
(question (rr-rdata cname-rr) qtype qclass)
|
(let ((cname-rr (car cnames)))
|
||||||
zone
|
(resolve-from-zone
|
||||||
start-of-authority
|
(question (rr-rdata cname-rr) qtype qclass)
|
||||||
recursion-desired?
|
zone
|
||||||
(set))))
|
start-of-authority
|
||||||
base-reply
|
recursion-desired?
|
||||||
(set->list cnames))
|
(set)
|
||||||
base-reply))
|
(lambda (qr) (loop (cdr cnames) (merge-replies reply qr)))))))
|
||||||
(if (set-empty? (question-result-answers expanded-reply))
|
(k base-reply)))
|
||||||
(kf)
|
|
||||||
expanded-reply))
|
|
||||||
|
|
||||||
(define (closest-nameservers name zone)
|
(define (closest-nameservers name zone)
|
||||||
(let search ((name name))
|
(let search ((name name))
|
||||||
|
@ -139,24 +141,28 @@
|
||||||
(define (random-element a-nonempty-list)
|
(define (random-element a-nonempty-list)
|
||||||
(car 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))
|
(define ns-name (rr-rdata ns-rr))
|
||||||
;; ^ the rr-name is the subzone origin; the rr-rdata is the
|
;; ^ the rr-name is the subzone origin; the rr-rdata is the
|
||||||
;; nameserver for the subzone
|
;; nameserver for the subzone
|
||||||
(match (resolve-from-zone (question ns-name 'a 'in) ;; TODO: 'aaaa ?
|
(resolve-from-zone
|
||||||
zone
|
(question ns-name 'a 'in) ;; TODO: 'aaaa ?
|
||||||
#f
|
zone
|
||||||
#t
|
#f
|
||||||
(set))
|
#t
|
||||||
[#f zone] ;; Can't find the address of the nameserver!
|
(set)
|
||||||
[(question-result _ enhanced-zone answers _ _)
|
(lambda (qr)
|
||||||
(define address-rrs (filter-by-type answers 'a))
|
(match qr
|
||||||
(if (set-empty? address-rrs)
|
[#f (k zone)] ;; Can't find the address of the nameserver!
|
||||||
zone ;; Again, no addresses for the nameserver!
|
[(question-result _ enhanced-zone answers _ _)
|
||||||
(network-query/addresses q
|
(define address-rrs (filter-by-type answers 'a))
|
||||||
enhanced-zone
|
(if (set-empty? address-rrs)
|
||||||
ns-rr
|
(k zone) ;; Again, no addresses for the nameserver!
|
||||||
(map rr-rdata (set->list address-rrs))))]))
|
(resolver-network-query q
|
||||||
|
enhanced-zone
|
||||||
|
ns-rr
|
||||||
|
(map rr-rdata (set->list address-rrs))
|
||||||
|
k))]))))
|
||||||
|
|
||||||
;; additional-section/a : CompiledZone ListOf<DomainName>
|
;; additional-section/a : CompiledZone ListOf<DomainName>
|
||||||
;; Implements the "additional section" rules from RFC 1035 (and the
|
;; Implements the "additional section" rules from RFC 1035 (and the
|
||||||
|
@ -183,22 +189,26 @@
|
||||||
(and start-of-authority (set start-of-authority))
|
(and start-of-authority (set start-of-authority))
|
||||||
(additional-section/a zone (set-map ns-rrset rr-rdata))))
|
(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?
|
(answer-from-zone q zone start-of-authority recursion-desired?
|
||||||
|
k
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ((best-nameservers (closest-untried-nameservers q zone nameservers-tried)))
|
(let ((best-nameservers (closest-untried-nameservers q zone nameservers-tried)))
|
||||||
(if (null? best-nameservers)
|
(if (null? best-nameservers)
|
||||||
(empty-answer q zone start-of-authority)
|
(k (empty-answer q zone start-of-authority))
|
||||||
(if recursion-desired?
|
(if recursion-desired?
|
||||||
(let ((best-nameserver (random-element best-nameservers)))
|
(let ((best-nameserver (random-element best-nameservers)))
|
||||||
(define enhanced-zone (network-query q zone best-nameserver))
|
(network-query q zone best-nameserver
|
||||||
(if (eq? enhanced-zone #f)
|
(lambda (enhanced-zone)
|
||||||
;; name-error received!
|
(write `(BACK-FROM-NETWORK-QUERY (original-question ,q) (best-nameserver ,best-nameserver) (qr ,enhanced-zone))) (newline)
|
||||||
#f
|
(if (eq? enhanced-zone #f)
|
||||||
;; we presumably learned something that might help us
|
;; name-error received!
|
||||||
(resolve-from-zone q
|
(k #f)
|
||||||
enhanced-zone
|
;; we presumably learned something that might help us
|
||||||
start-of-authority
|
(resolve-from-zone q
|
||||||
recursion-desired?
|
enhanced-zone
|
||||||
(set-add nameservers-tried best-nameserver))))
|
start-of-authority
|
||||||
(build-referral q zone start-of-authority (list->set best-nameservers))))))))
|
recursion-desired?
|
||||||
|
(set-add nameservers-tried best-nameserver)
|
||||||
|
k)))))
|
||||||
|
(k (build-referral q zone start-of-authority (list->set best-nameservers)))))))))
|
|
@ -10,20 +10,10 @@
|
||||||
(require "api.rkt")
|
(require "api.rkt")
|
||||||
(require "codec.rkt")
|
(require "codec.rkt")
|
||||||
(require "zonedb.rkt")
|
(require "zonedb.rkt")
|
||||||
(require "network-query-sig.rkt")
|
(require "resolver.rkt")
|
||||||
(require "resolver-unit.rkt")
|
|
||||||
(require "dump-bytes.rkt")
|
(require "dump-bytes.rkt")
|
||||||
(require "simple-udp-service.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
|
;; 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
|
;; as a zone's worth of DNS data which is used to answer queries
|
||||||
;; authoritatively. Never caches information, never performs recursive
|
;; authoritatively. Never caches information, never performs recursive
|
||||||
|
@ -127,7 +117,7 @@
|
||||||
;;
|
;;
|
||||||
;; TODO: We support returning out-of-bailiwick records (glue)
|
;; TODO: We support returning out-of-bailiwick records (glue)
|
||||||
;; here. Reexamine the rules for doing so.
|
;; 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
|
[#f
|
||||||
(make-reply (question-name q)
|
(make-reply (question-name q)
|
||||||
#t
|
#t
|
||||||
|
|
Loading…
Reference in New Issue