Rearrange resolver/network-query interaction, in particular making
network-query a separate os.rkt process.
This commit is contained in:
Tony Garnock-Jones
parent
ed4fe93405
commit
4b7c931527
52
api.rkt
52
api.rkt
|
|
@ -2,9 +2,14 @@
|
|||
;; Definitions for use in the API to the functionality of the library.
|
||||
|
||||
(provide (struct-out question)
|
||||
(struct-out question-result)
|
||||
(struct-out answered-question)
|
||||
(struct-out rr)
|
||||
|
||||
(struct-out complete-answer)
|
||||
empty-complete-answer
|
||||
merge-answers
|
||||
extract-addresses
|
||||
|
||||
(struct-out hinfo)
|
||||
(struct-out minfo)
|
||||
(struct-out mx)
|
||||
|
|
@ -18,6 +23,8 @@
|
|||
qclass->value value->qclass)
|
||||
|
||||
(require "mapping.rkt")
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
|
||||
;; A DomainName is a ListOf<Bytes>, representing a domain name. The
|
||||
;; head of the list is the leftmost label; for example, www.google.com
|
||||
|
|
@ -39,12 +46,12 @@
|
|||
;; type and class?"
|
||||
(struct question (name type class) #:transparent)
|
||||
|
||||
;; A QuestionResult is a (question-result Question CompiledZone
|
||||
;; SetOf<RR> SetOf<RR> SetOf<RR>), representing the results of
|
||||
;; answering a Question in the context of a given RR database,
|
||||
;; possibly after recursively asking other servers for answers.
|
||||
(struct question-result (question knowledge answers authorities additional)
|
||||
#:transparent)
|
||||
;; An AnsweredQuestion is an (answered-question Question
|
||||
;; CompleteAnswer).
|
||||
(struct answered-question (q a) #:transparent)
|
||||
|
||||
;; A CompleteAnswer is a (complete-answer Set<RR> Set<RR> Set<RR>)
|
||||
(struct complete-answer (rrs authorities additional) #:transparent)
|
||||
|
||||
;; An RR is a (rr DomainName RRType RRClass Uint32 RData),
|
||||
;; representing a resource record.
|
||||
|
|
@ -131,3 +138,34 @@
|
|||
#:forward-default class->value
|
||||
#:backward-default value->class
|
||||
(* 255))
|
||||
|
||||
;; -> CompleteAnswer
|
||||
(define (empty-complete-answer)
|
||||
(complete-answer (set) (set) (set)))
|
||||
|
||||
;; CompleteAnswer CompleteAnswer -> CompleteAnswer
|
||||
(define (merge-answers a1 a2)
|
||||
(match-define (complete-answer n1 u1 d1) a1)
|
||||
(match-define (complete-answer n2 u2 d2) a2)
|
||||
(complete-answer (set-union n1 n2)
|
||||
(set-union u1 u2)
|
||||
(set-union d1 d2)))
|
||||
|
||||
;; DomainName CompleteAnswer -> ListOf<IPv4>
|
||||
(define (extract-addresses name ans)
|
||||
(match-define (complete-answer ns us ds) ans)
|
||||
(define rrs (set->list (set-union ns us ds)))
|
||||
(let loop ((names (list name))
|
||||
(ips (set))
|
||||
(seen (set)))
|
||||
(if (null? names)
|
||||
ips
|
||||
(let* ((name (car names))
|
||||
(records (filter (lambda (rr) (equal? name (rr-name rr))) rrs)))
|
||||
(if (set-member? seen name)
|
||||
(loop (cdr names) ips seen)
|
||||
(let ((a-records (filter (lambda (rr) (equal? 'a (rr-type rr))) records))
|
||||
(cname-records (filter (lambda (rr) (equal? 'cname (rr-type rr))) records)))
|
||||
(loop (append (map rr-rdata cname-records) (cdr names))
|
||||
(set-union ips (list->set (map rr-rdata a-records)))
|
||||
(set-add seen name))))))))
|
||||
|
|
|
|||
44
driver.rkt
44
driver.rkt
|
|
@ -102,19 +102,35 @@
|
|||
;;
|
||||
;; 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) values)
|
||||
[#f
|
||||
(make-reply (question-name q)
|
||||
#t
|
||||
(set)
|
||||
(set)
|
||||
(set))]
|
||||
[(question-result _ _ answers authorities additional)
|
||||
(make-reply (question-name q)
|
||||
#f
|
||||
answers
|
||||
authorities
|
||||
additional)]))
|
||||
(match-define (question qname qtype qclass) q)
|
||||
|
||||
(define (expand-cnames worklist ans)
|
||||
(match worklist
|
||||
['()
|
||||
(match-define (complete-answer ns us ds) ans)
|
||||
(make-reply qname #f ns us ds)]
|
||||
[(cons next-cname rest)
|
||||
(define a (resolve-from-zone (question next-cname qtype qclass) zone soa-rr (set)))
|
||||
(incorporate-answer a rest ans)]))
|
||||
|
||||
(define (incorporate-answer this-answer worklist ans)
|
||||
(match this-answer
|
||||
[(partial-answer new-info more-cnames)
|
||||
(expand-cnames (append worklist more-cnames)
|
||||
(merge-answers new-info ans))]
|
||||
[(? complete-answer?)
|
||||
(expand-cnames worklist
|
||||
(merge-answers this-answer ans))]
|
||||
[_ ;; #f or a referral
|
||||
(expand-cnames worklist ans)]))
|
||||
|
||||
(match (resolve-from-zone q zone soa-rr (set))
|
||||
[#f ;; Signal name-error/NXDOMAIN
|
||||
(make-reply qname #t (set) (set) (set))]
|
||||
[(referral _ ns-rrs additional)
|
||||
(make-reply qname #f ns-rrs (set soa-rr) additional)]
|
||||
[this-answer
|
||||
(incorporate-answer this-answer '() (empty-complete-answer))]))
|
||||
|
||||
;; TODO: check opcode and direction in request
|
||||
;; TODO: think again about multiple questions in one packet
|
||||
|
|
@ -123,4 +139,4 @@
|
|||
(first-only (dns-message-questions request-message))))
|
||||
|
||||
(require "test-rrs.rkt")
|
||||
(start-server 5555 test-soa-rr test-rrs)
|
||||
(start-server (test-port-number) test-soa-rr test-rrs)
|
||||
|
|
|
|||
|
|
@ -10,12 +10,16 @@
|
|||
(require "os-dns.rkt")
|
||||
(require "os-timer.rkt")
|
||||
|
||||
(provide network-query/addresses)
|
||||
(provide network-query
|
||||
(struct-out network-reply))
|
||||
|
||||
;; 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.rkt (rule
|
||||
;; 1, in the action of answer-from-zone):
|
||||
;; filter-dns-reply), some are handled in resolver.rkt (rule 1, in the
|
||||
;; action of answer-from-zone), and some are handled in the
|
||||
;; interaction between the resolver and the network-query modules
|
||||
;; (rule 1 as well, the interplay between CNAME expansion and
|
||||
;; recursion):
|
||||
|
||||
;; <blockquote>
|
||||
;; When a cache receives a normal DNS response, it learns exactly one
|
||||
|
|
@ -60,8 +64,40 @@
|
|||
;; possible way.
|
||||
;; </blockquote>
|
||||
|
||||
;; A NetworkQueryResult is a ListOf<Action>, some actions to take:
|
||||
;; either involved in or resulting from completion of the network
|
||||
;; query.
|
||||
|
||||
(define first-timeout 3) ;; seconds
|
||||
|
||||
;; A NetworkRequest is a (network-request UdpAddress Question
|
||||
;; DomainName NEListOf<UdpAddress> UniqueID) representing the
|
||||
;; parameters used to start and process a network query.
|
||||
(struct network-request (client-socket
|
||||
question
|
||||
zone-origin
|
||||
server-ips
|
||||
unique-id)
|
||||
#:transparent)
|
||||
|
||||
;; A NetworkReply is a (network-reply UniqueID Maybe<CompleteAnswer>)
|
||||
;; representing the final result of a network query.
|
||||
(struct network-reply (unique-id answer) #:transparent)
|
||||
|
||||
;; A NetworkQueryState is a (network-query-state NetworkRequest
|
||||
;; Integer ListOf<UdpAddress>), representing an in-progress DNS
|
||||
;; network query.
|
||||
(struct network-query-state (request
|
||||
timeout
|
||||
remaining-addresses)
|
||||
#:transparent)
|
||||
|
||||
;; A ResolvingNameservers is a (resolving-nameservers NetworkRequest
|
||||
;; Integer), representing an in-progress nameserver resolution
|
||||
;; operation that must be completed before the actual query can
|
||||
;; continue.
|
||||
(struct resolving-nameservers (request remaining-count) #:transparent)
|
||||
|
||||
;; seconds -> Maybe<seconds>
|
||||
(define (next-timeout timeout)
|
||||
(case timeout
|
||||
|
|
@ -69,13 +105,8 @@
|
|||
((11) 45)
|
||||
((45) #f)))
|
||||
|
||||
;; IPv4 -> String
|
||||
(define (ip->host-name ip-address)
|
||||
(match-define (vector a b c d) ip-address)
|
||||
(format "~a.~a.~a.~a" a b c d))
|
||||
|
||||
(define (make-dns-query-message q)
|
||||
(dns-message (random 65536)
|
||||
(define (make-dns-query-message q query-id)
|
||||
(dns-message query-id
|
||||
'request
|
||||
'query
|
||||
'non-authoritative
|
||||
|
|
@ -88,7 +119,7 @@
|
|||
'()
|
||||
'()))
|
||||
|
||||
;; filter-dns-reply : DNSMessage DomainName -> (or Maybe<Set<RR>> 'no-answer)
|
||||
;; filter-dns-reply : DNSMessage DomainName -> (or Maybe<CompleteAnswer> 'no-answer)
|
||||
;;
|
||||
;; Filters RRs from the answer, authorities, and additional sections
|
||||
;; of the passed-in `message`, returning the set of RRs surviving the
|
||||
|
|
@ -99,88 +130,98 @@
|
|||
;; code, `'no-answer` is returned.
|
||||
(define (filter-dns-reply message zone-origin)
|
||||
(case (dns-message-response-code message)
|
||||
[(no-error)
|
||||
(list->set
|
||||
(filter (lambda (claim-rr) (in-bailiwick? (rr-name claim-rr) zone-origin))
|
||||
(append (dns-message-answers message)
|
||||
(dns-message-authorities message)
|
||||
(dns-message-additional message))))]
|
||||
[(no-error)
|
||||
(define (f l)
|
||||
(list->set (filter (lambda (claim-rr) (in-bailiwick? (rr-name claim-rr) zone-origin)) l)))
|
||||
(complete-answer (f (dns-message-answers message))
|
||||
(f (dns-message-authorities message))
|
||||
(f (dns-message-additional message)))]
|
||||
[(name-error) #f]
|
||||
[else 'no-answer]))
|
||||
|
||||
;; network-query/addresses :
|
||||
;; UdpAddress Question DomainName ListOf<IPv4>
|
||||
;; (Maybe<Set<RR>> -> ListOf<Action>) -> ListOf<Action>
|
||||
;;
|
||||
;; Repeatedly uses `network-query/addresses/timeout` to try asking the
|
||||
;; whole of `server-ips` the question `q`, starting with a timeout of
|
||||
;; `first-timeout` seconds and increasing each time
|
||||
;; `network-query/addresses/timeout` returns `'no-answer` up to a
|
||||
;; give-up timeout limit.
|
||||
(define (network-query/addresses s q zone-origin server-ips k)
|
||||
(let try-with-timeout ((timeout first-timeout))
|
||||
(if timeout
|
||||
(network-query/addresses/timeout s q zone-origin server-ips timeout
|
||||
(lambda (result)
|
||||
(if (eq? result 'no-answer)
|
||||
(try-with-timeout (next-timeout timeout))
|
||||
(k result))))
|
||||
(k (set)))))
|
||||
;; IPv4 -> String
|
||||
(define (ip->host-name ip-address)
|
||||
(match-define (vector a b c d) ip-address)
|
||||
(format "~a.~a.~a.~a" a b c d))
|
||||
|
||||
;; network-query/addresses/timeout :
|
||||
;; UdpAddress Question DomainName ListOf<IPv4> Seconds
|
||||
;; ((or Maybe<Set<RR>> 'no-answer) -> ListOf<Action>) -> ListOf<Action>
|
||||
;;
|
||||
;; Sends the question to each of the servers whose addresses are given
|
||||
;; in `server-ips` using `network-query/address/timeout`, one at a
|
||||
;; time, in order, trying the next in the list only if `'no-answer`
|
||||
;; results from the most recent communication attempt. If and when the
|
||||
;; list is exhausted, `'no-answer` is returned.
|
||||
(define (network-query/addresses/timeout s q zone-origin server-ips timeout k)
|
||||
;; TODO: randomize ordering of servers in list.
|
||||
(let search ((remaining-ips server-ips))
|
||||
(if (null? remaining-ips)
|
||||
(k 'no-answer)
|
||||
(network-query/address/timeout s q zone-origin (car remaining-ips) timeout
|
||||
(lambda (result)
|
||||
(if (eq? result 'no-answer)
|
||||
(search (cdr remaining-ips))
|
||||
(k result)))))))
|
||||
(define (make-dns-address ip-address)
|
||||
(udp-address (ip->host-name ip-address) 53))
|
||||
|
||||
;; network-query/address/timeout :
|
||||
;; UdpAddress Question DomainName IPv4 Seconds
|
||||
;; ((or Maybe<Set<RR>> 'no-answer) -> ListOf<Action>) -> ListOf<Action>
|
||||
;;
|
||||
;; Sends the question to the server address `server-ip` given. Waits
|
||||
;; `timeout` seconds for an answer: if one arrives, it is filtered and
|
||||
;; the result is returned to the caller. If the timeout expires before
|
||||
;; a reply is received, or some error result is received from the
|
||||
;; server, `'no-answer` is returned to the caller.
|
||||
(define (network-query/address/timeout s q zone-origin server-ip timeout k)
|
||||
(define server-host-name (ip->host-name server-ip))
|
||||
(define server-port 53)
|
||||
(define query (make-dns-query-message q))
|
||||
(define req (dns-request query
|
||||
s
|
||||
(udp-address server-host-name server-port)))
|
||||
(define subscription-id (list s (dns-message-id query)))
|
||||
(define start-time (current-inexact-milliseconds))
|
||||
(list (send-message req)
|
||||
(send-message (set-timer subscription-id (* timeout 1000) #t))
|
||||
(subscribe subscription-id
|
||||
;; network-query : UdpAddress Question DomainName NEListOf<DomainName> UniqueId -> OsProcess
|
||||
(define (network-query s q zone-origin server-names unique-id)
|
||||
(os-big-bang (resolving-nameservers (network-request s q zone-origin '() unique-id)
|
||||
(length server-names))
|
||||
(map (lambda (nameserver-name)
|
||||
(define subscription-id (list 'nameserver-name-resolution nameserver-name))
|
||||
(define subq (question nameserver-name 'a 'in)) ;; TODO: 'aaaa ?
|
||||
(list (send-message subq)
|
||||
(subscribe subscription-id
|
||||
(message-handlers (resolving-nameservers req remaining)
|
||||
[(answered-question (== subq) ans)
|
||||
(define new-ips
|
||||
(append (network-request-server-ips req)
|
||||
(map make-dns-address
|
||||
(set->list (extract-addresses nameserver-name ans)))))
|
||||
(define new-req (struct-copy network-request req [server-ips new-ips]))
|
||||
(define new-remaining (- remaining 1))
|
||||
(extend-transition
|
||||
(if (zero? new-remaining)
|
||||
(try-next-server (network-query-state new-req
|
||||
first-timeout
|
||||
new-ips))
|
||||
(transition (resolving-nameservers new-req new-remaining)))
|
||||
(unsubscribe subscription-id))]))))
|
||||
server-names)))
|
||||
|
||||
(define (try-next-server w)
|
||||
(match w
|
||||
[(network-query-state req timeout '())
|
||||
;; No more addresses to try with this timeout. Refill the list
|
||||
;; and bump the timeout and retry.
|
||||
;; TODO: randomize ordering of servers in list. (Don't forget the initial fill.)
|
||||
(try-next-server (struct-copy network-query-state w
|
||||
[timeout (next-timeout timeout)]
|
||||
[remaining-addresses (network-request-server-ips req)]))]
|
||||
[(network-query-state req #f _)
|
||||
;; No more timeouts to try, so give up.
|
||||
(on-answer w (empty-complete-answer))]
|
||||
[(network-query-state req timeout (cons current-address remaining-addresses))
|
||||
(define rpc-id (gensym 'network-query/allocate-query-id))
|
||||
(transition w
|
||||
(send-message `(request ,rpc-id allocate-query-id))
|
||||
(subscribe rpc-id
|
||||
(message-handlers w
|
||||
[(timer-expired (== subscription-id) _)
|
||||
(write `(Timed out ,q to ,zone-origin ,server-ip after ,timeout seconds)) (newline)
|
||||
(transition w
|
||||
(unsubscribe subscription-id)
|
||||
(k 'no-answer))]
|
||||
[(dns-reply reply-message source (== s))
|
||||
;; TODO: maybe receive only specifically from the queried IP address?
|
||||
(write `(,q --> ,(dns-message-answers reply-message) from ,server-ip in
|
||||
,(inexact->exact (round (- (current-inexact-milliseconds) start-time)))
|
||||
ms)) (newline)
|
||||
(if (not (= (dns-message-id reply-message) (dns-message-id query)))
|
||||
w
|
||||
(transition w
|
||||
(unsubscribe subscription-id)
|
||||
(k (filter-dns-reply reply-message zone-origin))))]))))
|
||||
[`(reply ,(== rpc-id) ,id)
|
||||
(extend-transition (send-request req id timeout current-address remaining-addresses)
|
||||
(unsubscribe rpc-id))])))]))
|
||||
|
||||
(define (on-answer w ans)
|
||||
(transition w
|
||||
(send-message (network-reply (network-request-unique-id (network-query-state-request w))
|
||||
ans))))
|
||||
|
||||
(define (send-request req query-id timeout server-ip remaining-ips)
|
||||
(match-define (network-request s q zone-origin _ _) req)
|
||||
(define query (make-dns-query-message q query-id))
|
||||
(define subscription-id (list s query-id))
|
||||
(define start-time (current-inexact-milliseconds))
|
||||
(transition (network-query-state req timeout remaining-ips)
|
||||
(send-message (dns-request query s server-ip))
|
||||
(send-message (set-timer subscription-id (* timeout 1000) #t))
|
||||
(subscribe subscription-id
|
||||
(message-handlers w
|
||||
[(timer-expired (== subscription-id) _)
|
||||
(write `(Timed out ,q to ,zone-origin ,server-ip after ,timeout seconds)) (newline)
|
||||
(extend-transition (try-next-server w)
|
||||
(unsubscribe subscription-id)
|
||||
(send-message (list 'release-query-id query-id)))]
|
||||
[(dns-reply reply-message source (== s))
|
||||
;; TODO: maybe receive only specifically from the queried IP address?
|
||||
(write `(,q --> ,(dns-message-answers reply-message) from ,server-ip in
|
||||
,(inexact->exact (round (- (current-inexact-milliseconds) start-time)))
|
||||
ms)) (newline)
|
||||
(if (not (= (dns-message-id reply-message) (dns-message-id query)))
|
||||
w
|
||||
(extend-transition (on-answer w (filter-dns-reply reply-message zone-origin))
|
||||
(unsubscribe subscription-id)
|
||||
(send-message (list 'release-query-id query-id))))]))))
|
||||
|
|
|
|||
|
|
@ -21,9 +21,11 @@
|
|||
|
||||
(except-out (struct-out transition) transition)
|
||||
(rename-out [make-transition transition])
|
||||
extend-transition
|
||||
|
||||
ground-vm ;; reprovided from os.rkt for convenience
|
||||
os-big-bang)
|
||||
os-big-bang
|
||||
os-big-bang/transition)
|
||||
|
||||
;; A SID is an Any, a world-specific identifier for subscriptions.
|
||||
|
||||
|
|
@ -53,7 +55,14 @@
|
|||
;; -- a (transition WorldState ListOf<Action>) or
|
||||
;; -- a WorldState
|
||||
(struct transition (state actions) #:transparent)
|
||||
(define (make-transition state . actions) (transition state (flatten actions)))
|
||||
(define (make-transition state . actions) (transition state actions))
|
||||
|
||||
;; Transition [Action ...] -> Transition
|
||||
;; Append the given actions to the transition given as the first argument.
|
||||
(define (extend-transition t . more-actions)
|
||||
(match t
|
||||
[(transition state actions) (transition state (list actions more-actions))]
|
||||
[state (transition state more-actions)]))
|
||||
|
||||
;; A World is a (world WorldState Map<SID,Set<EventDescription>>), a
|
||||
;; representation of a suspended world and its active subscriptions.
|
||||
|
|
@ -110,7 +119,8 @@
|
|||
(transition->os-transition w (transition t '()))))
|
||||
|
||||
(define (transition->os-transition w t)
|
||||
(match-define (transition state actions) t)
|
||||
(match-define (transition state unflattened-actions) t)
|
||||
(define actions (flatten unflattened-actions))
|
||||
(kernel-mode-transition (world->os-suspension (update-world w state actions))
|
||||
(for/list [(a actions) #:when (send-message? a)]
|
||||
(send-message-body a))
|
||||
|
|
@ -134,6 +144,7 @@
|
|||
actions)))
|
||||
|
||||
(define (os-big-bang initial-state . initial-actions)
|
||||
(lambda ()
|
||||
(transition->os-transition (world (void) (hash))
|
||||
(transition initial-state (flatten initial-actions)))))
|
||||
(os-big-bang/transition (transition initial-state initial-actions)))
|
||||
|
||||
(define (os-big-bang/transition t)
|
||||
(lambda () (transition->os-transition (world (void) (hash)) t)))
|
||||
|
|
|
|||
267
proxy.rkt
267
proxy.rkt
|
|
@ -19,8 +19,8 @@
|
|||
(require "os-timer.rkt")
|
||||
|
||||
;; Instantiated with a collection of trusted roots to begin its
|
||||
;; searches from. Performs recursive queries. Doesn't yet cache
|
||||
;; responses, but will do so in future.
|
||||
;; searches from. Performs recursive queries. Caches in the stupidest
|
||||
;; possible way.
|
||||
|
||||
;; For discarding retransmitted requests that we're still working on.
|
||||
(struct active-request (source id) #:transparent)
|
||||
|
|
@ -28,111 +28,190 @@
|
|||
;; start-proxy : UInt16 ListOf<RR> -> Void
|
||||
(require racket/pretty)
|
||||
(define (start-proxy port-number rrs)
|
||||
;; Compile the zone hash table
|
||||
(define zone (compile-zone-db rrs))
|
||||
(pretty-print zone)
|
||||
|
||||
(define boot-server
|
||||
(os-big-bang (set) ;; SetOf<ActiveRequest>
|
||||
;;(spawn dns-spy)
|
||||
(spawn (timer-relay))
|
||||
(send-meta-message `(request create-server-socket (udp new ,port-number 512)))
|
||||
(subscribe 'wait-for-server-socket
|
||||
(meta-message-handlers w
|
||||
[`(reply create-server-socket ,s)
|
||||
(transition w
|
||||
(unsubscribe 'wait-for-server-socket)
|
||||
(send-meta-message
|
||||
`(request create-client-socket (udp new 0 512)))
|
||||
(client-socket-waiter s))]))))
|
||||
(os-big-bang 'no-state/boot-server
|
||||
;;(spawn dns-spy)
|
||||
(spawn (timer-relay))
|
||||
(spawn (query-id-allocator))
|
||||
(send-meta-message `(request create-server-socket (udp new ,port-number 512)))
|
||||
(subscribe 'wait-for-server-socket
|
||||
(meta-message-handlers w
|
||||
[`(reply create-server-socket ,s)
|
||||
(transition w
|
||||
(unsubscribe 'wait-for-server-socket)
|
||||
(send-meta-message
|
||||
`(request create-client-socket (udp new 0 512)))
|
||||
(client-socket-waiter s))]))))
|
||||
|
||||
(define (client-socket-waiter s)
|
||||
(subscribe 'wait-for-client-socket
|
||||
(meta-message-handlers w
|
||||
[`(reply create-client-socket ,c)
|
||||
(transition w
|
||||
(unsubscribe 'wait-for-client-socket)
|
||||
(spawn (dns-read-driver s))
|
||||
(spawn (dns-write-driver s))
|
||||
(spawn (dns-read-driver c))
|
||||
(spawn (dns-write-driver c))
|
||||
(subscribe 'packet-handler (packet-handler s c)))])))
|
||||
|
||||
(define (packet-handler s c)
|
||||
(message-handlers old-active-requests
|
||||
[(? bad-dns-packet? p)
|
||||
(pretty-print p) ;; TODO: perhaps use metalevel events? perhaps don't bother though
|
||||
old-active-requests]
|
||||
[(and r (dns-request m source (== s))) ;; We only listen for requests on our server socket
|
||||
(define req-id (active-request source (dns-message-id m)))
|
||||
;; TODO: when we have presence/error-handling, remove req-id
|
||||
;; from active requests once request-handler pseudothread exits.
|
||||
(if (set-member? old-active-requests req-id)
|
||||
old-active-requests ;; ignore retransmitted duplicates
|
||||
(transition (set-add old-active-requests req-id)
|
||||
(spawn (request-handler zone r c))))]
|
||||
[(and r (dns-reply m (== s) sink))
|
||||
(define req-id (active-request sink (dns-message-id m)))
|
||||
(set-remove old-active-requests req-id)]))
|
||||
(meta-message-handlers w
|
||||
[`(reply create-client-socket ,c)
|
||||
(display "Ready.") (newline)
|
||||
(transition w
|
||||
(unsubscribe 'wait-for-client-socket)
|
||||
(spawn (dns-read-driver s))
|
||||
(spawn (dns-write-driver s))
|
||||
(spawn (dns-read-driver c))
|
||||
(spawn (dns-write-driver c))
|
||||
(spawn (packet-dispatcher s))
|
||||
(spawn (question-dispatcher (compile-zone-db rrs) c)))])))
|
||||
|
||||
(ground-vm (os-big-bang (void)
|
||||
;;(spawn udp-spy)
|
||||
(spawn udp-driver)
|
||||
(spawn (timer-driver))
|
||||
(spawn (nested-vm boot-server)))))
|
||||
;;(spawn udp-spy)
|
||||
(spawn udp-driver)
|
||||
(spawn (timer-driver))
|
||||
(spawn (nested-vm boot-server)))))
|
||||
|
||||
(define (request-handler zone request client-sock)
|
||||
;; 1. try resolving locally
|
||||
;; 2. if it answers, send that out. otherwise, it needs to request something recursively.
|
||||
;; 3. if the socket doesn't exist, request it, and wait for the reply.
|
||||
;; 4. start processing the network query: it will result in a send/receive/timeout combo
|
||||
;; 5. on timeout, try a different server, or if there aren't any
|
||||
;; more, report failure to the resolver
|
||||
;; 6. on packet, report success to the resolver and goto 2.
|
||||
;; -. remember to release the socket when we're done!
|
||||
(define (query-id-allocator)
|
||||
;; TODO: track how many are allocated and throttle requests if too
|
||||
;; many are in flight
|
||||
(os-big-bang (set) ;; SetOf<UInt16>, all active query IDs
|
||||
(subscribe 'query-id-request-handler
|
||||
(message-handlers allocated
|
||||
[`(request ,reply-addr allocate-query-id)
|
||||
(let recheck ()
|
||||
(define n (random 65536))
|
||||
(if (set-member? allocated n)
|
||||
(recheck)
|
||||
(transition (set-add allocated n)
|
||||
(send-message `(reply ,reply-addr ,n)))))]
|
||||
[`(release-query-id ,n)
|
||||
(transition (set-remove allocated n))]))))
|
||||
|
||||
(define (packet-dispatcher s)
|
||||
(os-big-bang (set) ;; SetOf<ActiveRequest>
|
||||
(subscribe 'packet-dispatcher
|
||||
(message-handlers old-active-requests
|
||||
[(? bad-dns-packet? p)
|
||||
(pretty-print p) ;; TODO: perhaps use metalevel events? perhaps don't bother though
|
||||
old-active-requests]
|
||||
[(and r (dns-request m source (== s))) ;; We only listen for requests on our server socket
|
||||
(define req-id (active-request source (dns-message-id m)))
|
||||
;; TODO: when we have presence/error-handling, remove req-id
|
||||
;; from active requests once request-handler pseudothread exits.
|
||||
(if (set-member? old-active-requests req-id)
|
||||
old-active-requests ;; ignore retransmitted duplicates
|
||||
(transition (set-add old-active-requests req-id)
|
||||
(spawn (packet-relay req-id r))))]
|
||||
[(and r (dns-reply m (== s) sink))
|
||||
(define req-id (active-request sink (dns-message-id m)))
|
||||
(set-remove old-active-requests req-id)]))))
|
||||
|
||||
(define (packet-relay req-id request)
|
||||
(match-define (dns-request request-message request-source request-sink) request)
|
||||
(define question (and (pair? (dns-message-questions request-message))
|
||||
(car (dns-message-questions request-message))))
|
||||
(define (answer->reply q a)
|
||||
(define-values (response-code ns us ds)
|
||||
(match a
|
||||
[#f
|
||||
(values 'name-error '() '() '())]
|
||||
[(complete-answer ns us ds)
|
||||
(values 'no-error (rr-set->list ns) (rr-set->list us) (rr-set->list ds))]))
|
||||
(dns-reply (dns-message (dns-message-id request-message)
|
||||
'response
|
||||
'query
|
||||
'non-authoritative
|
||||
'not-truncated
|
||||
(dns-message-recursion-desired request-message)
|
||||
'recursion-available
|
||||
response-code
|
||||
(if q (list q) '())
|
||||
ns
|
||||
us
|
||||
ds)
|
||||
request-sink
|
||||
request-source))
|
||||
;; TODO: pay attention to recursion-desired flag
|
||||
(match (dns-message-questions request-message)
|
||||
['()
|
||||
;; No questions!
|
||||
(os-big-bang 'no-state/packet-relay
|
||||
(send-message (answer->reply #f (empty-complete-answer))))]
|
||||
[(cons original-question _)
|
||||
;; At least one question
|
||||
(write `(Looking up ,original-question
|
||||
with query id ,(dns-message-id request-message))) (newline)
|
||||
(os-big-bang 'no-state/packet-relay
|
||||
(send-message original-question)
|
||||
(subscribe 'wait-for-answer
|
||||
(message-handlers w
|
||||
[(answered-question (== original-question) answer)
|
||||
(transition w
|
||||
(unsubscribe 'wait-for-answer)
|
||||
(send-message (answer->reply original-question answer)))])))]))
|
||||
|
||||
(write `(Looking up ,question with query id ,(dns-message-id request-message))) (newline)
|
||||
(define (question-dispatcher zone0 client-sock)
|
||||
(os-big-bang zone0
|
||||
;; TODO: consider deduping questions here too?
|
||||
(subscribe 'question-handler-factory
|
||||
(message-handlers zone
|
||||
[(? question? q)
|
||||
(transition zone
|
||||
(spawn (question-handler zone q client-sock)))]
|
||||
[(network-reply _ answer)
|
||||
(incorporate-complete-answer answer zone)]))))
|
||||
|
||||
(define (make-reply answers authorities additional)
|
||||
(dns-message (dns-message-id request-message)
|
||||
'response
|
||||
'query
|
||||
'non-authoritative
|
||||
'not-truncated
|
||||
(dns-message-recursion-desired request-message)
|
||||
'recursion-available
|
||||
'no-error
|
||||
(list question)
|
||||
(rr-set->list answers)
|
||||
(rr-set->list authorities)
|
||||
(rr-set->list additional)))
|
||||
(struct question-state (zone q client-sock nameservers-tried retry-count) #:transparent)
|
||||
(struct expanding-cnames (q accumulator remaining-count) #:transparent)
|
||||
|
||||
(define (resolver-actions qr)
|
||||
(match qr
|
||||
[(resolver-network-query q zone-origin addresses k) ;; need subquestion answered
|
||||
;;(write `(INTERMEDIATE ,q ,ns-rr (,(length addresses) addresses))) (newline)
|
||||
(network-query/addresses client-sock q zone-origin addresses
|
||||
(lambda (rrs) (resolver-actions (k rrs))))]
|
||||
[#f ;; got a name-error/NXDOMAIN from some nameserver
|
||||
;; TODO: re-examine my reasoning for not sending name-error/NXDOMAIN here
|
||||
(send-message (dns-reply (make-reply (set) (set) (set)) request-sink request-source))]
|
||||
[(question-result _ _ anss auths adds)
|
||||
(send-message (dns-reply (make-reply anss auths adds) request-sink request-source))]))
|
||||
(define (question-handler zone q client-sock)
|
||||
(os-big-bang/transition
|
||||
(retry-question (question-state zone q client-sock (set) 0))))
|
||||
|
||||
(if (eq? question #f)
|
||||
(os-big-bang 'no-questions-no-processing-no-answers)
|
||||
(os-big-bang '???
|
||||
(resolver-actions
|
||||
(resolve-from-zone question
|
||||
zone
|
||||
#f ;; no SOA, since we're not authoritative for anything
|
||||
#t ;; we *are* however recursive.
|
||||
(set) ;; haven't tried any nameservers yet
|
||||
values)))))
|
||||
(define (send-empty-reply w q)
|
||||
(transition w (send-message (answered-question q (empty-complete-answer)))))
|
||||
|
||||
(define (retry-question w)
|
||||
(match w
|
||||
[(question-state _ q _ _ 20) ;; TODO: is this a sensible limit?
|
||||
;; Too many retries, i.e. too many referrals.
|
||||
(send-empty-reply w q)]
|
||||
[(question-state zone q client-sock nameservers-tried old-retry-count)
|
||||
;; Credit remaining. Try once more (perhaps for the first time, in fact).
|
||||
(match (resolve-from-zone q zone #f nameservers-tried)
|
||||
[#f ;; We're not authoritative so this is just a signal that we can't answer usefully
|
||||
(send-empty-reply w q)]
|
||||
[(referral zone-origin nameserver-rrs _)
|
||||
(define referral-id (gensym 'referral))
|
||||
(transition w
|
||||
(spawn (network-query client-sock
|
||||
q
|
||||
zone-origin
|
||||
(map rr-rdata (set->list nameserver-rrs))
|
||||
referral-id))
|
||||
(subscribe referral-id
|
||||
(message-handlers w
|
||||
[(network-reply (== referral-id) #f) ;; name-error/NXDOMAIN
|
||||
(transition w (send-message (answered-question q #f)))]
|
||||
[(network-reply (== referral-id) ans)
|
||||
(extend-transition
|
||||
(retry-question (struct-copy question-state w
|
||||
[nameservers-tried (set-union nameservers-tried
|
||||
nameserver-rrs)]
|
||||
[zone (incorporate-complete-answer ans zone)]
|
||||
[retry-count (+ old-retry-count 1)]))
|
||||
(unsubscribe referral-id))])))]
|
||||
[(? complete-answer? ans)
|
||||
(transition w (send-message (answered-question q ans)))]
|
||||
[(partial-answer base cnames)
|
||||
(transition (expanding-cnames q base (length cnames))
|
||||
(map (lambda (cname)
|
||||
(define subscription-id (list 'cname-expander cname))
|
||||
(define cname-q (question cname (question-type q) (question-class q)))
|
||||
(list (send-message cname-q)
|
||||
(subscribe subscription-id
|
||||
(message-handlers (expanding-cnames q acc remaining)
|
||||
[(answered-question (== cname-q) ans)
|
||||
(define new-acc (if ans (merge-answers acc ans) acc))
|
||||
(define new-remaining (- remaining 1))
|
||||
(define new-w (expanding-cnames q new-acc new-remaining))
|
||||
(transition new-w
|
||||
(unsubscribe subscription-id)
|
||||
(if (positive? new-remaining)
|
||||
(send-message (answered-question q new-acc))
|
||||
'()))]))))
|
||||
cnames))])]))
|
||||
|
||||
(require "test-rrs.rkt")
|
||||
(start-proxy 5555 test-roots)
|
||||
(start-proxy (test-port-number) test-roots)
|
||||
|
|
|
|||
|
|
@ -1,57 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
;; Noddy representation of a zone, and various zone and RRSet utilities.
|
||||
|
||||
(require racket/unit)
|
||||
(require racket/pretty)
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require "api.rkt")
|
||||
(require "codec.rkt")
|
||||
(require "zonedb.rkt")
|
||||
(require "network-query.rkt")
|
||||
(require "resolver.rkt")
|
||||
(require "test-rrs.rkt")
|
||||
|
||||
;; (require racket/trace)
|
||||
;; (trace ;;resolve-from-zone
|
||||
;; ;;build-referral
|
||||
;; ;;incorporate-claims
|
||||
;; ;;additional-section/a
|
||||
;; ;;network-query
|
||||
;; ;;network-query/addresses
|
||||
;; ;;dns-message->claims
|
||||
;; ;;negative-network-query-result
|
||||
;; ;;closest-untried-nameservers
|
||||
;; ;;answer-from-zone
|
||||
;; ;;merge-replies
|
||||
;; ;;in-bailiwick?
|
||||
;; )
|
||||
|
||||
(define (drive-resolver qr)
|
||||
(match qr
|
||||
[(resolver-network-query q zone-origin addresses k)
|
||||
(write `(INTERMEDIATE ,q ,zone-origin (,(length addresses) addresses))) (newline)
|
||||
(network-query/addresses 'foo q zone-origin addresses
|
||||
(lambda (rrs) (drive-resolver (k rrs))))]
|
||||
[_ 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)))
|
||||
test-roots
|
||||
)
|
||||
#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))
|
||||
187
resolver.rkt
187
resolver.rkt
|
|
@ -9,21 +9,11 @@
|
|||
(require "codec.rkt")
|
||||
(require "zonedb.rkt")
|
||||
|
||||
(provide (struct-out resolver-network-query)
|
||||
(provide (struct-out partial-answer)
|
||||
(struct-out referral)
|
||||
|
||||
resolve-from-zone)
|
||||
|
||||
;; A ResolverResult is one of
|
||||
;; -- a QuestionResult, a complete answer to the issued question, or
|
||||
;; -- a ResolverNetworkQuery, a subquestion that must be answered
|
||||
;; before resolution can continue.
|
||||
|
||||
;; A ResolverContinuation is a (Maybe<CompiledZone> -> ResolverResult).
|
||||
|
||||
;; A ResolverNetworkQuery is a (resolver-network-query Question
|
||||
;; DomainName ListOf<IPv4> ResolverContinuation), representing a
|
||||
;; subquestion that must be answered before resolution can continue.
|
||||
(struct resolver-network-query (q zone-origin addresses k) #:transparent)
|
||||
|
||||
;; Rules:
|
||||
;;
|
||||
;; - If the DB already has an answer, return it.
|
||||
|
|
@ -51,54 +41,42 @@
|
|||
;;
|
||||
;; - See RFC 1035 section 7.1.
|
||||
|
||||
;; QuestionResult Maybe<QuestionResult> -> QuestionResult
|
||||
;; Add the supporting facts from r2 into r1, keeping r1's
|
||||
;; question. Replaces the knowledge from r1 with the knowledge from
|
||||
;; r2. Suitable for use when r2 is answering some sub-question of
|
||||
;; r1's question.
|
||||
(define (merge-replies r1 r2)
|
||||
(match r2
|
||||
[#f r1]
|
||||
[(question-result _ k2 n2 u2 d2) ;; a normal result
|
||||
(match-define (question-result q1 k1 n1 u1 d1) r1)
|
||||
(question-result q1
|
||||
k2
|
||||
(set-union n1 n2)
|
||||
(set-union u1 u2)
|
||||
(set-union d1 d2))]))
|
||||
;; An Answer is one of
|
||||
;; -- a PartialAnswer (some CNAMEs need expanding),
|
||||
;; -- a CompleteAnswer (a complete answer ready to send),
|
||||
;; -- #f (the domain name does not exist in the CompiledZone given),
|
||||
;; -- a Referral (a referral to some other nameserver).
|
||||
|
||||
(define (answer-from-zone q zone start-of-authority recursion-desired? ks kf)
|
||||
;; A PartialAnswer is a (partial-answer CompleteAnswer ListOf<DomainName>)
|
||||
;; A collection of relevant RRs together with some CNAMEs that need expanding.
|
||||
(struct partial-answer (base cnames) #:transparent)
|
||||
|
||||
;; A Referral is a (referral DomainName Set<RR> Set<RR>)
|
||||
(struct referral (zone-origin nameserver-rrs additional) #:transparent)
|
||||
|
||||
;; An answer of #f here does NOT indicate a missing domain-name
|
||||
;; (name-error/NXDOMAIN), but instead indicates that there are no
|
||||
;; records matching the query in the database given. It's up to the
|
||||
;; caller to decide what to do about that.
|
||||
(define (answer-from-zone q zone start-of-authority)
|
||||
(match-define (question name qtype qclass) q)
|
||||
(define rrset (hash-ref zone name set))
|
||||
(define filtered-rrs (filter-rrs rrset qtype qclass))
|
||||
(define cnames (filter-by-type rrset 'cname)) ;; TODO: filter by class too??
|
||||
(define base-reply (question-result q
|
||||
zone
|
||||
(set-union cnames filtered-rrs)
|
||||
(if (and start-of-authority
|
||||
(in-bailiwick? name (rr-name start-of-authority)))
|
||||
(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.
|
||||
(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)
|
||||
(question-result-knowledge reply) ;; best knowledge yet
|
||||
start-of-authority
|
||||
recursion-desired?
|
||||
(set)
|
||||
(lambda (qr) (loop (cdr cnames) (merge-replies reply qr)))))))
|
||||
(k base-reply)))
|
||||
(define answer-set (set-union cnames filtered-rrs))
|
||||
(define base (complete-answer answer-set
|
||||
(if (and start-of-authority
|
||||
(in-bailiwick? name (rr-name start-of-authority)))
|
||||
(set start-of-authority)
|
||||
(set))
|
||||
(set)))
|
||||
(cond
|
||||
[(set-empty? answer-set) ;; No matching records or domain absent (deliberately ambiguous)
|
||||
#f]
|
||||
[(or (eq? qtype 'cname) (set-empty? cnames)) ;; Either asking for CNAMEs, or no CNAMEs to expand
|
||||
base]
|
||||
[else ;; Kick off the algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a
|
||||
(partial-answer base (set-map cnames rr-rdata))]))
|
||||
|
||||
(define (closest-nameservers name zone)
|
||||
(let search ((name name))
|
||||
|
|
@ -125,56 +103,15 @@
|
|||
(set-subtract ns-rrset nameservers-tried))
|
||||
|
||||
(define (empty-answer q zone start-of-authority)
|
||||
(if (and start-of-authority
|
||||
(in-bailiwick? (question-name q) (rr-name start-of-authority)))
|
||||
;; NXDOMAIN/name-error if the question is something we're qualified to answer
|
||||
(if (and start-of-authority ;; we are authoritative for something
|
||||
(in-bailiwick? (question-name q) (rr-name start-of-authority)) ;; for this in particular
|
||||
(not (hash-has-key? zone (question-name q)))) ;; and there are no RRs at all for this q
|
||||
;; NXDOMAIN/name-error: we definitely know there are no RRs at all for this q.
|
||||
#f
|
||||
;; A normal no-answers packet otherwise.
|
||||
(question-result q
|
||||
zone
|
||||
(set)
|
||||
(set)
|
||||
(set))))
|
||||
(empty-complete-answer)))
|
||||
|
||||
(define (group-rrs-with-known-address ns-set zone)
|
||||
(partition (lambda (rr)
|
||||
(not (set-empty? (filter-by-type (hash-ref zone (rr-rdata rr) set) 'a))))
|
||||
(set->list ns-set)))
|
||||
|
||||
(define (resolve-nameservers ns-set zone k)
|
||||
(define-values (addressable-rrs non-addressable-rrs) (group-rrs-with-known-address ns-set zone))
|
||||
(define resort-to-recursion? (null? addressable-rrs))
|
||||
;; ^ only recurse if we know absolutely *none* of the addresses of
|
||||
;; the nameservers we've been asked to resolve.
|
||||
(define chosen-ns-rrs (if (null? addressable-rrs) non-addressable-rrs addressable-rrs))
|
||||
(define zone-origin (rr-name (car chosen-ns-rrs)))
|
||||
;; ^ Bailiwick of the nameservers. Any element of ns-set will do,
|
||||
;; since they all have the same rr-name by operation of
|
||||
;; closest-untried-nameservers.
|
||||
(let loop ((nss chosen-ns-rrs)
|
||||
(nameserver-ips (set))
|
||||
(zone zone))
|
||||
(if (null? nss)
|
||||
(k (map rr-rdata (set->list nameserver-ips)) zone zone-origin (list->set chosen-ns-rrs))
|
||||
(let ((ns-rr (car nss)))
|
||||
(define ns-name (rr-rdata ns-rr)) ;; name of this server
|
||||
(define (accumulate-ips ips zone) (loop (cdr nss) (set-union ips nameserver-ips) zone))
|
||||
;;(write `(loop ,resort-to-recursion? ,ns-name ,zone-origin ,(length nss) ,(set-count nameserver-ips))) (newline)
|
||||
(resolve-from-zone (question ns-name 'a 'in) ;; TODO: 'aaaa ?
|
||||
zone
|
||||
#f ;; we are not ourselves authoritative in this context
|
||||
resort-to-recursion?
|
||||
(set)
|
||||
(lambda (qr)
|
||||
(match qr
|
||||
[#f
|
||||
;; Got an NXDOMAIN while searching for the nameserver's address.
|
||||
(accumulate-ips (set) zone)]
|
||||
[(question-result _ enhanced-zone answers _ _)
|
||||
;; Got a (possibly-empty) set of answers.
|
||||
(accumulate-ips (filter-by-type answers 'a) enhanced-zone)])))))))
|
||||
|
||||
;; additional-section/a : CompiledZone ListOf<DomainName>
|
||||
;; additional-section/a : CompiledZone ListOf<DomainName> -> Set<RR>
|
||||
;; Implements the "additional section" rules from RFC 1035 (and the
|
||||
;; rules for IPv6 from RFC 3596). Provides A and AAAA records for
|
||||
;; names mentioned in the "names" list that have entries in "zone".
|
||||
|
|
@ -189,38 +126,12 @@
|
|||
(set)
|
||||
names))
|
||||
|
||||
;; build-referral : Question CompiledZone RR 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 zone start-of-authority ns-rrset)
|
||||
(question-result q
|
||||
zone
|
||||
ns-rrset
|
||||
(if start-of-authority (set start-of-authority) (set))
|
||||
(additional-section/a zone (set-map ns-rrset rr-rdata))))
|
||||
|
||||
;; TODO: simplify external API here, supplying such as (set) for
|
||||
;; nameservers-tried and values for k.
|
||||
(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 (set-empty? best-nameservers)
|
||||
(k (empty-answer q zone start-of-authority))
|
||||
(if recursion-desired?
|
||||
(resolve-nameservers best-nameservers zone
|
||||
(lambda (nameserver-ips zone zone-origin chosen-nameservers)
|
||||
(resolver-network-query q zone-origin nameserver-ips
|
||||
(lambda (new-rrs)
|
||||
(if (eq? new-rrs #f)
|
||||
;; name-error received!
|
||||
(k #f)
|
||||
;; we presumably learned something that might help us
|
||||
(resolve-from-zone q
|
||||
(incorporate-rr-set new-rrs zone)
|
||||
start-of-authority
|
||||
recursion-desired?
|
||||
(set-union nameservers-tried chosen-nameservers)
|
||||
k))))))
|
||||
(k (build-referral q zone start-of-authority best-nameservers))))))))
|
||||
(define (resolve-from-zone q zone start-of-authority nameservers-tried)
|
||||
(or (answer-from-zone q zone start-of-authority)
|
||||
(let ((best-nameservers (closest-untried-nameservers q zone nameservers-tried)))
|
||||
(if (set-empty? best-nameservers)
|
||||
(empty-answer q zone start-of-authority)
|
||||
(let ((zone-origin (rr-name (car (set->list best-nameservers))))) ;; any entry will do
|
||||
(referral zone-origin
|
||||
best-nameservers
|
||||
(additional-section/a zone (set-map best-nameservers rr-rdata))))))))
|
||||
|
|
|
|||
|
|
@ -117,19 +117,35 @@
|
|||
;;
|
||||
;; 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) values)
|
||||
[#f
|
||||
(make-reply (question-name q)
|
||||
#t
|
||||
(set)
|
||||
(set)
|
||||
(set))]
|
||||
[(question-result _ _ answers authorities additional)
|
||||
(make-reply (question-name q)
|
||||
#f
|
||||
answers
|
||||
authorities
|
||||
additional)]))
|
||||
(match-define (question qname qtype qclass) q)
|
||||
|
||||
(define (expand-cnames worklist ans)
|
||||
(match worklist
|
||||
['()
|
||||
(match-define (complete-answer ns us ds) ans)
|
||||
(make-reply qname #f ns us ds)]
|
||||
[(cons next-cname rest)
|
||||
(define a (resolve-from-zone (question next-cname qtype qclass) zone soa-rr (set)))
|
||||
(incorporate-answer a rest ans)]))
|
||||
|
||||
(define (incorporate-answer this-answer worklist ans)
|
||||
(match this-answer
|
||||
[(partial-answer new-info more-cnames)
|
||||
(expand-cnames (append worklist more-cnames)
|
||||
(merge-answers new-info ans))]
|
||||
[(? complete-answer?)
|
||||
(expand-cnames worklist
|
||||
(merge-answers this-answer ans))]
|
||||
[_ ;; #f or a referral
|
||||
(expand-cnames worklist ans)]))
|
||||
|
||||
(match (resolve-from-zone q zone soa-rr (set))
|
||||
[#f ;; Signal name-error/NXDOMAIN
|
||||
(make-reply qname #t (set) (set) (set))]
|
||||
[(referral _ ns-rrs additional)
|
||||
(make-reply qname #f ns-rrs (set soa-rr) additional)]
|
||||
[this-answer
|
||||
(incorporate-answer this-answer '() (empty-complete-answer))]))
|
||||
|
||||
;; TODO: check opcode and direction in request
|
||||
;; TODO: think again about multiple questions in one packet
|
||||
|
|
@ -138,4 +154,4 @@
|
|||
(first-only (dns-message-questions request-message))))
|
||||
|
||||
(require "test-rrs.rkt")
|
||||
(start-server 5555 test-soa-rr test-rrs)
|
||||
(start-server (test-port-number) test-soa-rr test-rrs)
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
(require "api.rkt")
|
||||
|
||||
(provide test-soa-rr test-rrs test-roots)
|
||||
(provide test-soa-rr test-rrs test-roots test-port-number)
|
||||
|
||||
(define test-soa-rr
|
||||
(rr '(#"example") 'soa 'in 30
|
||||
|
|
@ -36,3 +36,8 @@
|
|||
(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))))
|
||||
|
||||
(define (test-port-number)
|
||||
(string->number
|
||||
(or (getenv "DNSPORT")
|
||||
(error 'test-port-number "Please set your DNSPORT environment variable."))))
|
||||
|
|
|
|||
17
zonedb.rkt
17
zonedb.rkt
|
|
@ -8,7 +8,8 @@
|
|||
(require "codec.rkt")
|
||||
|
||||
(provide incorporate-rr
|
||||
incorporate-rr-set
|
||||
incorporate-complete-answer
|
||||
empty-zone-db
|
||||
compile-zone-db
|
||||
compiled-zone?
|
||||
in-bailiwick?
|
||||
|
|
@ -28,9 +29,17 @@
|
|||
(define (incorporate-rr rr db)
|
||||
(hash-set db (rr-name rr) (set-add (hash-ref db (rr-name rr) set) rr)))
|
||||
|
||||
;; Set<RR> Hash -> Hash
|
||||
(define (incorporate-rr-set rrs db)
|
||||
(foldl incorporate-rr db (set->list rrs)))
|
||||
;; Maybe<CompleteAnswer> Hash -> Hash
|
||||
(define (incorporate-complete-answer ans db)
|
||||
(match ans
|
||||
[#f db]
|
||||
[(complete-answer ns us ds) (foldl incorporate-rr db (append (set->list ns)
|
||||
(set->list us)
|
||||
(set->list ds)))]))
|
||||
|
||||
;; empty-zone-db : -> CompiledZone
|
||||
(define (empty-zone-db)
|
||||
(make-immutable-hash))
|
||||
|
||||
;; compile-zone-db : ListOf<RR> -> CompiledZone
|
||||
;; Builds an immutable hash table from the given RRs, suitable for
|
||||
|
|
|
|||
Loading…
Reference in New Issue