diff --git a/driver.rkt b/driver.rkt index 4bac855..5c9b420 100644 --- a/driver.rkt +++ b/driver.rkt @@ -77,7 +77,7 @@ (dns-message (dns-message-id request-message) 'response 'query - (if (in-bailiwick? name soa-rr) 'authoritative 'non-authoritative) + (if (in-bailiwick? name (rr-name soa-rr)) 'authoritative 'non-authoritative) 'not-truncated (dns-message-recursion-desired request-message) 'no-recursion-available diff --git a/network-query.rkt b/network-query.rkt index 61f2154..b42da85 100644 --- a/network-query.rkt +++ b/network-query.rkt @@ -89,21 +89,22 @@ '())) ;; incorporate-dns-reply : -;; DNSMessage CompiledZone RR +;; DNSMessage CompiledZone 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 `ns-rr`. 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 ns-rr) +;; `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) (case (dns-message-response-code message) [(no-error) (foldl (lambda (claim-rr zone) - (if (in-bailiwick? (rr-name claim-rr) ns-rr) + (if (in-bailiwick? (rr-name claim-rr) zone-origin) (incorporate-rr claim-rr zone) zone)) zone @@ -114,7 +115,7 @@ [else 'no-answer])) ;; network-query/addresses : -;; UdpAddress Question CompiledZone RR ListOf +;; UdpAddress Question CompiledZone DomainName ListOf ;; (Maybe -> ListOf) -> ListOf ;; ;; Repeatedly uses `network-query/addresses/timeout` to try asking the @@ -122,9 +123,9 @@ ;; `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 ns-rr server-ips k) +(define (network-query/addresses s q zone zone-origin server-ips k) (let try-with-timeout ((timeout first-timeout)) - (network-query/addresses/timeout s q zone ns-rr server-ips timeout + (network-query/addresses/timeout s q zone zone-origin server-ips timeout (lambda (result) (if (eq? result 'no-answer) (let ((new-timeout (next-timeout timeout))) @@ -134,7 +135,7 @@ (k result)))))) ;; network-query/addresses/timeout : -;; UdpAddress Question CompiledZone RR ListOf Seconds +;; UdpAddress Question CompiledZone DomainName ListOf Seconds ;; ((or Maybe 'no-answer) -> ListOf) -> ListOf ;; ;; Sends the question to each of the servers whose addresses are given @@ -142,19 +143,19 @@ ;; 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 ns-rr server-ips timeout k) +(define (network-query/addresses/timeout s q zone 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 ns-rr (car remaining-ips) timeout + (network-query/address/timeout s q zone 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 RR IPv4 Seconds +;; UdpAddress Question CompiledZone DomainName IPv4 Seconds ;; ((or Maybe 'no-answer) -> ListOf) -> ListOf ;; ;; Sends the question to the server address `server-ip` given. Waits @@ -163,7 +164,7 @@ ;; 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 ns-rr server-ip timeout k) +(define (network-query/address/timeout s q zone 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)) @@ -174,16 +175,16 @@ (list (send-message req) (send-message (set-timer subscription-id (* timeout 1000) #t)) (subscribe subscription-id - (message-handlers w - [(timer-expired (== subscription-id) _) - (write `(Timed out ,q to ,ns-rr 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? - (if (not (= (dns-message-id reply-message) (dns-message-id query))) - w - (transition w - (unsubscribe subscription-id) - (k (incorporate-dns-reply reply-message zone ns-rr))))])))) + (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? + (if (not (= (dns-message-id reply-message) (dns-message-id query))) + w + (transition w + (unsubscribe subscription-id) + (k (incorporate-dns-reply reply-message zone zone-origin))))])))) diff --git a/proxy.rkt b/proxy.rkt index 987149a..8adf928 100644 --- a/proxy.rkt +++ b/proxy.rkt @@ -113,9 +113,9 @@ (define (resolver-actions qr) (match qr - [(resolver-network-query q zone ns-rr addresses k) ;; need subquestion answered + [(resolver-network-query q zone zone-origin addresses k) ;; need subquestion answered ;;(write `(INTERMEDIATE ,q ,ns-rr (,(length addresses) addresses))) (newline) - (network-query/addresses client-sock q zone ns-rr addresses + (network-query/addresses client-sock q zone zone-origin addresses (lambda (qr) (resolver-actions (k qr))))] [#f ;; got a name-error/NXDOMAIN from some nameserver ;; TODO: re-examine my reasoning for not sending name-error/NXDOMAIN here diff --git a/resolver-test.rkt b/resolver-test.rkt index e8dee0d..112709b 100644 --- a/resolver-test.rkt +++ b/resolver-test.rkt @@ -30,9 +30,9 @@ (define (drive-resolver qr) (match qr - [(resolver-network-query q zone ns-rr addresses k) - (write `(INTERMEDIATE ,q ,ns-rr (,(length addresses) addresses))) (newline) - (network-query/addresses 'foo q zone ns-rr addresses + [(resolver-network-query q zone 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))))] [_ qr])) diff --git a/resolver.rkt b/resolver.rkt index b06512a..82786c2 100644 --- a/resolver.rkt +++ b/resolver.rkt @@ -4,6 +4,7 @@ (require racket/set) (require racket/match) +(require racket/list) (require "api.rkt") (require "codec.rkt") (require "zonedb.rkt") @@ -19,10 +20,10 @@ ;; A ResolverContinuation is a (Maybe -> ResolverResult). ;; A ResolverNetworkQuery is a (resolver-network-query Question -;; CompiledZone RR ListOf ResolverContinuation), +;; CompiledZone DomainName ListOf ResolverContinuation), ;; representing a subquestion that must be answered before resolution ;; can continue. -(struct resolver-network-query (q zone ns-rr addresses k) #:transparent) +(struct resolver-network-query (q zone zone-origin addresses k) #:transparent) ;; Rules: ;; @@ -76,7 +77,7 @@ zone (set-union cnames filtered-rrs) (if (and start-of-authority - (in-bailiwick? name start-of-authority)) + (in-bailiwick? name (rr-name start-of-authority))) (set start-of-authority) (set)) (set))) @@ -118,28 +119,15 @@ ;; Remove a label and keep looking. (search (cdr name)))))) -;; Returns a list of NS RRs in some priority order: records for which -;; we know the associated A record are listed before records for which -;; we don't. +;; Returns a set of NS RRs in an arbitrary order. (define (closest-untried-nameservers q zone nameservers-tried) (define name (question-name q)) (define ns-rrset (closest-nameservers name zone)) - (let loop ((untried (set->list (set-subtract ns-rrset nameservers-tried))) - (with-address '()) - (without-address '())) - (if (null? untried) - (append with-address without-address) - (let ((ns-rr (car untried))) - (define rrs (hash-ref zone (rr-rdata ns-rr) (set))) - (define a-rrs (filter-by-type rrs 'a)) - (define has-address? (not (set-empty? a-rrs))) - (loop (cdr untried) - (if has-address? (cons ns-rr with-address) with-address) - (if has-address? without-address (cons ns-rr without-address))))))) + (set-subtract ns-rrset nameservers-tried)) (define (empty-answer q zone start-of-authority) (if (and start-of-authority - (in-bailiwick? (question-name q) 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 #f ;; A normal no-answers packet otherwise. @@ -149,31 +137,43 @@ (set) (set)))) -(define (random-element a-nonempty-list) - (car a-nonempty-list)) +(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 (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 - (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))])))) +(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 ;; Implements the "additional section" rules from RFC 1035 (and the @@ -186,7 +186,7 @@ (set-union section (set-filter (lambda (rr) (and (memv (rr-type rr) '(a aaaa)) (eqv? (rr-class rr) 'in))) - (hash-ref zone name)))) + (hash-ref zone name set)))) (set) names)) @@ -207,20 +207,21 @@ k (lambda () (let ((best-nameservers (closest-untried-nameservers q zone nameservers-tried))) - (if (null? best-nameservers) + (if (set-empty? best-nameservers) (k (empty-answer q zone start-of-authority)) (if recursion-desired? - (let ((best-nameserver (random-element best-nameservers))) - (network-query q zone best-nameserver - (lambda (enhanced-zone) - (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))))))))) + (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) + ;; 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-union nameservers-tried chosen-nameservers) + k)))))) + (k (build-referral q zone start-of-authority best-nameservers)))))))) diff --git a/simplified-driver.rkt b/simplified-driver.rkt index 14a3216..83b88b7 100644 --- a/simplified-driver.rkt +++ b/simplified-driver.rkt @@ -92,7 +92,7 @@ (dns-message (dns-message-id request-message) 'response 'query - (if (in-bailiwick? name soa-rr) 'authoritative 'non-authoritative) + (if (in-bailiwick? name (rr-name soa-rr)) 'authoritative 'non-authoritative) 'not-truncated (dns-message-recursion-desired request-message) 'no-recursion-available diff --git a/zonedb.rkt b/zonedb.rkt index 8ad3419..2f6ef15 100644 --- a/zonedb.rkt +++ b/zonedb.rkt @@ -36,14 +36,14 @@ (define (compiled-zone? z) (hash? z)) ;; hm -;; in-bailiwick? : DomainName RR -> Boolean +;; in-bailiwick? : DomainName DomainName -> Boolean ;; Answers #t iff dn falls within the bailiwick of the zone with -;; origin rr. -(define (in-bailiwick? dn rr) +;; origin o. +(define (in-bailiwick? dn o) (cond - ((equal? dn (rr-name rr)) #t) + ((equal? dn o) #t) ((null? dn) #f) - (else (in-bailiwick? (cdr dn) rr)))) + (else (in-bailiwick? (cdr dn) o)))) ;; set-filter : (X -> Boolean) SetOf -> SetOf ;; Retains only those elements of its argument for which the predicate