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

Track current-name, which we need to know to remove lame servers.

This commit is contained in:
Tony Garnock-Jones 2012-04-04 17:55:33 -04:00
parent 18facb4c9e
commit 6c8c6c5201
1 changed files with 13 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
network-query.rkt
View File

@ -86,11 +86,13 @@
;; A NetworkQueryState is a (network-query-state NetworkRequest ;; A NetworkQueryState is a (network-query-state NetworkRequest
;; Integer Map<DomainName,ListOf<UdpAddress>> ListOf<UdpAddress> ;; Integer Map<DomainName,ListOf<UdpAddress>> ListOf<UdpAddress>
;; ListOf<DomainName>), representing an in-progress DNS network query. ;; Maybe<DomainName> ListOf<DomainName>), representing an in-progress
;; DNS network query.
(struct network-query-state (request (struct network-query-state (request
timeout timeout
known-addresses known-addresses
remaining-addresses remaining-addresses
current-name
remaining-names) remaining-names)
#:transparent) #:transparent)
@ -154,29 +156,34 @@
first-timeout first-timeout
(hash) (hash)
'() '()
#f
server-names)))) server-names))))
(define (try-next-server w) (define (try-next-server w)
(match w (match w
[(network-query-state _ #f _ _ _) [(network-query-state _ #f _ _ _ _)
;; No more timeouts to try, so give up. ;; No more timeouts to try, so give up.
(on-answer w (empty-complete-answer))] (on-answer w (empty-complete-answer))]
[(network-query-state req timeout _ '() '()) [(network-query-state req timeout _ '() _ '())
;; No more addresses to try with this timeout. Refill the list ;; No more addresses to try with this timeout. Refill the list
;; and bump the timeout and retry. ;; and bump the timeout and retry.
;; TODO: randomize ordering of servers in list. (Don't forget the initial fill.) ;; TODO: randomize ordering of servers in list. (Don't forget the initial fill.)
(try-next-server (struct-copy network-query-state w (try-next-server (struct-copy network-query-state w
[timeout (next-timeout timeout)] [timeout (next-timeout timeout)]
[remaining-addresses '()] [remaining-addresses '()]
[current-name #f]
[remaining-names (network-request-server-names req)]))] [remaining-names (network-request-server-names req)]))]
[(network-query-state req _ known-addresses '() (cons current-name remaining-names)) [(network-query-state req _ known-addresses '() _ (cons current-name remaining-names))
(if (hash-has-key? known-addresses current-name) (if (hash-has-key? known-addresses current-name)
(try-next-server (struct-copy network-query-state w (try-next-server (struct-copy network-query-state w
[remaining-addresses (hash-ref known-addresses [remaining-addresses (hash-ref known-addresses
current-name)] current-name)]
[current-name current-name]
[remaining-names remaining-names])) [remaining-names remaining-names]))
(let ((subq (ns-question current-name (network-request-question req)))) (let ((subq (ns-question current-name (network-request-question req))))
(transition (struct-copy network-query-state w [remaining-names remaining-names]) (transition (struct-copy network-query-state w
[current-name current-name]
[remaining-names remaining-names])
(send-message subq) (send-message subq)
(subscribe/fresh subscription-id (subscribe/fresh subscription-id
(message-handlers w (message-handlers w
@ -190,7 +197,7 @@
ips)] ips)]
[remaining-addresses ips])) [remaining-addresses ips]))
(unsubscribe subscription-id))])))))] (unsubscribe subscription-id))])))))]
[(network-query-state req timeout _ (cons current-ip remaining-ips) _) [(network-query-state req timeout _ (cons current-ip remaining-ips) _ _)
(define rpc-id (gensym 'network-query/allocate-query-id)) (define rpc-id (gensym 'network-query/allocate-query-id))
(transition w (transition w
(send-message `(request ,rpc-id allocate-query-id)) (send-message `(request ,rpc-id allocate-query-id))