Try the nameservers we have addresses for before looking up any more nameserver addresses.
This commit is contained in:
Tony Garnock-Jones
parent
7217768b9a
commit
d1ad3d7086
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -89,21 +89,22 @@
|
|||
'()))
|
||||
|
||||
;; incorporate-dns-reply :
|
||||
;; DNSMessage CompiledZone RR<NS>
|
||||
;; DNSMessage CompiledZone DomainName
|
||||
;; -> (or Maybe<CompiledZone> '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<NS> ListOf<IPv4>
|
||||
;; UdpAddress Question CompiledZone DomainName ListOf<IPv4>
|
||||
;; (Maybe<CompiledZone> -> ListOf<Action>) -> ListOf<Action>
|
||||
;;
|
||||
;; 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<NS> ListOf<IPv4> Seconds
|
||||
;; UdpAddress Question CompiledZone DomainName ListOf<IPv4> Seconds
|
||||
;; ((or Maybe<CompiledZone> 'no-answer) -> ListOf<Action>) -> ListOf<Action>
|
||||
;;
|
||||
;; 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<NS> IPv4 Seconds
|
||||
;; UdpAddress Question CompiledZone DomainName IPv4 Seconds
|
||||
;; ((or Maybe<CompiledZone> 'no-answer) -> ListOf<Action>) -> ListOf<Action>
|
||||
;;
|
||||
;; 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))))]))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]))
|
||||
|
||||
|
|
|
|||
119
resolver.rkt
119
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<CompiledZone> -> ResolverResult).
|
||||
|
||||
;; A ResolverNetworkQuery is a (resolver-network-query Question
|
||||
;; CompiledZone RR<NS> ListOf<IPv4> ResolverContinuation),
|
||||
;; CompiledZone DomainName ListOf<IPv4> 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<DomainName>
|
||||
;; 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))))))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
10
zonedb.rkt
10
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<X> -> SetOf<X>
|
||||
;; Retains only those elements of its argument for which the predicate
|
||||
|
|
|
|||
Loading…
Reference in New Issue