Make network-query no longer directly aware of CompiledZones.
This commit is contained in:
Tony Garnock-Jones
parent
6cde0922d9
commit
e6568d49b5
|
|
@ -1,7 +1,7 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require racket/udp)
|
||||
(require "api.rkt")
|
||||
(require "codec.rkt")
|
||||
(require "zonedb.rkt")
|
||||
|
|
@ -88,83 +88,76 @@
|
|||
'()
|
||||
'()))
|
||||
|
||||
;; incorporate-dns-reply :
|
||||
;; DNSMessage CompiledZone DomainName
|
||||
;; -> (or Maybe<CompiledZone> 'no-answer)
|
||||
;; filter-dns-reply : DNSMessage DomainName -> (or Maybe<Set<RR>> 'no-answer)
|
||||
;;
|
||||
;; Incorporates RRs from the answer, authorities, and additional
|
||||
;; sections of the passed-in `message` to the passed-in `zone`,
|
||||
;; returning the augmented zone. RRs are only incorporated if their
|
||||
;; `rr-name` falls in the bailiwick of the given `zone-origin`. All of
|
||||
;; this only happens if the passed-in message's
|
||||
;; `dns-message-response-code` is `'no-error`: if it's `'name-error`,
|
||||
;; then `#f` is returned, and if it's any other code, `'no-answer` is
|
||||
;; returned.
|
||||
(define (incorporate-dns-reply message zone zone-origin)
|
||||
;; Filters RRs from the answer, authorities, and additional sections
|
||||
;; of the passed-in `message`, returning the set of RRs surviving the
|
||||
;; filter. RRs are only accepted if their `rr-name` falls in the
|
||||
;; bailiwick of the given `zone-origin`. All of this only happens if
|
||||
;; the passed-in message's `dns-message-response-code` is `'no-error`:
|
||||
;; if it's `'name-error`, then `#f` is returned, and if it's any other
|
||||
;; code, `'no-answer` is returned.
|
||||
(define (filter-dns-reply message zone-origin)
|
||||
(case (dns-message-response-code message)
|
||||
[(no-error)
|
||||
(foldl (lambda (claim-rr zone)
|
||||
(if (in-bailiwick? (rr-name claim-rr) zone-origin)
|
||||
(incorporate-rr claim-rr zone)
|
||||
zone))
|
||||
zone
|
||||
(append (dns-message-answers message)
|
||||
(dns-message-authorities message)
|
||||
(dns-message-additional message)))]
|
||||
(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))))]
|
||||
[(name-error) #f]
|
||||
[else 'no-answer]))
|
||||
|
||||
;; network-query/addresses :
|
||||
;; UdpAddress Question CompiledZone DomainName ListOf<IPv4>
|
||||
;; (Maybe<CompiledZone> -> ListOf<Action>) -> ListOf<Action>
|
||||
;; 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 zone-origin server-ips k)
|
||||
(define (network-query/addresses s q zone-origin server-ips k)
|
||||
(let try-with-timeout ((timeout first-timeout))
|
||||
(network-query/addresses/timeout s q zone zone-origin server-ips timeout
|
||||
(network-query/addresses/timeout s q zone-origin server-ips timeout
|
||||
(lambda (result)
|
||||
(if (eq? result 'no-answer)
|
||||
(let ((new-timeout (next-timeout timeout)))
|
||||
(if new-timeout
|
||||
(try-with-timeout new-timeout)
|
||||
(k zone)))
|
||||
(k (set))))
|
||||
(k result))))))
|
||||
|
||||
;; network-query/addresses/timeout :
|
||||
;; UdpAddress Question CompiledZone DomainName ListOf<IPv4> Seconds
|
||||
;; ((or Maybe<CompiledZone> 'no-answer) -> ListOf<Action>) -> ListOf<Action>
|
||||
;; 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 zone-origin server-ips timeout k)
|
||||
(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 zone-origin (car remaining-ips) timeout
|
||||
(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)))))))
|
||||
|
||||
;; network-query/address/timeout :
|
||||
;; UdpAddress Question CompiledZone DomainName IPv4 Seconds
|
||||
;; ((or Maybe<CompiledZone> 'no-answer) -> ListOf<Action>) -> ListOf<Action>
|
||||
;; 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 incorporated
|
||||
;; into the passed-in `zone` (using `incorporate-dns-reply`), 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
|
||||
;; `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 zone-origin server-ip timeout k)
|
||||
(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))
|
||||
|
|
@ -191,4 +184,4 @@
|
|||
w
|
||||
(transition w
|
||||
(unsubscribe subscription-id)
|
||||
(k (incorporate-dns-reply reply-message zone zone-origin))))]))))
|
||||
(k (filter-dns-reply reply-message zone-origin))))]))))
|
||||
|
|
|
|||
|
|
@ -113,10 +113,10 @@
|
|||
|
||||
(define (resolver-actions qr)
|
||||
(match qr
|
||||
[(resolver-network-query q zone zone-origin addresses k) ;; need subquestion answered
|
||||
[(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 zone-origin addresses
|
||||
(lambda (qr) (resolver-actions (k qr))))]
|
||||
(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))]
|
||||
|
|
|
|||
|
|
@ -30,10 +30,10 @@
|
|||
|
||||
(define (drive-resolver qr)
|
||||
(match qr
|
||||
[(resolver-network-query q zone zone-origin addresses k)
|
||||
[(resolver-network-query q zone-origin addresses k)
|
||||
(write `(INTERMEDIATE ,q ,zone-origin (,(length addresses) addresses))) (newline)
|
||||
(network-query/addresses 'foo q zone zone-origin addresses
|
||||
(lambda (qr) (drive-resolver (k qr))))]
|
||||
(network-query/addresses 'foo q zone-origin addresses
|
||||
(lambda (rrs) (drive-resolver (k rrs))))]
|
||||
[_ qr]))
|
||||
|
||||
(define (run-question name qtype)
|
||||
|
|
|
|||
15
resolver.rkt
15
resolver.rkt
|
|
@ -20,10 +20,9 @@
|
|||
;; A ResolverContinuation is a (Maybe<CompiledZone> -> ResolverResult).
|
||||
|
||||
;; A ResolverNetworkQuery is a (resolver-network-query Question
|
||||
;; CompiledZone DomainName ListOf<IPv4> ResolverContinuation),
|
||||
;; representing a subquestion that must be answered before resolution
|
||||
;; can continue.
|
||||
(struct resolver-network-query (q zone zone-origin addresses k) #:transparent)
|
||||
;; 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:
|
||||
;;
|
||||
|
|
@ -212,14 +211,14 @@
|
|||
(if recursion-desired?
|
||||
(resolve-nameservers best-nameservers zone
|
||||
(lambda (nameserver-ips zone zone-origin chosen-nameservers)
|
||||
(resolver-network-query q zone zone-origin nameserver-ips
|
||||
(lambda (enhanced-zone)
|
||||
(if (eq? enhanced-zone #f)
|
||||
(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
|
||||
enhanced-zone
|
||||
(incorporate-rr-set new-rrs zone)
|
||||
start-of-authority
|
||||
recursion-desired?
|
||||
(set-union nameservers-tried chosen-nameservers)
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
(require "codec.rkt")
|
||||
|
||||
(provide incorporate-rr
|
||||
incorporate-rr-set
|
||||
compile-zone-db
|
||||
compiled-zone?
|
||||
in-bailiwick?
|
||||
|
|
@ -25,7 +26,11 @@
|
|||
|
||||
;; RR Hash -> Hash
|
||||
(define (incorporate-rr rr db)
|
||||
(hash-set db (rr-name rr) (set-add (hash-ref db (rr-name rr) (set)) rr)))
|
||||
(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)))
|
||||
|
||||
;; compile-zone-db : ListOf<RR> -> CompiledZone
|
||||
;; Builds an immutable hash table from the given RRs, suitable for
|
||||
|
|
|
|||
Loading…
Reference in New Issue