First pass at TRifying network-query.rkt
This commit is contained in:
Tony Garnock-Jones
parent
bdafaa6199
commit
1b2e842a15
|
|
@ -1,14 +1,15 @@
|
|||
#lang racket/base
|
||||
#lang typed/racket/base
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require "api.rkt")
|
||||
(require "codec.rkt")
|
||||
(require "zonedb.rkt")
|
||||
(require racket-typed-matrix/sugar-untyped)
|
||||
(require racket-typed-matrix/drivers/udp-untyped)
|
||||
(require racket-typed-matrix/drivers/timer-untyped)
|
||||
(require racket-typed-matrix/sugar-typed)
|
||||
(require racket-typed-matrix/drivers/udp)
|
||||
(require racket-typed-matrix/drivers/timer)
|
||||
(require "tk-dns.rkt")
|
||||
(require (rename-in racket-typed-matrix/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149
|
||||
|
||||
(provide network-query
|
||||
(struct-out network-reply))
|
||||
|
|
@ -103,45 +104,44 @@
|
|||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
;; A NetworkQueryResult is a ListOf<Action>, some actions to take:
|
||||
;; either involved in or resulting from completion of the network
|
||||
;; query.
|
||||
|
||||
(define first-timeout 3) ;; seconds
|
||||
|
||||
;; A NetworkRequest is a (network-request UdpAddress Question
|
||||
;; DomainName NEListOf<DomainName> UniqueID) representing the
|
||||
;; parameters used to start and process a network query.
|
||||
(struct network-request (client-socket
|
||||
question
|
||||
zone-origin
|
||||
server-names
|
||||
unique-id)
|
||||
#:prefab)
|
||||
(struct: network-request ([client-socket : UdpAddress]
|
||||
[question : Question]
|
||||
[zone-origin : DomainName]
|
||||
[server-names : (Listof DomainName)]
|
||||
[unique-id : Any])
|
||||
#:prefab)
|
||||
(define-type NetworkRequest network-request)
|
||||
|
||||
;; A NetworkReply is a (network-reply UniqueID Maybe<CompleteAnswer>)
|
||||
;; representing the final result of a network query.
|
||||
(struct network-reply (unique-id answer) #:prefab)
|
||||
(struct: network-reply ([unique-id : Any] [answer : (Option CompleteAnswer)]) #:prefab)
|
||||
|
||||
;; A NetworkQueryState is a (network-query-state NetworkRequest
|
||||
;; Integer Map<DomainName,ListOf<UdpAddress>> ListOf<UdpAddress>
|
||||
;; Maybe<DomainName> ListOf<DomainName>), representing an in-progress
|
||||
;; DNS network query.
|
||||
(struct network-query-state (request
|
||||
timeout
|
||||
known-addresses
|
||||
remaining-addresses
|
||||
current-name
|
||||
remaining-names)
|
||||
#:prefab)
|
||||
(struct: network-query-state ([request : NetworkRequest]
|
||||
[timeout : (Option Natural)]
|
||||
[known-addresses : (HashTable DomainName (Listof UdpAddress))]
|
||||
[remaining-addresses : (Listof UdpAddress)]
|
||||
[current-name : (Option DomainName)]
|
||||
[remaining-names : (Listof DomainName)])
|
||||
#:prefab)
|
||||
(define-type NetworkQueryState network-query-state)
|
||||
|
||||
;; seconds -> Maybe<seconds>
|
||||
(: next-timeout : Natural -> (Option Natural))
|
||||
(define (next-timeout timeout)
|
||||
(case timeout
|
||||
((3) 11)
|
||||
((11) 45)
|
||||
((45) #f)))
|
||||
(cond
|
||||
[(equal? timeout 3) 11]
|
||||
[(equal? timeout 11) 45]
|
||||
[else #f]))
|
||||
|
||||
(: make-dns-query-message : Question Nonnegative-Integer -> DNSMessage)
|
||||
(define (make-dns-query-message q query-id)
|
||||
(dns-message query-id
|
||||
'request
|
||||
|
|
@ -156,9 +156,9 @@
|
|||
'()
|
||||
'()))
|
||||
|
||||
;; filter-dns-reply : Question DNSMessage DomainName
|
||||
;; -> (or Maybe<CompleteAnswer> 'bad-answer 'lame-delegation)
|
||||
;;
|
||||
(define-type CheckedAnswer (U (Option CompleteAnswer) 'bad-answer 'lame-delegation))
|
||||
|
||||
(: filter-dns-reply : Question DNSMessage DomainName -> CheckedAnswer)
|
||||
;; 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
|
||||
|
|
@ -173,20 +173,22 @@
|
|||
(define (filter-dns-reply q message zone-origin)
|
||||
(case (dns-message-response-code message)
|
||||
[(no-error)
|
||||
(: f : (Listof RR) -> (Setof RR))
|
||||
(define (f l)
|
||||
(list->set (filter (lambda (claim-rr) (in-bailiwick? (rr-name claim-rr) zone-origin)) l)))
|
||||
(list->set (filter (lambda: ([claim-rr : RR])
|
||||
(in-bailiwick? (rr-name claim-rr) zone-origin)) l)))
|
||||
;; Here's where we do the "lame referral" check. This code is
|
||||
;; nice and simple (though wrong) without it. Ho hum.
|
||||
(define answers (f (dns-message-answers message)))
|
||||
(define unfiltered-authorities (dns-message-authorities message))
|
||||
(define non-subzone-ns-rrs ;; all NS authorities not for a STRICT subzone of our zone-origin
|
||||
(filter (lambda (rr) (and (eqv? (rr-type rr) 'ns)
|
||||
(or (equal? (rr-name rr) zone-origin)
|
||||
(not (in-bailiwick? (rr-name rr) zone-origin)))))
|
||||
(filter (lambda: ([rr : RR]) (and (eqv? (rdata-type (rr-rdata rr)) 'ns)
|
||||
(or (equal? (rr-name rr) zone-origin)
|
||||
(not (in-bailiwick? (rr-name rr) zone-origin)))))
|
||||
unfiltered-authorities))
|
||||
(define authorities (f unfiltered-authorities))
|
||||
(define answers-to-q ;; answers specifically to the question we asked
|
||||
(set-filter (lambda (rr) (equal? (rr-name rr) (question-name q))) answers))
|
||||
(set-filter (lambda: ([rr : RR]) (equal? (rr-name rr) (question-name q))) answers))
|
||||
(define lame?
|
||||
(and (set-empty? (filter-by-type answers-to-q 'cname))
|
||||
(set-empty? (filter-rrs answers-to-q (question-type q) (question-class q)))
|
||||
|
|
@ -204,79 +206,87 @@
|
|||
(dns-message-questions message)))
|
||||
'bad-answer]))
|
||||
|
||||
;; IPv4 -> String
|
||||
(: ip->host-name : 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))
|
||||
|
||||
(: make-dns-address : IPv4 -> UdpAddress)
|
||||
(define (make-dns-address ip-address)
|
||||
(udp-remote-address (ip->host-name ip-address) 53))
|
||||
|
||||
;; network-query : UdpAddress Question DomainName NEListOf<DomainName> UniqueId -> Spawn
|
||||
(: network-query : (All (ParentState)
|
||||
UdpAddress Question DomainName (Listof DomainName) Any ->
|
||||
(Action ParentState)))
|
||||
(define (network-query s q zone-origin server-names unique-id)
|
||||
(spawn #:debug-name (list 'network-query q)
|
||||
#:child
|
||||
(try-next-server (network-query-state (network-request s q zone-origin server-names unique-id)
|
||||
first-timeout
|
||||
(hash)
|
||||
'()
|
||||
#f
|
||||
server-names))))
|
||||
(spawn: #:debug-name (list 'network-query q)
|
||||
#:parent : ParentState
|
||||
#:child : NetworkQueryState
|
||||
(try-next-server
|
||||
(network-query-state (network-request s q zone-origin server-names unique-id)
|
||||
first-timeout
|
||||
(ann #hash() (HashTable DomainName (Listof UdpAddress)))
|
||||
'()
|
||||
#f
|
||||
server-names))))
|
||||
|
||||
(: try-next-server : NetworkQueryState -> (Transition NetworkQueryState))
|
||||
(define (try-next-server w)
|
||||
(match w
|
||||
[(network-query-state _ #f _ _ _ _)
|
||||
;; No more timeouts to try, so give up.
|
||||
(on-answer w (empty-complete-answer) #f)]
|
||||
[(network-query-state req timeout _ '() _ '())
|
||||
;; No more addresses to try with this timeout. Refill the list
|
||||
;; and bump the timeout and retry.
|
||||
;; TODO: randomize ordering of servers in list. (Don't forget the initial fill.)
|
||||
(try-next-server (struct-copy network-query-state w
|
||||
[timeout (next-timeout timeout)]
|
||||
[remaining-addresses '()]
|
||||
[current-name #f]
|
||||
[remaining-names (network-request-server-names req)]))]
|
||||
[(network-query-state req _ known-addresses '() _ (cons current-name remaining-names))
|
||||
(if (hash-has-key? known-addresses current-name)
|
||||
(define timeout (network-query-state-timeout w))
|
||||
(if (not timeout)
|
||||
;; No more timeouts to try, so give up.
|
||||
(on-answer w (empty-complete-answer) #f)
|
||||
(match w
|
||||
[(network-query-state req _ _ '() _ '())
|
||||
;; No more addresses to try with this timeout. Refill the list
|
||||
;; and bump the timeout and retry.
|
||||
;; TODO: randomize ordering of servers in list. (Don't forget the initial fill.)
|
||||
(try-next-server (struct-copy network-query-state w
|
||||
[remaining-addresses (hash-ref known-addresses
|
||||
current-name)]
|
||||
[current-name current-name]
|
||||
[remaining-names remaining-names]))
|
||||
(let ((subq (ns-question current-name (network-request-question req))))
|
||||
(transition (struct-copy network-query-state w
|
||||
[current-name current-name]
|
||||
[remaining-names remaining-names])
|
||||
(send-message subq)
|
||||
(endpoint #:subscriber (answered-question subq (wild))
|
||||
#:let-name subq-id
|
||||
#:state w
|
||||
[(answered-question (== subq) ans)
|
||||
(let ((ips (map make-dns-address
|
||||
(set->list (extract-addresses current-name ans)))))
|
||||
(sequence-actions
|
||||
(try-next-server (struct-copy network-query-state w
|
||||
[known-addresses (hash-set known-addresses
|
||||
current-name
|
||||
ips)]
|
||||
[remaining-addresses ips]))
|
||||
(delete-endpoint subq-id)))]))))]
|
||||
[(network-query-state req timeout _ (cons current-ip remaining-ips) _ _)
|
||||
(define rpc-id (gensym 'network-query/allocate-query-id))
|
||||
(transition w
|
||||
(send-message `(request ,rpc-id allocate-query-id))
|
||||
(endpoint #:subscriber `(reply ,rpc-id ,(wild))
|
||||
#:name rpc-id
|
||||
#:state w
|
||||
[`(reply ,(== rpc-id) ,id)
|
||||
(sequence-actions (send-request (struct-copy network-query-state w
|
||||
[remaining-addresses remaining-ips])
|
||||
id
|
||||
timeout
|
||||
current-ip)
|
||||
(delete-endpoint rpc-id))]))]))
|
||||
[timeout (next-timeout timeout)]
|
||||
[remaining-addresses '()]
|
||||
[current-name #f]
|
||||
[remaining-names (network-request-server-names req)]))]
|
||||
[(network-query-state req _ known-addresses '() _ (cons current-name remaining-names))
|
||||
(if (hash-has-key? known-addresses current-name)
|
||||
(try-next-server (struct-copy network-query-state w
|
||||
[remaining-addresses (hash-ref known-addresses current-name)]
|
||||
[current-name current-name]
|
||||
[remaining-names remaining-names]))
|
||||
(let ((subq (ns-question current-name (network-request-question req))))
|
||||
(transition: (struct-copy network-query-state w
|
||||
[current-name current-name]
|
||||
[remaining-names remaining-names]) : NetworkQueryState
|
||||
(send-message subq)
|
||||
(endpoint: w : NetworkQueryState
|
||||
#:subscriber (answered-question subq (wild))
|
||||
#:let-name subq-id
|
||||
[(answered-question (== subq) ans)
|
||||
(let ((ips (map make-dns-address
|
||||
(set->list (extract-addresses current-name ans)))))
|
||||
(sequence-actions
|
||||
(try-next-server (struct-copy network-query-state w
|
||||
[known-addresses (hash-set known-addresses
|
||||
current-name
|
||||
ips)]
|
||||
[remaining-addresses ips]))
|
||||
(delete-endpoint subq-id)))]))))]
|
||||
[(network-query-state req _ _ (cons current-ip remaining-ips) _ _)
|
||||
(define rpc-id (gensym 'network-query/allocate-query-id))
|
||||
(transition: w : NetworkQueryState
|
||||
(send-message `(request ,rpc-id allocate-query-id))
|
||||
(endpoint: w : NetworkQueryState
|
||||
#:subscriber `(reply ,rpc-id ,(wild))
|
||||
#:name rpc-id
|
||||
[`(reply ,(== rpc-id) ,(? exact-nonnegative-integer? id))
|
||||
(sequence-actions (send-request (struct-copy network-query-state w
|
||||
[remaining-addresses remaining-ips])
|
||||
id
|
||||
timeout
|
||||
current-ip)
|
||||
(delete-endpoint rpc-id))]))])))
|
||||
|
||||
(: on-answer : NetworkQueryState CheckedAnswer (Option UdpAddress)
|
||||
-> (Transition NetworkQueryState))
|
||||
(define (on-answer w ans server-ip)
|
||||
(match ans
|
||||
['bad-answer ;; can come from filter-dns-reply
|
||||
|
|
@ -289,17 +299,22 @@
|
|||
server-ip
|
||||
zone-origin
|
||||
q))
|
||||
;; Actually remove the offending IP address so it's never tried again.
|
||||
(try-next-server (struct-copy network-query-state w
|
||||
[known-addresses (hash-update known-addresses
|
||||
current-name
|
||||
(lambda (addrs)
|
||||
(remove server-ip addrs)))]))]
|
||||
[else
|
||||
(transition w
|
||||
(try-next-server (if (and current-name server-ip)
|
||||
;; Actually remove the offending IP address so it's never tried again.
|
||||
(struct-copy network-query-state w
|
||||
[known-addresses (hash-update known-addresses
|
||||
current-name
|
||||
(lambda: ([addrs : (Listof
|
||||
UdpAddress)])
|
||||
(remove server-ip addrs)))])
|
||||
w))]
|
||||
[(? complete-answer? ans)
|
||||
(transition: w : NetworkQueryState
|
||||
(send-message (network-reply (network-request-unique-id (network-query-state-request w))
|
||||
ans)))]))
|
||||
|
||||
(: send-request : NetworkQueryState Nonnegative-Integer Natural UdpAddress
|
||||
-> (Transition NetworkQueryState))
|
||||
(define (send-request w query-id timeout server-ip)
|
||||
(match-define (network-request s q zone-origin _ _) (network-query-state-request w))
|
||||
(define query (make-dns-query-message q query-id))
|
||||
|
|
@ -310,13 +325,13 @@
|
|||
q query-id
|
||||
zone-origin server-ip
|
||||
timeout))
|
||||
(transition w
|
||||
(transition: w : NetworkQueryState
|
||||
(send-message (dns-request query s server-ip))
|
||||
(send-message (set-timer timeout-id (* timeout 1000) 'relative))
|
||||
;; TODO: Restore this to a "join" when proper pattern-unions are implemented
|
||||
(endpoint #:subscriber (timer-expired timeout-id (wild))
|
||||
#:name timeout-id
|
||||
#:state w
|
||||
(endpoint: w : NetworkQueryState
|
||||
#:subscriber (timer-expired timeout-id (wild))
|
||||
#:name timeout-id
|
||||
[(timer-expired (== timeout-id) _)
|
||||
(begin
|
||||
(log-debug (format "Timed out ~v ~v to ~v ~v after ~v seconds"
|
||||
|
|
@ -327,9 +342,9 @@
|
|||
(delete-endpoint timeout-id)
|
||||
(delete-endpoint reply-wait-id)
|
||||
(send-message (list 'release-query-id query-id))))])
|
||||
(endpoint #:subscriber (dns-reply (wild) (wild) s)
|
||||
#:name reply-wait-id
|
||||
#:state w
|
||||
(endpoint: w : NetworkQueryState
|
||||
#:subscriber (dns-reply (wild) (wild) s)
|
||||
#:name reply-wait-id
|
||||
[(dns-reply reply-message source (== s))
|
||||
;; TODO: maybe receive only specifically from the queried IP address?
|
||||
(begin
|
||||
|
|
@ -342,7 +357,7 @@
|
|||
(dns-message-authorities reply-message)
|
||||
(dns-message-additional reply-message)))
|
||||
(if (not (= (dns-message-id reply-message) (dns-message-id query)))
|
||||
(transition w)
|
||||
(transition: w : NetworkQueryState)
|
||||
(sequence-actions (on-answer w
|
||||
(filter-dns-reply q reply-message zone-origin)
|
||||
server-ip)
|
||||
|
|
|
|||
Loading…
Reference in New Issue