Update to extrasugar syntax
This commit is contained in:
Tony Garnock-Jones
parent
1c59eff9d3
commit
fe320d86ce
15
driver.rkt
15
driver.rkt
|
|
@ -60,17 +60,16 @@
|
||||||
|
|
||||||
(ground-vm: ((inst udp-driver Void))
|
(ground-vm: ((inst udp-driver Void))
|
||||||
((inst generic-spy Void) 'UDP)
|
((inst generic-spy Void) 'UDP)
|
||||||
(nested-vm: : Void
|
(spawn-vm: : Void
|
||||||
(spawn: #:parent : Void #:child : Void (dns-spy))
|
(spawn: #:parent : Void #:child : Void (dns-spy))
|
||||||
(spawn: #:parent : Void #:child : Void (dns-read-driver local-addr))
|
(spawn: #:parent : Void #:child : Void (dns-read-driver local-addr))
|
||||||
(spawn: #:parent : Void #:child : Void (dns-write-driver local-addr))
|
(spawn: #:parent : Void #:child : Void (dns-write-driver local-addr))
|
||||||
(endpoint: : Void #:subscriber (bad-dns-packet-pattern (wild) (wild) (wild) (wild))
|
(subscriber: Void (bad-dns-packet-pattern (wild) (wild) (wild) (wild))
|
||||||
[p (begin (log-error (pretty-format p))
|
(on-message [p (begin (log-error (pretty-format p)) '())]))
|
||||||
'())])
|
(subscriber: Void (dns-request-pattern (wild) (wild) (wild))
|
||||||
(endpoint: : Void #:subscriber (dns-request-pattern (wild) (wild) (wild))
|
(on-message [(? dns-request? r)
|
||||||
[(? dns-request? r)
|
(let ((reply (handle-request soa-rr zone r)))
|
||||||
(begin (define reply (handle-request soa-rr zone r))
|
(when reply (send-message reply)))])))))
|
||||||
(when reply (send-message reply)))]))))
|
|
||||||
|
|
||||||
(define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage))
|
(define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -246,16 +246,16 @@
|
||||||
UdpAddress Question DomainName (Listof DomainName) Any ->
|
UdpAddress Question DomainName (Listof DomainName) Any ->
|
||||||
(Action ParentState)))
|
(Action ParentState)))
|
||||||
(define (network-query s q zone-origin server-names unique-id)
|
(define (network-query s q zone-origin server-names unique-id)
|
||||||
(spawn: #:debug-name (list 'network-query q)
|
(name-process (list 'network-query q)
|
||||||
#:parent : ParentState
|
(spawn: #:parent : ParentState
|
||||||
#:child : NetworkQueryState
|
#:child : NetworkQueryState
|
||||||
(try-next-server
|
(try-next-server
|
||||||
(network-query-state (network-request s q zone-origin server-names unique-id)
|
(network-query-state (network-request s q zone-origin server-names unique-id)
|
||||||
first-timeout
|
first-timeout
|
||||||
(ann #hash() (HashTable DomainName (Listof UdpAddress)))
|
(ann #hash() (HashTable DomainName (Listof UdpAddress)))
|
||||||
'()
|
'()
|
||||||
#f
|
#f
|
||||||
server-names))))
|
server-names)))))
|
||||||
|
|
||||||
(: try-next-server : NetworkQueryState -> (Transition NetworkQueryState))
|
(: try-next-server : NetworkQueryState -> (Transition NetworkQueryState))
|
||||||
(define (try-next-server w)
|
(define (try-next-server w)
|
||||||
|
|
@ -284,33 +284,36 @@
|
||||||
[current-name current-name]
|
[current-name current-name]
|
||||||
[remaining-names remaining-names]) : NetworkQueryState
|
[remaining-names remaining-names]) : NetworkQueryState
|
||||||
(send-message subq)
|
(send-message subq)
|
||||||
(endpoint: w : NetworkQueryState
|
(let-fresh (subq-id)
|
||||||
#:subscriber (answered-question-pattern subq (wild))
|
(name-endpoint subq-id
|
||||||
#:let-name subq-id
|
(subscriber: NetworkQueryState (answered-question-pattern subq (wild))
|
||||||
[(answered-question (== subq) ans)
|
(match-state w
|
||||||
(let ((ips (map make-dns-address
|
(on-message
|
||||||
(set->list (extract-addresses current-name ans)))))
|
[(answered-question (== subq) ans)
|
||||||
(sequence-actions
|
(let ((ips (map make-dns-address
|
||||||
(try-next-server (struct-copy network-query-state w
|
(set->list (extract-addresses current-name ans)))))
|
||||||
[known-addresses (hash-set known-addresses
|
(sequence-actions
|
||||||
current-name
|
(try-next-server (struct-copy network-query-state w
|
||||||
ips)]
|
[known-addresses (hash-set known-addresses
|
||||||
[remaining-addresses ips]))
|
current-name
|
||||||
(delete-endpoint subq-id)))]))))]
|
ips)]
|
||||||
|
[remaining-addresses ips]))
|
||||||
|
(delete-endpoint subq-id)))]))))))))]
|
||||||
[(network-query-state req _ _ (cons current-ip remaining-ips) _ _)
|
[(network-query-state req _ _ (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 : NetworkQueryState
|
(transition: w : NetworkQueryState
|
||||||
(send-message `(request ,rpc-id allocate-query-id))
|
(send-message `(request ,rpc-id allocate-query-id))
|
||||||
(endpoint: w : NetworkQueryState
|
(name-endpoint rpc-id
|
||||||
#:subscriber `(reply ,rpc-id ,(wild))
|
(subscriber: NetworkQueryState `(reply ,rpc-id ,(wild))
|
||||||
#:name rpc-id
|
(match-state w
|
||||||
[`(reply ,(== rpc-id) ,(? exact-nonnegative-integer? id))
|
(on-message
|
||||||
(sequence-actions (send-request (struct-copy network-query-state w
|
[`(reply ,(== rpc-id) ,(? exact-nonnegative-integer? id))
|
||||||
[remaining-addresses remaining-ips])
|
(sequence-actions (send-request (struct-copy network-query-state w
|
||||||
id
|
[remaining-addresses remaining-ips])
|
||||||
timeout
|
id
|
||||||
current-ip)
|
timeout
|
||||||
(delete-endpoint rpc-id))]))])))
|
current-ip)
|
||||||
|
(delete-endpoint rpc-id))])))))])))
|
||||||
|
|
||||||
(: on-answer : NetworkQueryState CheckedAnswer (Option UdpAddress)
|
(: on-answer : NetworkQueryState CheckedAnswer (Option UdpAddress)
|
||||||
-> (Transition NetworkQueryState))
|
-> (Transition NetworkQueryState))
|
||||||
|
|
@ -356,38 +359,40 @@
|
||||||
(send-message (dns-request query s server-ip))
|
(send-message (dns-request query s server-ip))
|
||||||
(send-message (set-timer timeout-id (* timeout 1000) 'relative))
|
(send-message (set-timer timeout-id (* timeout 1000) 'relative))
|
||||||
;; TODO: Restore this to a "join" when proper pattern-unions are implemented
|
;; TODO: Restore this to a "join" when proper pattern-unions are implemented
|
||||||
(endpoint: w : NetworkQueryState
|
(name-endpoint timeout-id
|
||||||
#:subscriber (timer-expired-pattern timeout-id (wild))
|
(subscriber: NetworkQueryState (timer-expired-pattern timeout-id (wild))
|
||||||
#:name timeout-id
|
(match-state w
|
||||||
[(timer-expired (== timeout-id) _)
|
(on-message
|
||||||
(begin
|
[(timer-expired (== timeout-id) _)
|
||||||
(log-debug (format "Timed out ~v ~v to ~v ~v after ~v seconds"
|
(begin
|
||||||
q query-id
|
(log-debug (format "Timed out ~v ~v to ~v ~v after ~v seconds"
|
||||||
zone-origin server-ip
|
q query-id
|
||||||
timeout))
|
zone-origin server-ip
|
||||||
(sequence-actions (try-next-server w)
|
timeout))
|
||||||
(delete-endpoint timeout-id)
|
(sequence-actions (try-next-server w)
|
||||||
(delete-endpoint reply-wait-id)
|
(delete-endpoint timeout-id)
|
||||||
(send-message (list 'release-query-id query-id))))])
|
(delete-endpoint reply-wait-id)
|
||||||
(endpoint: w : NetworkQueryState
|
(send-message (list 'release-query-id query-id))))]))))
|
||||||
#:subscriber (dns-reply-pattern (wild) (wild) s)
|
(name-endpoint reply-wait-id
|
||||||
#:name reply-wait-id
|
(subscriber: NetworkQueryState (dns-reply-pattern (wild) (wild) s)
|
||||||
[(dns-reply reply-message source (== s))
|
(match-state w
|
||||||
;; TODO: maybe receive only specifically from the queried IP address?
|
(on-message
|
||||||
(begin
|
[(dns-reply reply-message source (== s))
|
||||||
(log-debug
|
;; TODO: maybe receive only specifically from the queried IP address?
|
||||||
(format
|
(begin
|
||||||
"Answer to ~v from ~v ~v in ~v ms~n-- Answers: ~v~n-- Authorities: ~v~n-- Additional: ~v"
|
(log-debug
|
||||||
q zone-origin server-ip
|
(format
|
||||||
(inexact->exact (round (- (current-inexact-milliseconds) start-time)))
|
"Answer to ~v from ~v ~v in ~v ms~n-- Answers: ~v~n-- Authorities: ~v~n-- Additional: ~v"
|
||||||
(dns-message-answers reply-message)
|
q zone-origin server-ip
|
||||||
(dns-message-authorities reply-message)
|
(inexact->exact (round (- (current-inexact-milliseconds) start-time)))
|
||||||
(dns-message-additional reply-message)))
|
(dns-message-answers reply-message)
|
||||||
(if (not (= (dns-message-id reply-message) (dns-message-id query)))
|
(dns-message-authorities reply-message)
|
||||||
(transition: w : NetworkQueryState)
|
(dns-message-additional reply-message)))
|
||||||
(sequence-actions (on-answer w
|
(if (not (= (dns-message-id reply-message) (dns-message-id query)))
|
||||||
(filter-dns-reply q reply-message zone-origin)
|
(transition: w : NetworkQueryState)
|
||||||
server-ip)
|
(sequence-actions (on-answer w
|
||||||
(delete-endpoint timeout-id)
|
(filter-dns-reply q reply-message zone-origin)
|
||||||
(delete-endpoint reply-wait-id)
|
server-ip)
|
||||||
(send-message (list 'release-query-id query-id)))))])))
|
(delete-endpoint timeout-id)
|
||||||
|
(delete-endpoint reply-wait-id)
|
||||||
|
(send-message (list 'release-query-id query-id)))))]))))))
|
||||||
|
|
|
||||||
376
proxy.rkt
376
proxy.rkt
|
|
@ -54,70 +54,76 @@
|
||||||
((inst generic-spy Void) 'UDP)
|
((inst generic-spy Void) 'UDP)
|
||||||
((inst udp-driver Void))
|
((inst udp-driver Void))
|
||||||
((inst timer-driver Void))
|
((inst timer-driver Void))
|
||||||
(nested-vm: : Void
|
(spawn-vm: : Void
|
||||||
#:debug-name 'dns-vm
|
#:debug-name 'dns-vm
|
||||||
(spawn: #:debug-name 'dns-spy #:parent : Void #:child : Void (dns-spy))
|
(name-process 'dns-spy (spawn: #:parent : Void #:child : Void (dns-spy)))
|
||||||
((inst timer-relay Void) 'timer-relay:dns)
|
((inst timer-relay Void) 'timer-relay:dns)
|
||||||
(spawn: #:debug-name 'query-id-allocator #:parent : Void
|
(name-process 'query-id-allocator (spawn: #:parent : Void #:child : (Setof Natural)
|
||||||
#:child : (Setof Natural)
|
(query-id-allocator)))
|
||||||
(query-id-allocator))
|
(name-process 'server-dns-reader (spawn: #:parent : Void #:child : Void
|
||||||
(spawn: #:debug-name 'server-dns-reader #:parent : Void
|
(dns-read-driver server-addr)))
|
||||||
#:child : Void (dns-read-driver server-addr))
|
(name-process 'server-dns-writer (spawn: #:parent : Void #:child : Void
|
||||||
(spawn: #:debug-name 'server-dns-writer #:parent : Void
|
(dns-write-driver server-addr)))
|
||||||
#:child : Void (dns-write-driver server-addr))
|
(name-process 'client-dns-reader (spawn: #:parent : Void #:child : Void
|
||||||
(spawn: #:debug-name 'client-dns-reader #:parent : Void
|
(dns-read-driver client-addr)))
|
||||||
#:child : Void (dns-read-driver client-addr))
|
(name-process 'client-dns-writer (spawn: #:parent : Void #:child : Void
|
||||||
(spawn: #:debug-name 'client-dns-writer #:parent : Void
|
(dns-write-driver client-addr)))
|
||||||
#:child : Void (dns-write-driver client-addr))
|
(name-process 'packet-dispatcher (spawn: #:parent : Void
|
||||||
(spawn: #:debug-name 'packet-dispatcher #:parent : Void
|
#:child : (Setof ActiveRequest)
|
||||||
#:child : (Setof ActiveRequest) (packet-dispatcher server-addr))
|
(packet-dispatcher server-addr)))
|
||||||
(spawn: #:debug-name 'question-dispatcher #:parent : Void
|
(name-process 'question-dispatcher (spawn: #:parent : Void
|
||||||
#:child : CompiledZone (question-dispatcher zone roots-only client-addr)))))
|
#:child : CompiledZone
|
||||||
|
(question-dispatcher zone
|
||||||
|
roots-only
|
||||||
|
client-addr))))))
|
||||||
|
|
||||||
(: query-id-allocator : -> (Transition (Setof Natural)))
|
(: query-id-allocator : -> (Transition (Setof Natural)))
|
||||||
(define (query-id-allocator)
|
(define (query-id-allocator)
|
||||||
;; TODO: track how many are allocated and throttle requests if too
|
;; TODO: track how many are allocated and throttle requests if too
|
||||||
;; many are in flight
|
;; many are in flight
|
||||||
(transition: ((inst set Natural)) : (Setof Natural) ;; all active query IDs
|
(transition: ((inst set Natural)) : (Setof Natural) ;; all active query IDs
|
||||||
(endpoint: allocated : (Setof Natural)
|
(subscriber: (Setof Natural) `(request ,(wild) allocate-query-id)
|
||||||
#:subscriber `(request ,(wild) allocate-query-id)
|
(match-state allocated
|
||||||
[`(request ,reply-addr allocate-query-id)
|
(on-message
|
||||||
(let: recheck : (Transition (Setof Natural)) ()
|
[`(request ,reply-addr allocate-query-id)
|
||||||
(define n (random 65536))
|
(let: recheck : (Transition (Setof Natural)) ()
|
||||||
(if (set-member? allocated n)
|
(define n (random 65536))
|
||||||
(recheck)
|
(if (set-member? allocated n)
|
||||||
(transition: (set-add allocated n) : (Setof Natural)
|
(recheck)
|
||||||
(send-message `(reply ,reply-addr ,n)))))])
|
(transition: (set-add allocated n) : (Setof Natural)
|
||||||
(endpoint: allocated : (Setof Natural)
|
(send-message `(reply ,reply-addr ,n)))))])))
|
||||||
#:subscriber `(release-query-id ,(wild))
|
(subscriber: (Setof Natural) `(release-query-id ,(wild))
|
||||||
[`(release-query-id ,(? exact-nonnegative-integer? n))
|
(match-state allocated
|
||||||
(transition: (set-remove allocated n) : (Setof Natural))])))
|
(on-message
|
||||||
|
[`(release-query-id ,(? exact-nonnegative-integer? n))
|
||||||
|
(transition: (set-remove allocated n) : (Setof Natural))])))))
|
||||||
|
|
||||||
(: packet-dispatcher : UdpAddress -> (Transition (Setof ActiveRequest)))
|
(: packet-dispatcher : UdpAddress -> (Transition (Setof ActiveRequest)))
|
||||||
(define (packet-dispatcher s)
|
(define (packet-dispatcher s)
|
||||||
(transition: ((inst set ActiveRequest)) : (Setof ActiveRequest)
|
(transition: ((inst set ActiveRequest)) : (Setof ActiveRequest)
|
||||||
(endpoint: : (Setof ActiveRequest)
|
(subscriber: (Setof ActiveRequest) (bad-dns-packet-pattern (wild) (wild) (wild) (wild))
|
||||||
#:subscriber (bad-dns-packet-pattern (wild) (wild) (wild) (wild))
|
(on-message [p (begin (log-error (pretty-format p)) '())]))
|
||||||
[p (begin (log-error (pretty-format p)) '())])
|
(subscriber: (Setof ActiveRequest) (dns-request-pattern (wild) (wild) s)
|
||||||
(endpoint: old-active-requests : (Setof ActiveRequest)
|
(match-state old-active-requests
|
||||||
#:subscriber (dns-request-pattern (wild) (wild) s)
|
(on-message
|
||||||
[(and r (dns-request m source (== s)))
|
[(and r (dns-request m source (== s)))
|
||||||
;; ^ We only listen for requests on our server socket
|
;; ^ We only listen for requests on our server socket
|
||||||
(let ((req-id (active-request source (dns-message-id m))))
|
(let ((req-id (active-request source (dns-message-id m))))
|
||||||
;; TODO: when we have presence/error-handling, remove req-id
|
;; TODO: when we have presence/error-handling, remove req-id
|
||||||
;; from active requests once request-handler pseudothread exits.
|
;; from active requests once request-handler pseudothread exits.
|
||||||
(if (set-member? old-active-requests req-id)
|
(if (set-member? old-active-requests req-id)
|
||||||
(transition: old-active-requests : (Setof ActiveRequest))
|
(transition: old-active-requests : (Setof ActiveRequest))
|
||||||
;; ^ ignore retransmitted duplicates
|
;; ^ ignore retransmitted duplicates
|
||||||
(transition: (set-add old-active-requests req-id) : (Setof ActiveRequest)
|
(transition: (set-add old-active-requests req-id) : (Setof ActiveRequest)
|
||||||
(spawn: #:debug-name (list 'packet-relay req-id)
|
(name-process (list 'packet-relay req-id)
|
||||||
#:parent : (Setof ActiveRequest)
|
(spawn: #:parent : (Setof ActiveRequest)
|
||||||
#:child : Void (packet-relay req-id r)))))])
|
#:child : Void (packet-relay req-id r))))))])))
|
||||||
(endpoint: old-active-requests : (Setof ActiveRequest)
|
(subscriber: (Setof ActiveRequest) (dns-reply-pattern (wild) s (wild))
|
||||||
#:subscriber (dns-reply-pattern (wild) s (wild))
|
(match-state old-active-requests
|
||||||
[(and r (dns-reply m (== s) sink))
|
(on-message
|
||||||
(let ((req-id (active-request sink (dns-message-id m))))
|
[(and r (dns-reply m (== s) sink))
|
||||||
(transition: (set-remove old-active-requests req-id) : (Setof ActiveRequest)))])))
|
(let ((req-id (active-request sink (dns-message-id m))))
|
||||||
|
(transition: (set-remove old-active-requests req-id) : (Setof ActiveRequest)))])))))
|
||||||
|
|
||||||
(: packet-relay : ActiveRequest DNSRequest -> (Transition Void))
|
(: packet-relay : ActiveRequest DNSRequest -> (Transition Void))
|
||||||
(define (packet-relay req-id request)
|
(define (packet-relay req-id request)
|
||||||
|
|
@ -157,35 +163,37 @@
|
||||||
original-question (dns-message-id request-message)))
|
original-question (dns-message-id request-message)))
|
||||||
(transition/no-state
|
(transition/no-state
|
||||||
(send-message original-question)
|
(send-message original-question)
|
||||||
(endpoint: : Void
|
(let-fresh (wait-id)
|
||||||
#:subscriber (answered-question-pattern original-question (wild))
|
(name-endpoint wait-id
|
||||||
#:let-name wait-id
|
(subscriber: Void (answered-question-pattern original-question (wild))
|
||||||
[(answered-question (== original-question) answer)
|
(on-message
|
||||||
(begin (log-debug (format "Final answer to ~v with query id ~v is ~v"
|
[(answered-question (== original-question) answer)
|
||||||
original-question
|
(begin (log-debug (format "Final answer to ~v with query id ~v is ~v"
|
||||||
(dns-message-id request-message)
|
original-question
|
||||||
answer))
|
(dns-message-id request-message)
|
||||||
(list (delete-endpoint wait-id)
|
answer))
|
||||||
(send-message (answer->reply original-question answer))))]))]))
|
(list (delete-endpoint wait-id)
|
||||||
|
(send-message (answer->reply original-question answer))))])))))]))
|
||||||
|
|
||||||
(: glueless-question-handler : CompiledZone Question UdpAddress -> (Transition Void))
|
(: glueless-question-handler : CompiledZone Question UdpAddress -> (Transition Void))
|
||||||
(define (glueless-question-handler roots-only-zone q client-sock)
|
(define (glueless-question-handler roots-only-zone q client-sock)
|
||||||
;; Restart q, an overly-glueless question, from the roots.
|
;; Restart q, an overly-glueless question, from the roots.
|
||||||
(define restarted-question (restart-question q))
|
(define restarted-question (restart-question q))
|
||||||
(transition/no-state
|
(transition/no-state
|
||||||
(endpoint: : Void
|
(let-fresh (relay)
|
||||||
#:subscriber (answered-question-pattern restarted-question (wild))
|
(name-endpoint relay
|
||||||
#:let-name relay
|
(subscriber: Void (answered-question-pattern restarted-question (wild))
|
||||||
[(answered-question (== restarted-question) ans)
|
(on-message
|
||||||
;; We got the answer to our restarted question; now transform
|
[(answered-question (== restarted-question) ans)
|
||||||
;; it into an answer to the original question, to unblock the
|
;; We got the answer to our restarted question; now transform
|
||||||
;; original questioner.
|
;; it into an answer to the original question, to unblock the
|
||||||
(list (delete-endpoint relay)
|
;; original questioner.
|
||||||
(send-message (answered-question q ans)))])
|
(list (delete-endpoint relay)
|
||||||
(spawn: #:debug-name (list 'glueless-question-handler-inner restarted-question)
|
(send-message (answered-question q ans)))]))))
|
||||||
#:parent : Void
|
(name-process (list 'glueless-question-handler-inner restarted-question)
|
||||||
#:child : QHState
|
(spawn: #:parent : Void
|
||||||
(question-handler roots-only-zone restarted-question client-sock))))
|
#:child : QHState
|
||||||
|
(question-handler roots-only-zone restarted-question client-sock)))))
|
||||||
|
|
||||||
(: question-dispatcher : CompiledZone CompiledZone UdpAddress -> (Transition CompiledZone))
|
(: question-dispatcher : CompiledZone CompiledZone UdpAddress -> (Transition CompiledZone))
|
||||||
(define (question-dispatcher seed-zone roots-only client-sock)
|
(define (question-dispatcher seed-zone roots-only client-sock)
|
||||||
|
|
@ -199,66 +207,70 @@
|
||||||
(define-values (cleaned-seed-zone initial-timers) (zone-expire seed-zone))
|
(define-values (cleaned-seed-zone initial-timers) (zone-expire seed-zone))
|
||||||
(sequence-actions (transition-and-set-timers cleaned-seed-zone initial-timers)
|
(sequence-actions (transition-and-set-timers cleaned-seed-zone initial-timers)
|
||||||
;; TODO: consider deduping questions here too?
|
;; TODO: consider deduping questions here too?
|
||||||
(endpoint: zone : CompiledZone
|
(subscriber: CompiledZone `(debug-dump)
|
||||||
#:subscriber `(debug-dump)
|
(match-state zone
|
||||||
[`(debug-dump)
|
(on-message
|
||||||
(begin
|
[`(debug-dump)
|
||||||
(with-output-to-file "zone-proxy.zone"
|
(begin
|
||||||
(lambda ()
|
(with-output-to-file "zone-proxy.zone"
|
||||||
(write-bytes (bit-string->bytes (zone->bit-string zone))))
|
(lambda ()
|
||||||
#:mode 'binary
|
(write-bytes (bit-string->bytes (zone->bit-string zone))))
|
||||||
#:exists 'replace)
|
#:mode 'binary
|
||||||
(with-output-to-file "zone-proxy.dump"
|
#:exists 'replace)
|
||||||
(lambda ()
|
(with-output-to-file "zone-proxy.dump"
|
||||||
(display "----------------------------------------------------------------------\n")
|
(lambda ()
|
||||||
(display (seconds->date (current-seconds)))
|
(display "----------------------------------------------------------------------\n")
|
||||||
(newline)
|
(display (seconds->date (current-seconds)))
|
||||||
(for: ([name (in-hash-keys zone)])
|
(newline)
|
||||||
(define rrmap (hash-ref zone name))
|
(for: ([name (in-hash-keys zone)])
|
||||||
(for: ([rr (in-hash-keys rrmap)])
|
(define rrmap (hash-ref zone name))
|
||||||
(define expiry (hash-ref rrmap rr))
|
(for: ([rr (in-hash-keys rrmap)])
|
||||||
(write (list rr expiry))
|
(define expiry (hash-ref rrmap rr))
|
||||||
(newline)))
|
(write (list rr expiry))
|
||||||
(newline))
|
(newline)))
|
||||||
#:mode 'text
|
(newline))
|
||||||
#:exists 'append)
|
#:mode 'text
|
||||||
;; (with-output-to-file "zone-proxy.debug"
|
#:exists 'append)
|
||||||
;; (lambda ()
|
;; (with-output-to-file "zone-proxy.debug"
|
||||||
;; (display "----------------------------------------------------------------------\n")
|
;; (lambda ()
|
||||||
;; (display (seconds->date (current-seconds)))
|
;; (display "----------------------------------------------------------------------\n")
|
||||||
;; (newline)
|
;; (display (seconds->date (current-seconds)))
|
||||||
;; (pretty-write current-ground-transition))
|
;; (newline)
|
||||||
;; #:mode 'text
|
;; (pretty-write current-ground-transition))
|
||||||
;; #:exists 'append)
|
;; #:mode 'text
|
||||||
(transition: zone : CompiledZone))])
|
;; #:exists 'append)
|
||||||
(endpoint: zone : CompiledZone
|
(transition: zone : CompiledZone))])))
|
||||||
#:subscriber (question-pattern (wild) (wild) (wild) (wild))
|
(subscriber: CompiledZone (question-pattern (wild) (wild) (wild) (wild))
|
||||||
[(? question? q)
|
(match-state zone
|
||||||
(transition: zone : CompiledZone
|
(on-message
|
||||||
(cond
|
[(? question? q)
|
||||||
[(question-cyclic? q)
|
(transition: zone : CompiledZone
|
||||||
(log-warning (format "Cyclic question ~v" q))
|
(cond
|
||||||
(send-message (answered-question q (empty-complete-answer)))]
|
[(question-cyclic? q)
|
||||||
[(question-too-glueless? q)
|
(log-warning (format "Cyclic question ~v" q))
|
||||||
(log-warning (format "Overly-glueless question ~v" q))
|
(send-message (answered-question q (empty-complete-answer)))]
|
||||||
(spawn: #:debug-name (list 'glueless-question-handler-outer q)
|
[(question-too-glueless? q)
|
||||||
#:parent : CompiledZone
|
(log-warning (format "Overly-glueless question ~v" q))
|
||||||
#:child : Void
|
(name-process (list 'glueless-question-handler-outer q)
|
||||||
(glueless-question-handler roots-only q client-sock))]
|
(spawn: #:parent : CompiledZone
|
||||||
[else
|
#:child : Void
|
||||||
(spawn: #:debug-name (list 'question-handler q)
|
(glueless-question-handler roots-only q client-sock)))]
|
||||||
#:parent : CompiledZone
|
[else
|
||||||
#:child : QHState
|
(name-process (list 'question-handler q)
|
||||||
(question-handler zone q client-sock))]))])
|
(spawn: #:parent : CompiledZone
|
||||||
(endpoint: zone : CompiledZone
|
#:child : QHState
|
||||||
#:subscriber (network-reply-pattern (wild) (wild))
|
(question-handler zone q client-sock)))]))])))
|
||||||
[(network-reply _ answer)
|
(subscriber: CompiledZone (network-reply-pattern (wild) (wild))
|
||||||
(let-values (((new-zone timers) (incorporate-complete-answer answer zone #t)))
|
(match-state zone
|
||||||
(transition-and-set-timers new-zone timers))])
|
(on-message
|
||||||
(endpoint: zone : CompiledZone
|
[(network-reply _ answer)
|
||||||
#:subscriber (timer-expired-pattern (list 'check-dns-expiry (wild)) (wild))
|
(let-values (((new-zone timers) (incorporate-complete-answer answer zone #t)))
|
||||||
[(timer-expired (list 'check-dns-expiry (? domain? name)) (? number? now-msec))
|
(transition-and-set-timers new-zone timers))])))
|
||||||
(transition: (zone-expire-name zone name (/ now-msec 1000.0)) : CompiledZone)])))
|
(subscriber: CompiledZone (timer-expired-pattern (list 'check-dns-expiry (wild)) (wild))
|
||||||
|
(match-state zone
|
||||||
|
(on-message
|
||||||
|
[(timer-expired (list 'check-dns-expiry (? domain? name)) (? number? now-msec))
|
||||||
|
(transition: (zone-expire-name zone name (/ now-msec 1000.0)) : CompiledZone)])))))
|
||||||
|
|
||||||
(struct: question-state ([zone : CompiledZone]
|
(struct: question-state ([zone : CompiledZone]
|
||||||
[q : Question]
|
[q : Question]
|
||||||
|
|
@ -307,35 +319,39 @@
|
||||||
zone-origin
|
zone-origin
|
||||||
(map rr-rdata-domain-name (set->list nameserver-rrs))
|
(map rr-rdata-domain-name (set->list nameserver-rrs))
|
||||||
referral-id)
|
referral-id)
|
||||||
(endpoint: w : QHState
|
(name-endpoint referral-id
|
||||||
#:subscriber (network-reply-pattern referral-id (wild))
|
(subscriber: QHState (network-reply-pattern referral-id (wild))
|
||||||
#:name referral-id
|
(match-state w
|
||||||
[(network-reply (== referral-id) #f) ;; name-error/NXDOMAIN
|
(on-message
|
||||||
(transition: w : QHState
|
[(network-reply (== referral-id) #f) ;; name-error/NXDOMAIN
|
||||||
(delete-endpoint referral-id)
|
(transition: w : QHState
|
||||||
(send-message (answered-question q #f)))]
|
(delete-endpoint referral-id)
|
||||||
[(network-reply (== referral-id) ans)
|
(send-message (answered-question q #f)))]
|
||||||
(let-values (((new-zone ignored-timers) (incorporate-complete-answer ans zone #f)))
|
[(network-reply (== referral-id) ans)
|
||||||
(when (log-level? (current-logger) 'debug)
|
(let-values (((new-zone ignored-timers)
|
||||||
(log-debug (format "Referral ~v results in origin ~v:~n"
|
(incorporate-complete-answer ans zone #f)))
|
||||||
referral-id zone-origin))
|
(when (log-level? (current-logger) 'debug)
|
||||||
(for ([k (set-union (list->set (hash-keys zone))
|
(log-debug (format "Referral ~v results in origin ~v:~n"
|
||||||
(list->set (hash-keys new-zone)))]
|
referral-id zone-origin))
|
||||||
#:when (in-bailiwick? k zone-origin))
|
(for ([k (set-union (list->set (hash-keys zone))
|
||||||
(log-debug (format "Old ~v ~v~nNew ~v ~v"
|
(list->set (hash-keys new-zone)))]
|
||||||
k (hash-ref zone k (lambda () 'missing))
|
#:when (in-bailiwick? k zone-origin))
|
||||||
k (hash-ref new-zone k (lambda () 'missing)))))
|
(log-debug (format "Old ~v ~v~nNew ~v ~v"
|
||||||
(log-debug "=-=-=-=-=-="))
|
k (hash-ref zone k (lambda () 'missing))
|
||||||
(define nameserver-names
|
k (hash-ref new-zone k (lambda () 'missing)))))
|
||||||
(list->set
|
(log-debug "=-=-=-=-=-="))
|
||||||
(for/list: : (Listof DomainName) ([rr nameserver-rrs]) (rr-rdata-domain-name rr))))
|
(define nameserver-names
|
||||||
(sequence-actions
|
(list->set
|
||||||
(retry-question (struct-copy question-state w
|
(for/list: : (Listof DomainName)
|
||||||
[nameservers-tried (set-union nameservers-tried
|
([rr nameserver-rrs])
|
||||||
nameserver-names)]
|
(rr-rdata-domain-name rr))))
|
||||||
[zone new-zone]
|
(sequence-actions
|
||||||
[retry-count (+ old-retry-count 1)]))
|
(retry-question (struct-copy question-state w
|
||||||
(delete-endpoint referral-id)))]))]
|
[nameservers-tried (set-union nameservers-tried
|
||||||
|
nameserver-names)]
|
||||||
|
[zone new-zone]
|
||||||
|
[retry-count (+ old-retry-count 1)]))
|
||||||
|
(delete-endpoint referral-id)))])))))]
|
||||||
[(? complete-answer? ans)
|
[(? complete-answer? ans)
|
||||||
(transition: w : QHState (send-message (answered-question q ans)))]
|
(transition: w : QHState (send-message (answered-question q ans)))]
|
||||||
[(partial-answer base cnames)
|
[(partial-answer base cnames)
|
||||||
|
|
@ -345,19 +361,21 @@
|
||||||
;; TODO: record chains of CNAMEs to avoid pathologically-long chains
|
;; TODO: record chains of CNAMEs to avoid pathologically-long chains
|
||||||
(define cname-q (cname-question cname q))
|
(define cname-q (cname-question cname q))
|
||||||
(list (send-message cname-q)
|
(list (send-message cname-q)
|
||||||
(endpoint: (expanding-cnames q acc remaining) : QHState
|
(let-fresh (subscription-id)
|
||||||
#:subscriber (answered-question-pattern cname-q (wild))
|
(name-endpoint subscription-id
|
||||||
#:let-name subscription-id
|
(subscriber: QHState (answered-question-pattern cname-q (wild))
|
||||||
[(answered-question (== cname-q) ans)
|
(match-state (expanding-cnames q acc remaining)
|
||||||
(let ()
|
(on-message
|
||||||
(define new-acc (if ans (merge-answers acc ans) acc))
|
[(answered-question (== cname-q) ans)
|
||||||
(define new-remaining (- remaining 1))
|
(let ()
|
||||||
(define new-w (expanding-cnames q new-acc new-remaining))
|
(define new-acc (if ans (merge-answers acc ans) acc))
|
||||||
(transition: new-w : QHState
|
(define new-remaining (- remaining 1))
|
||||||
(delete-endpoint subscription-id)
|
(define new-w (expanding-cnames q new-acc new-remaining))
|
||||||
(if (zero? new-remaining)
|
(transition: new-w : QHState
|
||||||
(send-message (answered-question q new-acc))
|
(delete-endpoint subscription-id)
|
||||||
'())))])))
|
(if (zero? new-remaining)
|
||||||
|
(send-message (answered-question q new-acc))
|
||||||
|
'())))])))))))
|
||||||
cnames))])]))
|
cnames))])]))
|
||||||
|
|
||||||
(require "test-rrs.rkt")
|
(require "test-rrs.rkt")
|
||||||
|
|
|
||||||
72
tk-dns.rkt
72
tk-dns.rkt
|
|
@ -76,20 +76,20 @@
|
||||||
(: dns-read-driver : UdpAddress -> (Transition Void))
|
(: dns-read-driver : UdpAddress -> (Transition Void))
|
||||||
(define (dns-read-driver s)
|
(define (dns-read-driver s)
|
||||||
(transition: (void) : Void
|
(transition: (void) : Void
|
||||||
(at-meta-level
|
(at-meta-level: Void
|
||||||
(endpoint: : Void
|
(subscriber: Void (udp-packet-pattern (wild) s (wild))
|
||||||
#:subscriber (udp-packet-pattern (wild) s (wild))
|
(on-message
|
||||||
[(udp-packet source (== s) #"")
|
[(udp-packet source (== s) #"")
|
||||||
(begin (log-info "Debug dump packet received")
|
(begin (log-info "Debug dump packet received")
|
||||||
(send-message `(debug-dump)))]
|
(send-message `(debug-dump)))]
|
||||||
[(udp-packet source (== s) body)
|
[(udp-packet source (== s) body)
|
||||||
(send-message
|
(send-message
|
||||||
(with-handlers ((exn:fail? (lambda (e)
|
(with-handlers ((exn:fail? (lambda (e)
|
||||||
(bad-dns-packet body source s 'unparseable))))
|
(bad-dns-packet body source s 'unparseable))))
|
||||||
(define message (packet->dns-message body))
|
(define message (packet->dns-message body))
|
||||||
(case (dns-message-direction message)
|
(case (dns-message-direction message)
|
||||||
((request) (dns-request message source s))
|
((request) (dns-request message source s))
|
||||||
((response) (dns-reply message source s)))))]))))
|
((response) (dns-reply message source s)))))])))))
|
||||||
|
|
||||||
(: dns-write-driver : UdpAddress -> (Transition Void))
|
(: dns-write-driver : UdpAddress -> (Transition Void))
|
||||||
(define (dns-write-driver s)
|
(define (dns-write-driver s)
|
||||||
|
|
@ -97,31 +97,31 @@
|
||||||
(define (translate message sink)
|
(define (translate message sink)
|
||||||
(with-handlers ((exn:fail? (lambda (e)
|
(with-handlers ((exn:fail? (lambda (e)
|
||||||
(send-message (bad-dns-packet message s sink 'unencodable)))))
|
(send-message (bad-dns-packet message s sink 'unencodable)))))
|
||||||
(at-meta-level
|
(at-meta-level: Void
|
||||||
(send-message (udp-packet s sink (dns-message->packet message))))))
|
(send-message (udp-packet s sink (dns-message->packet message))))))
|
||||||
(transition: (void) : Void
|
(transition: (void) : Void
|
||||||
(endpoint: : Void
|
(subscriber: Void (dns-request-pattern (wild) s (wild))
|
||||||
#:subscriber (dns-request-pattern (wild) s (wild))
|
(on-message
|
||||||
[(dns-request message (== s) sink) (translate message sink)])
|
[(dns-request message (== s) sink) (translate message sink)]))
|
||||||
(endpoint: : Void
|
(subscriber: Void (dns-reply-pattern (wild) s (wild))
|
||||||
#:subscriber (dns-reply-pattern (wild) s (wild))
|
(on-message
|
||||||
[(dns-reply message (== s) sink) (translate message sink)])))
|
[(dns-reply message (== s) sink) (translate message sink)]))))
|
||||||
|
|
||||||
(: dns-spy : -> (Transition Void))
|
(: dns-spy : -> (Transition Void))
|
||||||
(define (dns-spy)
|
(define (dns-spy)
|
||||||
(transition: (void) : Void
|
(transition: (void) : Void
|
||||||
(endpoint: : Void
|
(observe-publishers: Void (wild)
|
||||||
#:subscriber (wild) #:observer
|
(on-message
|
||||||
[(dns-request message source sink)
|
[(dns-request message source sink)
|
||||||
(begin (log-info (format "DNS: ~v asks ~v ~v~n : ~v"
|
(begin (log-info (format "DNS: ~v asks ~v ~v~n : ~v"
|
||||||
source sink (dns-message-id message)
|
source sink (dns-message-id message)
|
||||||
(dns-message-questions message)))
|
(dns-message-questions message)))
|
||||||
(void))]
|
(void))]
|
||||||
[(dns-reply message source sink)
|
[(dns-reply message source sink)
|
||||||
(begin (log-info (format "DNS: ~v answers ~v~n : ~v"
|
(begin (log-info (format "DNS: ~v answers ~v~n : ~v"
|
||||||
source sink
|
source sink
|
||||||
message))
|
message))
|
||||||
(void))]
|
(void))]
|
||||||
[x
|
[x
|
||||||
(begin (log-info (format "DNS: ~v" x))
|
(begin (log-info (format "DNS: ~v" x))
|
||||||
(void))])))
|
(void))]))))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue