syndicate-lang
/
racket-dns-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Only look up nameserver names as far as necessary

This commit is contained in:
Tony Garnock-Jones 2012-02-06 14:10:40 -05:00
parent 4b7c931527
commit 1203d9a18c
1 changed files with 50 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

94
network-query.rkt
View File

@ -71,12 +71,12 @@
(define first-timeout 3) ;; seconds
;; A NetworkRequest is a (network-request UdpAddress Question
;; DomainName NEListOf<UdpAddress> UniqueID) representing the
;; DomainName NEListOf<DomainName> UniqueID) representing the
;; parameters used to start and process a network query.
(struct network-request (client-socket
question
zone-origin
server-ips
server-names
unique-id)
#:transparent)
@ -85,19 +85,15 @@
(struct network-reply (unique-id answer) #:transparent)
;; A NetworkQueryState is a (network-query-state NetworkRequest
;; Integer ListOf<UdpAddress>), representing an in-progress DNS
;; network query.
;; Integer Map<DomainName,ListOf<UdpAddress>> ListOf<UdpAddress>
;; ListOf<DomainName>), representing an in-progress DNS network query.
(struct network-query-state (request
timeout
remaining-addresses)
known-addresses
remaining-addresses
remaining-names)
#:transparent)
;; A ResolvingNameservers is a (resolving-nameservers NetworkRequest
;; Integer), representing an in-progress nameserver resolution
;; operation that must be completed before the actual query can
;; continue.
(struct resolving-nameservers (request remaining-count) #:transparent)
;; seconds -> Maybe<seconds>
(define (next-timeout timeout)
(case timeout
@ -149,50 +145,60 @@
;; network-query : UdpAddress Question DomainName NEListOf<DomainName> UniqueId -> OsProcess
(define (network-query s q zone-origin server-names unique-id)
(os-big-bang (resolving-nameservers (network-request s q zone-origin '() unique-id)
(length server-names))
(map (lambda (nameserver-name)
(define subscription-id (list 'nameserver-name-resolution nameserver-name))
(define subq (question nameserver-name 'a 'in)) ;; TODO: 'aaaa ?
(list (send-message subq)
(subscribe subscription-id
(message-handlers (resolving-nameservers req remaining)
[(answered-question (== subq) ans)
(define new-ips
(append (network-request-server-ips req)
(map make-dns-address
(set->list (extract-addresses nameserver-name ans)))))
(define new-req (struct-copy network-request req [server-ips new-ips]))
(define new-remaining (- remaining 1))
(extend-transition
(if (zero? new-remaining)
(try-next-server (network-query-state new-req
first-timeout
new-ips))
(transition (resolving-nameservers new-req new-remaining)))
(unsubscribe subscription-id))]))))
server-names)))
(os-big-bang/transition
(try-next-server (network-query-state (network-request s q zone-origin server-names unique-id)
first-timeout
(hash)
'()
server-names))))
(define (try-next-server w)
(match w
[(network-query-state req timeout '())
[(network-query-state req #f _ _ _)
;; No more timeouts to try, so give up.
(on-answer w (empty-complete-answer))]
[(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 (network-request-server-ips req)]))]
[(network-query-state req #f _)
;; No more timeouts to try, so give up.
(on-answer w (empty-complete-answer))]
[(network-query-state req timeout (cons current-address remaining-addresses))
[remaining-addresses '()]
[remaining-names (network-request-server-names req)]))]
[(network-query-state _ _ 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)]
[remaining-names remaining-names]))
(let ((subscription-id (list 'nameserver-name-resolution current-name))
(subq (question current-name 'a 'in))) ;; TODO: 'aaaa ?
(transition (struct-copy network-query-state w [remaining-names remaining-names])
(send-message subq)
(subscribe subscription-id
(message-handlers w
[(answered-question (== subq) ans)
(define ips
(map make-dns-address (set->list (extract-addresses current-name ans))))
(extend-transition
(try-next-server (struct-copy network-query-state w
[known-addresses (hash-set known-addresses
current-name
ips)]
[remaining-addresses ips]))
(unsubscribe subscription-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))
(subscribe rpc-id
(message-handlers w
[`(reply ,(== rpc-id) ,id)
(extend-transition (send-request req id timeout current-address remaining-addresses)
(extend-transition (send-request (struct-copy network-query-state w
[remaining-addresses remaining-ips])
id
timeout
current-ip)
(unsubscribe rpc-id))])))]))
(define (on-answer w ans)
@ -200,12 +206,12 @@
(send-message (network-reply (network-request-unique-id (network-query-state-request w))
ans))))
(define (send-request req query-id timeout server-ip remaining-ips)
(match-define (network-request s q zone-origin _ _) req)
(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))
(define subscription-id (list s query-id))
(define start-time (current-inexact-milliseconds))
(transition (network-query-state req timeout remaining-ips)
(transition w
(send-message (dns-request query s server-ip))
(send-message (set-timer subscription-id (* timeout 1000) #t))
(subscribe subscription-id