Split resolver algorithm from network-query implementation
This commit is contained in:
parent
171aea110c
commit
ba92bbb1ff
|
@ -0,0 +1,3 @@
|
||||||
|
#lang racket/signature
|
||||||
|
|
||||||
|
network-query/addresses ;; Question CompiledZone NS-RR ListOf<IPv4> -> Maybe<CompiledZone>
|
|
@ -0,0 +1,137 @@
|
||||||
|
#lang racket/unit
|
||||||
|
|
||||||
|
(require racket/pretty)
|
||||||
|
|
||||||
|
(require racket/match)
|
||||||
|
(require "api.rkt")
|
||||||
|
(require "codec.rkt")
|
||||||
|
(require "zonedb.rkt")
|
||||||
|
(require "udp-operations-sig.rkt")
|
||||||
|
(require "network-query-sig.rkt")
|
||||||
|
|
||||||
|
(import udp-operations^)
|
||||||
|
(export network-query^)
|
||||||
|
|
||||||
|
(define first-timeout 3) ;; seconds
|
||||||
|
|
||||||
|
;; seconds -> Maybe<seconds>
|
||||||
|
(define (next-timeout timeout)
|
||||||
|
(case timeout
|
||||||
|
((3) 11)
|
||||||
|
((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-network-query-packet q)
|
||||||
|
(dns-message->packet
|
||||||
|
(dns-message (random 65536)
|
||||||
|
'request
|
||||||
|
'query
|
||||||
|
'non-authoritative
|
||||||
|
'not-truncated
|
||||||
|
'no-recursion-desired
|
||||||
|
'no-recursion-available
|
||||||
|
'no-error
|
||||||
|
(list q)
|
||||||
|
'()
|
||||||
|
'()
|
||||||
|
'())))
|
||||||
|
|
||||||
|
;; incorporate-dns-reply :
|
||||||
|
;; DNSMessage CompiledZone RR<NS> ( -> Maybe<CompiledZone> )
|
||||||
|
;; -> Maybe<CompiledZone>
|
||||||
|
;;
|
||||||
|
;; 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,the `keep-trying` thunk is invoked. (If the
|
||||||
|
;; caller is `network-query/addresses`, then `keep-trying` will try
|
||||||
|
;; other servers from the list of IPs available.)
|
||||||
|
(define (incorporate-dns-reply message zone ns-rr keep-trying)
|
||||||
|
(case (dns-message-response-code message)
|
||||||
|
[(no-error)
|
||||||
|
(foldl (lambda (claim-rr zone)
|
||||||
|
(if (in-bailiwick? (rr-name claim-rr) ns-rr)
|
||||||
|
(incorporate-rr claim-rr zone)
|
||||||
|
zone))
|
||||||
|
zone
|
||||||
|
(append (dns-message-answers message)
|
||||||
|
(dns-message-authorities message)
|
||||||
|
(dns-message-additional message)))]
|
||||||
|
[(name-error) #f]
|
||||||
|
[else (keep-trying)]))
|
||||||
|
|
||||||
|
;; network-query/addresses :
|
||||||
|
;; Question CompiledZone RR<NS> ListOf<IPv4> -> Maybe<CompiledZone>
|
||||||
|
;;
|
||||||
|
;; 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 q zone ns-rr server-ips)
|
||||||
|
(let ((s (udp-open-socket #f #f)))
|
||||||
|
(let try-with-timeout ((timeout first-timeout))
|
||||||
|
(match (network-query/addresses/timeout s q zone ns-rr server-ips timeout)
|
||||||
|
['no-answer
|
||||||
|
(define new-timeout (next-timeout timeout))
|
||||||
|
(if new-timeout
|
||||||
|
(try-with-timeout new-timeout)
|
||||||
|
zone)]
|
||||||
|
[result result]))))
|
||||||
|
|
||||||
|
;; network-query/addresses/timeout :
|
||||||
|
;; UdpSocket Question CompiledZone RR<NS> ListOf<IPv4> Seconds
|
||||||
|
;; -> (or Maybe<CompiledZone> 'no-answer)
|
||||||
|
;;
|
||||||
|
;; 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 ns-rr server-ips timeout)
|
||||||
|
;; TODO: randomize ordering of servers in list.
|
||||||
|
(let search ((remaining-ips server-ips))
|
||||||
|
(if (null? remaining-ips)
|
||||||
|
'no-answer
|
||||||
|
(match (network-query/address/timeout s q zone ns-rr (car remaining-ips) timeout)
|
||||||
|
['no-answer (search (cdr remaining-ips))]
|
||||||
|
[result result]))))
|
||||||
|
|
||||||
|
;; network-query/address/timeout :
|
||||||
|
;; UdpSocket Question CompiledZone RR<NS> IPv4 Seconds
|
||||||
|
;; -> (or Maybe<CompiledZone> 'no-answer)
|
||||||
|
;;
|
||||||
|
;; 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
|
||||||
|
;; server, `'no-answer` is returned to the caller.
|
||||||
|
(define (network-query/address/timeout s q zone ns-rr server-ip timeout)
|
||||||
|
(define server-host-name (ip->host-name server-ip))
|
||||||
|
(define server-port 53)
|
||||||
|
(write `(querying ,server-host-name ,server-port with timeout ,timeout)) (newline)
|
||||||
|
(udp-send-to s server-host-name server-port (make-network-query-packet q))
|
||||||
|
(define buffer (make-bytes 512)) ;; maximum DNS reply length
|
||||||
|
(define result (udp-receive/timeout s buffer timeout))
|
||||||
|
;; TODO: correlate query-ID
|
||||||
|
;; TODO: maybe receive only specifically from the queried IP address?
|
||||||
|
(if result
|
||||||
|
(let* ((reply-length (car result))
|
||||||
|
(packet (subbytes buffer 0 reply-length))
|
||||||
|
(reply-message (packet->dns-message packet)))
|
||||||
|
(pretty-print `(response ,result ,reply-message))
|
||||||
|
(incorporate-dns-reply reply-message
|
||||||
|
zone
|
||||||
|
ns-rr
|
||||||
|
(lambda () 'no-answer)))
|
||||||
|
'no-answer))
|
||||||
|
|
|
@ -1,4 +1,3 @@
|
||||||
#lang racket/signature
|
#lang racket/signature
|
||||||
|
|
||||||
network-query ;; Question CompiledZone NS-RR -> CompiledZone
|
|
||||||
resolve-from-zone ;; Question CompiledZone SOA-RR Boolean Set<NS-RR> -> QuestionResult
|
resolve-from-zone ;; Question CompiledZone SOA-RR Boolean Set<NS-RR> -> QuestionResult
|
||||||
|
|
|
@ -10,9 +10,11 @@
|
||||||
(require "codec.rkt")
|
(require "codec.rkt")
|
||||||
(require "zonedb.rkt")
|
(require "zonedb.rkt")
|
||||||
(require "ground-udp-operations-unit.rkt")
|
(require "ground-udp-operations-unit.rkt")
|
||||||
|
(require "network-query-unit.rkt")
|
||||||
(require "resolver-unit.rkt")
|
(require "resolver-unit.rkt")
|
||||||
|
|
||||||
(define-values/invoke-unit/infer (link resolver@ ground-udp-operations@))
|
(define-values/invoke-unit/infer
|
||||||
|
(link resolver@ network-query@ ground-udp-operations@))
|
||||||
|
|
||||||
;; (require racket/trace)
|
;; (require racket/trace)
|
||||||
;; (trace ;;resolve-from-zone
|
;; (trace ;;resolve-from-zone
|
||||||
|
|
|
@ -7,10 +7,10 @@
|
||||||
(require "api.rkt")
|
(require "api.rkt")
|
||||||
(require "codec.rkt")
|
(require "codec.rkt")
|
||||||
(require "zonedb.rkt")
|
(require "zonedb.rkt")
|
||||||
(require "udp-operations-sig.rkt")
|
(require "network-query-sig.rkt")
|
||||||
(require "resolver-sig.rkt")
|
(require "resolver-sig.rkt")
|
||||||
|
|
||||||
(import udp-operations^)
|
(import network-query^)
|
||||||
(export resolver^)
|
(export resolver^)
|
||||||
|
|
||||||
(define (answer-available? q zone)
|
(define (answer-available? q zone)
|
||||||
|
@ -111,132 +111,6 @@
|
||||||
(define (random-element a-nonempty-list)
|
(define (random-element a-nonempty-list)
|
||||||
(car a-nonempty-list))
|
(car a-nonempty-list))
|
||||||
|
|
||||||
(define first-timeout 3) ;; seconds
|
|
||||||
|
|
||||||
;; seconds -> Maybe<seconds>
|
|
||||||
(define (next-timeout timeout)
|
|
||||||
(case timeout
|
|
||||||
((3) 11)
|
|
||||||
((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 (negative-network-query-result zone)
|
|
||||||
zone)
|
|
||||||
|
|
||||||
(define (make-network-query-packet q)
|
|
||||||
(dns-message->packet
|
|
||||||
(dns-message (random 65536)
|
|
||||||
'request
|
|
||||||
'query
|
|
||||||
'non-authoritative
|
|
||||||
'not-truncated
|
|
||||||
'no-recursion-desired
|
|
||||||
'no-recursion-available
|
|
||||||
'no-error
|
|
||||||
(list q)
|
|
||||||
'()
|
|
||||||
'()
|
|
||||||
'())))
|
|
||||||
|
|
||||||
;; incorporate-dns-reply :
|
|
||||||
;; DNSMessage CompiledZone RR<NS> ( -> Maybe<CompiledZone> )
|
|
||||||
;; -> Maybe<CompiledZone>
|
|
||||||
;;
|
|
||||||
;; 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,the `keep-trying` thunk is invoked. (If the
|
|
||||||
;; caller is `network-query/addresses`, then `keep-trying` will try
|
|
||||||
;; other servers from the list of IPs available.)
|
|
||||||
(define (incorporate-dns-reply message zone ns-rr keep-trying)
|
|
||||||
(case (dns-message-response-code message)
|
|
||||||
[(no-error)
|
|
||||||
(foldl (lambda (claim-rr zone)
|
|
||||||
(if (in-bailiwick? (rr-name claim-rr) ns-rr)
|
|
||||||
(incorporate-rr claim-rr zone)
|
|
||||||
zone))
|
|
||||||
zone
|
|
||||||
(append (dns-message-answers message)
|
|
||||||
(dns-message-authorities message)
|
|
||||||
(dns-message-additional message)))]
|
|
||||||
[(name-error) #f]
|
|
||||||
[else (keep-trying)]))
|
|
||||||
|
|
||||||
;; network-query/addresses :
|
|
||||||
;; Question CompiledZone RR<NS> ListOf<IPv4> -> Maybe<CompiledZone>
|
|
||||||
;;
|
|
||||||
;; 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 q zone ns-rr server-ips)
|
|
||||||
(let ((s (udp-open-socket #f #f)))
|
|
||||||
(let try-with-timeout ((timeout first-timeout))
|
|
||||||
(match (network-query/addresses/timeout s q zone ns-rr server-ips timeout)
|
|
||||||
['no-answer
|
|
||||||
(define new-timeout (next-timeout timeout))
|
|
||||||
(if new-timeout
|
|
||||||
(try-with-timeout new-timeout)
|
|
||||||
(negative-network-query-result zone))]
|
|
||||||
[result result]))))
|
|
||||||
|
|
||||||
;; network-query/addresses/timeout :
|
|
||||||
;; UdpSocket Question CompiledZone RR<NS> ListOf<IPv4> Seconds
|
|
||||||
;; -> (or Maybe<CompiledZone> 'no-answer)
|
|
||||||
;;
|
|
||||||
;; 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 ns-rr server-ips timeout)
|
|
||||||
;; TODO: randomize ordering of servers in list.
|
|
||||||
(let search ((remaining-ips server-ips))
|
|
||||||
(if (null? remaining-ips)
|
|
||||||
'no-answer
|
|
||||||
(match (network-query/address/timeout s q zone ns-rr (car remaining-ips) timeout)
|
|
||||||
['no-answer (search (cdr remaining-ips))]
|
|
||||||
[result result]))))
|
|
||||||
|
|
||||||
;; network-query/address/timeout :
|
|
||||||
;; UdpSocket Question CompiledZone RR<NS> IPv4 Seconds
|
|
||||||
;; -> (or Maybe<CompiledZone> 'no-answer)
|
|
||||||
;;
|
|
||||||
;; 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
|
|
||||||
;; server, `'no-answer` is returned to the caller.
|
|
||||||
(define (network-query/address/timeout s q zone ns-rr server-ip timeout)
|
|
||||||
(define server-host-name (ip->host-name server-ip))
|
|
||||||
(define server-port 53)
|
|
||||||
(write `(querying ,server-host-name ,server-port with timeout ,timeout)) (newline)
|
|
||||||
(udp-send-to s server-host-name server-port (make-network-query-packet q))
|
|
||||||
(define buffer (make-bytes 512)) ;; maximum DNS reply length
|
|
||||||
(define result (udp-receive/timeout s buffer timeout))
|
|
||||||
;; TODO: correlate query-ID
|
|
||||||
;; TODO: maybe receive only specifically from the queried IP address?
|
|
||||||
(if result
|
|
||||||
(let* ((reply-length (car result))
|
|
||||||
(packet (subbytes buffer 0 reply-length))
|
|
||||||
(reply-message (packet->dns-message packet)))
|
|
||||||
(pretty-print `(response ,result ,reply-message))
|
|
||||||
(incorporate-dns-reply reply-message
|
|
||||||
zone
|
|
||||||
ns-rr
|
|
||||||
(lambda () 'no-answer)))
|
|
||||||
'no-answer))
|
|
||||||
|
|
||||||
(define (network-query q zone ns-rr)
|
(define (network-query q zone ns-rr)
|
||||||
(define ns-name (rr-rdata ns-rr))
|
(define ns-name (rr-rdata ns-rr))
|
||||||
;; ^ the rr-name is the subzone origin; the rr-rdata is the
|
;; ^ the rr-name is the subzone origin; the rr-rdata is the
|
||||||
|
@ -246,11 +120,11 @@
|
||||||
#f
|
#f
|
||||||
#t
|
#t
|
||||||
(set))
|
(set))
|
||||||
[#f (negative-network-query-result zone)] ;; Can't find the address of the nameserver!
|
[#f zone] ;; Can't find the address of the nameserver!
|
||||||
[(question-result _ enhanced-zone answers _ _)
|
[(question-result _ enhanced-zone answers _ _)
|
||||||
(define address-rrs (filter-by-type answers 'a))
|
(define address-rrs (filter-by-type answers 'a))
|
||||||
(if (set-empty? address-rrs)
|
(if (set-empty? address-rrs)
|
||||||
(negative-network-query-result zone) ;; Again, no addresses for the nameserver!
|
zone ;; Again, no addresses for the nameserver!
|
||||||
(network-query/addresses q
|
(network-query/addresses q
|
||||||
enhanced-zone
|
enhanced-zone
|
||||||
ns-rr
|
ns-rr
|
||||||
|
|
|
@ -11,11 +11,13 @@
|
||||||
(require "codec.rkt")
|
(require "codec.rkt")
|
||||||
(require "zonedb.rkt")
|
(require "zonedb.rkt")
|
||||||
(require "ground-udp-operations-unit.rkt")
|
(require "ground-udp-operations-unit.rkt")
|
||||||
|
(require "network-query-unit.rkt")
|
||||||
(require "resolver-unit.rkt")
|
(require "resolver-unit.rkt")
|
||||||
(require "dump-bytes.rkt")
|
(require "dump-bytes.rkt")
|
||||||
(require "simple-udp-service.rkt")
|
(require "simple-udp-service.rkt")
|
||||||
|
|
||||||
(define-values/invoke-unit/infer (link resolver@ ground-udp-operations@))
|
(define-values/invoke-unit/infer
|
||||||
|
(link resolver@ network-query@ ground-udp-operations@))
|
||||||
|
|
||||||
;; Instantiated with a SOA record for the zone it is serving as well
|
;; Instantiated with a SOA record for the zone it is serving as well
|
||||||
;; as a zone's worth of DNS data which is used to answer queries
|
;; as a zone's worth of DNS data which is used to answer queries
|
||||||
|
|
Loading…
Reference in New Issue