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