From e6568d49b5d0491ce3e2b3154a811a6eba51c698 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 31 Jan 2012 08:11:31 -0500 Subject: [PATCH] Make network-query no longer directly aware of CompiledZones. --- network-query.rkt | 69 +++++++++++++++++++++-------------------------- proxy.rkt | 6 ++--- resolver-test.rkt | 6 ++--- resolver.rkt | 15 +++++------ zonedb.rkt | 7 ++++- 5 files changed, 50 insertions(+), 53 deletions(-) diff --git a/network-query.rkt b/network-query.rkt index fc14111..566f567 100644 --- a/network-query.rkt +++ b/network-query.rkt @@ -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 'no-answer) +;; filter-dns-reply : DNSMessage DomainName -> (or Maybe> '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 -;; (Maybe -> ListOf) -> ListOf +;; UdpAddress Question DomainName ListOf +;; (Maybe> -> ListOf) -> ListOf ;; ;; 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 Seconds -;; ((or Maybe 'no-answer) -> ListOf) -> ListOf +;; UdpAddress Question DomainName ListOf Seconds +;; ((or Maybe> 'no-answer) -> ListOf) -> ListOf ;; ;; 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 'no-answer) -> ListOf) -> ListOf +;; UdpAddress Question DomainName IPv4 Seconds +;; ((or Maybe> 'no-answer) -> ListOf) -> ListOf ;; ;; 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))))])))) diff --git a/proxy.rkt b/proxy.rkt index 8adf928..636312b 100644 --- a/proxy.rkt +++ b/proxy.rkt @@ -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))] diff --git a/resolver-test.rkt b/resolver-test.rkt index 112709b..6f27f83 100644 --- a/resolver-test.rkt +++ b/resolver-test.rkt @@ -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) diff --git a/resolver.rkt b/resolver.rkt index b3e8be1..5156327 100644 --- a/resolver.rkt +++ b/resolver.rkt @@ -20,10 +20,9 @@ ;; A ResolverContinuation is a (Maybe -> ResolverResult). ;; A ResolverNetworkQuery is a (resolver-network-query Question -;; CompiledZone DomainName ListOf 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 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) diff --git a/zonedb.rkt b/zonedb.rkt index 2f6ef15..a84ce39 100644 --- a/zonedb.rkt +++ b/zonedb.rkt @@ -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 Hash -> Hash +(define (incorporate-rr-set rrs db) + (foldl incorporate-rr db (set->list rrs))) ;; compile-zone-db : ListOf -> CompiledZone ;; Builds an immutable hash table from the given RRs, suitable for