More pseudo-substruct pollution; proxy.rkt now works again
This commit is contained in:
Tony Garnock-Jones
parent
7653cf545a
commit
0bcfd18420
14
api.rkt
14
api.rkt
|
|
@ -21,10 +21,11 @@
|
|||
cname-question
|
||||
ns-question
|
||||
|
||||
AnsweredQuestion
|
||||
RR
|
||||
(struct-out answered-question)
|
||||
(struct-out answered-question-repr)
|
||||
AnsweredQuestion answered-question answered-question?
|
||||
AnsweredQuestionPattern answered-question-pattern answered-question-pattern?
|
||||
(struct-out rr)
|
||||
RR
|
||||
|
||||
CompleteAnswer
|
||||
(struct-out complete-answer)
|
||||
|
|
@ -122,8 +123,11 @@
|
|||
|
||||
;; An AnsweredQuestion is an (answered-question Question
|
||||
;; Maybe<CompleteAnswer>).
|
||||
(struct: answered-question ([q : Question] [a : (Option CompleteAnswer)]) #:prefab)
|
||||
(define-type AnsweredQuestion answered-question)
|
||||
(struct: (TQ TA) answered-question-repr ([q : TQ] [a : TA]) #:prefab)
|
||||
(pseudo-substruct: (answered-question-repr Question (Option CompleteAnswer))
|
||||
AnsweredQuestion answered-question answered-question?)
|
||||
(pseudo-substruct: (answered-question-repr (U Wild Question) (U Wild (Option CompleteAnswer)))
|
||||
AnsweredQuestionPattern answered-question-pattern answered-question-pattern?)
|
||||
|
||||
;; A CompleteAnswer is a (complete-answer Set<RR> Set<RR> Set<RR>)
|
||||
(struct: complete-answer
|
||||
|
|
|
|||
|
|
@ -8,11 +8,14 @@
|
|||
(require racket-typed-matrix/sugar-typed)
|
||||
(require racket-typed-matrix/drivers/udp)
|
||||
(require racket-typed-matrix/drivers/timer)
|
||||
(require racket-typed-matrix/support/pseudo-substruct)
|
||||
(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))
|
||||
(struct-out network-reply-repr)
|
||||
NetworkReply network-reply network-reply?
|
||||
NetworkReplyPattern network-reply-pattern network-reply-pattern?)
|
||||
|
||||
;; DJB's rules for handling DNS responses. Some of these are handled
|
||||
;; here (specifically, rules 2 through 5, in the action of
|
||||
|
|
@ -119,7 +122,13 @@
|
|||
|
||||
;; A NetworkReply is a (network-reply UniqueID Maybe<CompleteAnswer>)
|
||||
;; representing the final result of a network query.
|
||||
(struct: network-reply ([unique-id : Any] [answer : (Option CompleteAnswer)]) #:prefab)
|
||||
(struct: (TId TAnswer)
|
||||
network-reply-repr
|
||||
([unique-id : TId] [answer : TAnswer]) #:prefab)
|
||||
(pseudo-substruct: (network-reply-repr Any (Option CompleteAnswer))
|
||||
NetworkReply network-reply network-reply?)
|
||||
(pseudo-substruct: (network-reply-repr (U Wild Any) (U Wild (Option CompleteAnswer)))
|
||||
NetworkReplyPattern network-reply-pattern network-reply-pattern?)
|
||||
|
||||
;; A NetworkQueryState is a (network-query-state NetworkRequest
|
||||
;; Integer Map<DomainName,ListOf<UdpAddress>> ListOf<UdpAddress>
|
||||
|
|
|
|||
40
proxy.rkt
40
proxy.rkt
|
|
@ -123,10 +123,10 @@
|
|||
original-question (dns-message-id request-message)))
|
||||
(transition 'no-state/packet-relay
|
||||
(send-message original-question)
|
||||
(endpoint #:subscriber (answered-question original-question (wild))
|
||||
(endpoint #:subscriber (answered-question-repr original-question (wild))
|
||||
#:state w
|
||||
#:let-name wait-id
|
||||
[(answered-question (== original-question) answer)
|
||||
[(answered-question-repr (== original-question) answer)
|
||||
(begin (log-debug (format "Final answer to ~v with query id ~v is ~v"
|
||||
original-question
|
||||
(dns-message-id request-message)
|
||||
|
|
@ -139,16 +139,16 @@
|
|||
;; Restart q, an overly-glueless question, from the roots.
|
||||
(define restarted-question (restart-question q))
|
||||
(transition 'no-state
|
||||
(endpoint #:subscriber (answered-question restarted-question (wild))
|
||||
(endpoint #:subscriber (answered-question-repr restarted-question (wild))
|
||||
#:state w
|
||||
#:let-name relay
|
||||
[(answered-question (== restarted-question) ans)
|
||||
[(answered-question-repr (== restarted-question) ans)
|
||||
;; We got the answer to our restarted question; now transform
|
||||
;; it into an answer to the original question, to unblock the
|
||||
;; original questioner.
|
||||
(transition w
|
||||
(delete-endpoint relay)
|
||||
(send-message (answered-question q ans)))])
|
||||
(send-message (answered-question-repr q ans)))])
|
||||
(spawn #:debug-name (list 'glueless-question-handler-inner restarted-question)
|
||||
#:child (question-handler roots-only-zone restarted-question client-sock))))
|
||||
|
||||
|
|
@ -197,7 +197,7 @@
|
|||
(cond
|
||||
[(question-cyclic? q)
|
||||
(log-warning (format "Cyclic question ~v" q))
|
||||
(send-message (answered-question q (empty-complete-answer)))]
|
||||
(send-message (answered-question-repr q (empty-complete-answer)))]
|
||||
[(question-too-glueless? q)
|
||||
(log-warning (format "Overly-glueless question ~v" q))
|
||||
(spawn #:debug-name (list 'glueless-question-handler-outer q)
|
||||
|
|
@ -205,9 +205,9 @@
|
|||
[else
|
||||
(spawn #:debug-name (list 'question-handler q)
|
||||
#:child (question-handler zone q client-sock))]))])
|
||||
(endpoint #:subscriber (network-reply (wild) (wild))
|
||||
(endpoint #:subscriber (network-reply-repr (wild) (wild))
|
||||
#:state zone
|
||||
[(network-reply _ answer)
|
||||
[(network-reply-repr _ answer)
|
||||
(let-values (((new-zone timers) (incorporate-complete-answer answer zone #t)))
|
||||
(transition-and-set-timers new-zone timers))])
|
||||
(endpoint #:subscriber (timer-expired (list 'check-dns-expiry (wild)) (wild))
|
||||
|
|
@ -222,7 +222,7 @@
|
|||
(retry-question (question-state zone q client-sock (set) 0)))
|
||||
|
||||
(define (send-empty-reply w q)
|
||||
(transition w (send-message (answered-question q (empty-complete-answer)))))
|
||||
(transition w (send-message (answered-question-repr q (empty-complete-answer)))))
|
||||
|
||||
(define (retry-question w)
|
||||
(match w
|
||||
|
|
@ -241,21 +241,21 @@
|
|||
(define referral-id (gensym 'referral))
|
||||
(log-debug (format "Referral for ~v id ~v to ~v servers ~v"
|
||||
q referral-id (domain-labels zone-origin)
|
||||
(map domain-labels (set-map nameserver-rrs rr-rdata))))
|
||||
(map domain-labels (set-map nameserver-rrs rr-rdata-domain-name))))
|
||||
(transition w
|
||||
(network-query client-sock
|
||||
q
|
||||
zone-origin
|
||||
(map rr-rdata (set->list nameserver-rrs))
|
||||
(map rr-rdata-domain-name (set->list nameserver-rrs))
|
||||
referral-id)
|
||||
(endpoint #:subscriber (network-reply referral-id (wild))
|
||||
(endpoint #:subscriber (network-reply-repr referral-id (wild))
|
||||
#:name referral-id
|
||||
#:state w
|
||||
[(network-reply (== referral-id) #f) ;; name-error/NXDOMAIN
|
||||
[(network-reply-repr (== referral-id) #f) ;; name-error/NXDOMAIN
|
||||
(transition w
|
||||
(delete-endpoint referral-id)
|
||||
(send-message (answered-question q #f)))]
|
||||
[(network-reply (== referral-id) ans)
|
||||
(send-message (answered-question-repr q #f)))]
|
||||
[(network-reply-repr (== referral-id) ans)
|
||||
(let-values (((new-zone ignored-timers) (incorporate-complete-answer ans zone #f)))
|
||||
(when (log-level? (current-logger) 'debug)
|
||||
(log-debug (format "Referral ~v results in origin ~v:~n"
|
||||
|
|
@ -267,7 +267,7 @@
|
|||
k (hash-ref zone k 'missing)
|
||||
k (hash-ref new-zone k 'missing))))
|
||||
(log-debug "=-=-=-=-=-="))
|
||||
(define nameserver-names (for/set ([rr nameserver-rrs]) (rr-rdata rr)))
|
||||
(define nameserver-names (for/set ([rr nameserver-rrs]) (rr-rdata-domain-name rr)))
|
||||
(sequence-actions
|
||||
(retry-question (struct-copy question-state w
|
||||
[nameservers-tried (set-union nameservers-tried
|
||||
|
|
@ -276,17 +276,17 @@
|
|||
[retry-count (+ old-retry-count 1)]))
|
||||
(delete-endpoint referral-id)))]))]
|
||||
[(? complete-answer? ans)
|
||||
(transition w (send-message (answered-question q ans)))]
|
||||
(transition w (send-message (answered-question-repr q ans)))]
|
||||
[(partial-answer base cnames)
|
||||
(transition (expanding-cnames q base (length cnames))
|
||||
(map (lambda (cname)
|
||||
;; TODO: record chains of CNAMEs to avoid pathologically-long chains
|
||||
(define cname-q (cname-question cname q))
|
||||
(list (send-message cname-q)
|
||||
(endpoint #:subscriber (answered-question cname-q (wild))
|
||||
(endpoint #:subscriber (answered-question-repr cname-q (wild))
|
||||
#:state (expanding-cnames q acc remaining)
|
||||
#:let-name subscription-id
|
||||
[(answered-question (== cname-q) ans)
|
||||
[(answered-question-repr (== cname-q) ans)
|
||||
(let ()
|
||||
(define new-acc (if ans (merge-answers acc ans) acc))
|
||||
(define new-remaining (- remaining 1))
|
||||
|
|
@ -294,7 +294,7 @@
|
|||
(transition new-w
|
||||
(delete-endpoint subscription-id)
|
||||
(if (zero? new-remaining)
|
||||
(send-message (answered-question q new-acc))
|
||||
(send-message (answered-question-repr q new-acc))
|
||||
'())))])))
|
||||
cnames))])]))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue