From 1b2e842a15280d5b4dd3413f3adb1a6a716d5298 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 19 Mar 2013 22:42:42 -0400 Subject: [PATCH] First pass at TRifying network-query.rkt --- network-query.rkt | 239 ++++++++++++++++++++++++---------------------- 1 file changed, 127 insertions(+), 112 deletions(-) diff --git a/network-query.rkt b/network-query.rkt index 5df1d21..7a8ea64 100644 --- a/network-query.rkt +++ b/network-query.rkt @@ -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, 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 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) ;; 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> ListOf ;; Maybe ListOf), 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 +(: 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 '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 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)