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

Progress on Syndicate conversion of proxy.rkt; doesn't run yet

This commit is contained in:
Tony Garnock-Jones 2016-09-07 06:33:16 +01:00
parent aea344fd81
commit 53af1e0dd5
3 changed files with 344 additions and 450 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

274
network-query.rkt
View File

@ -123,27 +123,10 @@
(define first-timeout 3) ;; seconds (define first-timeout 3) ;; seconds
;; A NetworkRequest is a (network-request UdpAddress Question
;; DomainName NEListOf<DomainName> UniqueID) representing the
;; parameters used to start and process a network query.
(struct network-request (client-socket question zone-origin server-names unique-id) #:transparent)
;; A NetworkReply is a (network-reply UniqueID Maybe<CompleteAnswer>) ;; A NetworkReply is a (network-reply UniqueID Maybe<CompleteAnswer>)
;; representing the final result of a network query. ;; representing the final result of a network query.
(struct network-reply (unique-id answer) #:transparent) (struct network-reply (unique-id answer) #:transparent)
;; A NetworkQueryState is a (network-query-state NetworkRequest
;; Integer Map<DomainName,ListOf<UdpAddress>> ListOf<UdpAddress>
;; Maybe<DomainName> ListOf<DomainName>), representing an in-progress
;; DNS network query.
(struct network-query-state (request
timeout
known-addresses
remaining-addresses
current-name
remaining-names)
#:transparent)
;; (: next-timeout : Natural -> (Option Natural)) ;; (: next-timeout : Natural -> (Option Natural))
(define (next-timeout timeout) (define (next-timeout timeout)
(cond (cond
@ -210,9 +193,9 @@
(f (dns-message-additional message))))] (f (dns-message-additional message))))]
[(name-error) #f] [(name-error) #f]
[else [else
(log-info (format "Abnormal response-code ~v in response to questions ~v" (log-info "Abnormal response-code ~v in response to questions ~v"
(dns-message-response-code message) (dns-message-response-code message)
(dns-message-questions message))) (dns-message-questions message))
'bad-answer])) 'bad-answer]))
;; (: ip->host-name : IPv4 -> String) ;; (: ip->host-name : IPv4 -> String)
@ -226,152 +209,113 @@
;; (: network-query : (All (ParentState) ;; (: network-query : (All (ParentState)
;; UdpAddress Question DomainName (Listof DomainName) Any -> ;; UdpAddress Question DomainName (Listof DomainName) Any ->
;; (Action ParentState))) ;; Void))
(define (network-query s q zone-origin server-names unique-id) (define (network-query s q zone-origin server-names unique-id)
(spawn #:name (list 'network-query q) (actor*
(try-next-server #:name (list 'network-query q)
(network-query-state (network-request s q zone-origin server-names unique-id) (field [timeout first-timeout]
first-timeout [known-addresses #hash()] ;; Hash DomainName (Listof UdpAddress)
#hash() [remaining-addresses '()] ;; Listof UdpAddress
'() [current-name #f] ;; Option DomainName
#f [remaining-names server-names]) ;; Listof DomainName
server-names))))
;; (: try-next-server : NetworkQueryState -> (Transition NetworkQueryState)) (define (on-answer ans server-ip)
(define (try-next-server w) (match ans
(define timeout (network-query-state-timeout w)) ['bad-answer ;; can come from filter-dns-reply
(if (not timeout) (try-next-server)]
;; No more timeouts to try, so give up. ['lame-delegation ;; can come from filter-dns-reply
(on-answer w (empty-complete-answer) #f) (log-info "Lame delegation received from ~v (at ~v) in bailiwick ~v in response to ~v"
(match w (current-name)
[(network-query-state req _ _ '() _ '()) server-ip
;; No more addresses to try with this timeout. Refill the list zone-origin
;; and bump the timeout and retry. q)
;; TODO: randomize ordering of servers in list. (Don't forget the initial fill.) (when (and (current-name) server-ip)
(try-next-server (struct-copy network-query-state w ;; Actually remove the offending IP address so it's never tried again.
[timeout (next-timeout timeout)] (known-addresses (hash-update (known-addresses)
[remaining-addresses '()] (current-name)
[current-name #f] (lambda (addrs) (remove server-ip addrs)))))
[remaining-names (network-request-server-names req)]))] (try-next-server)]
[(network-query-state req _ known-addresses '() _ (cons current-name remaining-names)) [(and (or (? complete-answer?) #f) ans)
(if (hash-has-key? known-addresses current-name) (send! (network-reply unique-id ans))]))
(try-next-server (struct-copy network-query-state w
[remaining-addresses (hash-ref known-addresses current-name)]
[current-name current-name]
[remaining-names remaining-names]))
(let ((subq (ns-question current-name (network-request-question req))))
(transition (struct-copy network-query-state w
[current-name current-name]
[remaining-names remaining-names])
(send-message subq)
(let-fresh (subq-id)
(name-endpoint subq-id
(subscriber (answered-question 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
(send-message `(request ,rpc-id allocate-query-id))
(name-endpoint rpc-id
(subscriber `(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) (define (try-next-server)
;; -> (Transition NetworkQueryState)) (if (not (timeout))
(define (on-answer w ans server-ip) ;; No more timeouts to try, so give up.
(match ans (on-answer (empty-complete-answer) #f)
['bad-answer ;; can come from filter-dns-reply (match (remaining-addresses)
(try-next-server w)] ['()
['lame-delegation ;; can come from filter-dns-reply (match (remaining-names)
(match-define (network-query-state req _ known-addresses _ current-name _) w) ['()
(match-define (network-request _ q zone-origin _ _) req) ;; No more addresses to try with this timeout. Refill the list
(log-info (format "Lame delegation received from ~v (at ~v) in bailiwick ~v in response to ~v" ;; and bump the timeout and retry.
current-name ;; TODO: randomize ordering of servers in list. (Don't forget the initial fill.)
server-ip (timeout (next-timeout (timeout)))
zone-origin (current-name #f)
q)) (remaining-names server-names)
(try-next-server (if (and current-name server-ip) (try-next-server)]
;; Actually remove the offending IP address so it's never tried again. [(cons next-name new-remaining-names)
(struct-copy network-query-state w (current-name next-name)
[known-addresses (hash-update known-addresses (remaining-names new-remaining-names)
current-name (if (hash-has-key? (known-addresses) next-name)
(lambda (addrs) (begin (remaining-addresses (hash-ref (known-addresses) (current-name)))
(remove server-ip addrs)))]) (try-next-server))
w))] (let ((subq (ns-question next-name q)))
[(and (or (? complete-answer?) #f) ans) (react (on-start (send! subq))
(transition w (stop-when (message (answered-question subq $ans))
(send-message (network-reply (network-request-unique-id (network-query-state-request w)) (define ips
ans)))])) (for/list [(a (extract-addresses next-name ans))]
(make-dns-address a)))
(known-addresses (hash-set (known-addresses) next-name ips))
(remaining-addresses ips)
(try-next-server)))))])]
[(cons current-ip new-remaining-ips)
(remaining-addresses new-remaining-ips)
(define rpc-id (gensym 'network-query/allocate-query-id))
(react (on-start (send! `(request ,rpc-id allocate-query-id)))
(stop-when (message `(reply ,rpc-id ,(? exact-nonnegative-integer? $id)))
(remaining-addresses new-remaining-ips)
(send-request id current-ip)))])))
;; (: send-request : NetworkQueryState Nonnegative-Integer Natural UdpAddress (define (send-request query-id server-ip)
;; -> (Transition NetworkQueryState)) (define query (make-dns-query-message q query-id))
(define (send-request w query-id timeout server-ip) (define reply-wait-id (list s query-id 'reply-wait))
(match-define (network-request s q zone-origin _ _) (network-query-state-request w)) (define timeout-id (list s query-id 'timeout))
(define query (make-dns-query-message q query-id)) (define start-time (current-inexact-milliseconds))
(define reply-wait-id (list s query-id 'reply-wait)) (log-debug "Sending ~v ~v to ~v ~v with ~v seconds of timeout"
(define timeout-id (list s query-id 'timeout)) q query-id
(define start-time (current-inexact-milliseconds)) zone-origin server-ip
(log-debug (format "Sending ~v ~v to ~v ~v with ~v seconds of timeout" (timeout))
q query-id ;; NB: ANALYSIS: Previous implementation of this used a
zone-origin server-ip ;; quasi-join, where one endpoint deleted the other. Here the two
timeout)) ;; stop-when clauses do a similar job. Also, we can pull the
(transition w ;; `release-query-id` send up to an on-stop clause.
(send-message (dns-request query s server-ip)) (react (on-start
(send-message (set-timer timeout-id (* timeout 1000) 'relative)) (send! (dns-request query s server-ip))
;; TODO: Restore this to a "join" when proper pattern-unions are implemented (send! (set-timer timeout-id (* (timeout) 1000) 'relative)))
(name-endpoint timeout-id (on-stop
(subscriber (timer-expired timeout-id (wild)) (send! (list 'release-query-id query-id)))
(match-state w (stop-when (message (timer-expired timeout-id _))
(on-message (log-debug "Timed out ~v ~v to ~v ~v after ~v seconds"
[(timer-expired (== timeout-id) _) q query-id
(begin zone-origin server-ip
(log-debug (format "Timed out ~v ~v to ~v ~v after ~v seconds" (timeout))
q query-id (try-next-server))
zone-origin server-ip (stop-when (message (dns-reply
timeout)) (? (lambda (m) (= (dns-message-id m)
(sequence-actions (try-next-server w) (dns-message-id query)))
(delete-endpoint timeout-id) $reply-message)
(delete-endpoint reply-wait-id) $source
(send-message (list 'release-query-id query-id))))])))) s))
(name-endpoint reply-wait-id ;; TODO: maybe receive only specifically from the queried IP address?
(subscriber (dns-reply (wild) (wild) s) (log-debug "Answer to ~v from ~v ~v in ~v ms~n-- Answers: ~v~n-- Authorities: ~v~n-- Additional: ~v"
(match-state w q zone-origin server-ip
(on-message (inexact->exact (round (- (current-inexact-milliseconds) start-time)))
[(dns-reply reply-message source (== s)) (dns-message-answers reply-message)
;; TODO: maybe receive only specifically from the queried IP address? (dns-message-authorities reply-message)
(begin (dns-message-additional reply-message))
(log-debug (on-answer (filter-dns-reply q reply-message zone-origin) server-ip))))
(format
"Answer to ~v from ~v ~v in ~v ms~n-- Answers: ~v~n-- Authorities: ~v~n-- Additional: ~v" (try-next-server)))
q zone-origin server-ip
(inexact->exact (round (- (current-inexact-milliseconds) start-time))) (define ((dns-message-id-matches? expected) m)
(dns-message-answers reply-message) (= (dns-message-id m) expected))
(dns-message-authorities reply-message)
(dns-message-additional reply-message)))
(if (not (= (dns-message-id reply-message) (dns-message-id query)))
(transition w)
(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)))))]))))))

489
proxy.rkt
View File

@ -28,7 +28,7 @@
(require "zonedb.rkt") (require "zonedb.rkt")
(require "network-query.rkt") (require "network-query.rkt")
(require "resolver.rkt") (require "resolver.rkt")
(require syndicate) (require (except-in syndicate dataspace assert))
(require syndicate/actor) (require syndicate/actor)
(require syndicate/drivers/timer) (require syndicate/drivers/timer)
(require syndicate/drivers/udp) (require syndicate/drivers/udp)
@ -49,306 +49,253 @@
(log-info "Ready.") (log-info "Ready.")
(ground-vm (run-ground
(generic-spy 'UDP) (spawn-timer-driver)
(udp-driver) (spawn-udp-driver)
(timer-driver) (dataspace #:name 'dns-vm
(spawn-vm #:debug-name 'dns-vm (dns-spy)
(name-process 'dns-spy (spawn (dns-spy))) (actor #:name 'timer-relay:dns
(timer-relay 'timer-relay:dns) (on (message (inbound ($ m (timer-expired _ _)))) (send! m))
(name-process 'query-id-allocator (spawn (query-id-allocator))) (on (message ($ m (set-timer _ _ _))) (send! (outbound m))))
(name-process 'server-dns-reader (spawn (dns-read-driver server-addr))) (query-id-allocator)
(name-process 'server-dns-writer (spawn (dns-write-driver server-addr))) (dns-read-driver server-addr)
(name-process 'client-dns-reader (spawn (dns-read-driver client-addr))) (dns-write-driver server-addr)
(name-process 'client-dns-writer (spawn (dns-write-driver client-addr))) (dns-read-driver client-addr)
(name-process 'packet-dispatcher (spawn (packet-dispatcher server-addr))) (dns-write-driver client-addr)
(name-process 'question-dispatcher (spawn (question-dispatcher zone (packet-dispatcher server-addr)
roots-only (question-dispatcher zone roots-only client-addr)
client-addr)))))) (forever))))
;; (: query-id-allocator : -> (Transition (Setof Natural))) ;; (: query-id-allocator : -> Void)
(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 (set) ;; all active query IDs (actor #:name 'query-id-allocator
(subscriber `(request ,(wild) allocate-query-id) (field [allocated (set)])
(match-state allocated (on (message `(request ,$reply-addr allocate-query-id))
(on-message (let recheck ()
[`(request ,reply-addr allocate-query-id) (define n (random 65536))
(let recheck () (if (set-member? (allocated) n)
(define n (random 65536)) (recheck)
(if (set-member? allocated n) (begin (allocated (set-add (allocated) n))
(recheck) (send! `(reply ,reply-addr ,n))))))
(transition (set-add allocated n) (on (message `(release-query-id ,(? exact-nonnegative-integer? $n)))
(send-message `(reply ,reply-addr ,n)))))]))) (allocated (set-remove (allocated) n)))))
(subscriber `(release-query-id ,(wild))
(match-state allocated
(on-message
[`(release-query-id ,(? exact-nonnegative-integer? n))
(transition (set-remove allocated n))])))))
;; (: packet-dispatcher : UdpAddress -> (Transition (Setof ActiveRequest))) ;; (: packet-dispatcher : UdpAddress -> Void)
(define (packet-dispatcher s) (define (packet-dispatcher s)
(transition (set) (actor #:name 'packet-dispatcher
(subscriber (bad-dns-packet (wild) (wild) (wild) (wild)) (field [old-active-requests (set)])
(on-message [p (begin (log-error (pretty-format p)) '())])) (on (message ($ p (bad-dns-packet _ _ _ _)))
(subscriber (dns-request (wild) (wild) s) (log-error "~a" (pretty-format p)))
(match-state old-active-requests (on (message ($ r (dns-request $m $source s)))
(on-message ;; ^ We only listen for requests on our server socket
[(and r (dns-request m source (== s))) (define req-id (active-request source (dns-message-id m)))
;; ^ We only listen for requests on our server socket ;; TODO: when we have presence/error-handling, remove req-id
(let ((req-id (active-request source (dns-message-id m)))) ;; from active requests once request-handler pseudothread exits.
;; TODO: when we have presence/error-handling, remove req-id (when (not (set-member? (old-active-requests) req-id))
;; from active requests once request-handler pseudothread exits. ;; ^ ignore retransmitted duplicates
(if (set-member? old-active-requests req-id) (old-active-requests (set-add (old-active-requests) req-id))
(transition old-active-requests) (packet-relay req-id r)))
;; ^ ignore retransmitted duplicates (on (message ($ r (dns-reply $m s $sink)))
(transition (set-add old-active-requests req-id) (define req-id (active-request sink (dns-message-id m)))
(name-process (list 'packet-relay req-id) (old-active-requests (set-remove (old-active-requests) req-id)))))
(spawn (packet-relay req-id r))))))])))
(subscriber (dns-reply (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)))])))))
;; (: packet-relay : ActiveRequest DNSRequest -> (Transition Void)) ;; (: packet-relay : ActiveRequest DNSRequest -> Void)
(define (packet-relay req-id request) (define (packet-relay req-id request)
(match-define (dns-request request-message request-source request-sink) request) (match-define (dns-request request-message request-source request-sink) request)
;; (: answer->reply : (Option Question) (Option CompleteAnswer) -> DNSReply) ;; (: answer->reply : (Option Question) (Option CompleteAnswer) -> DNSReply)
(define (answer->reply q a) (define (answer->reply q a)
(define-values (response-code ns us ds) (define-values (response-code ns us ds)
(match a (match a
[#f [#f
(values 'name-error '() '() '())] (values 'name-error '() '() '())]
[(complete-answer ns us ds) [(complete-answer ns us ds)
(values 'no-error (rr-set->list ns) (rr-set->list us) (rr-set->list ds))])) (values 'no-error (rr-set->list ns) (rr-set->list us) (rr-set->list ds))]))
(dns-reply (dns-reply
(dns-message (dns-message-id request-message) (dns-message (dns-message-id request-message)
'response 'response
'query 'query
'non-authoritative 'non-authoritative
'not-truncated 'not-truncated
(dns-message-recursion-desired request-message) (dns-message-recursion-desired request-message)
'recursion-available 'recursion-available
response-code response-code
(if q (list q) '()) (if q (list q) '())
ns ns
us us
ds) ds)
request-sink request-sink
request-source)) request-source))
;; TODO: pay attention to recursion-desired flag
(match (dns-message-questions request-message)
['()
;; No questions!
(transition/no-state
(send-message (answer->reply #f (empty-complete-answer))))]
[(cons original-question _)
;; At least one question
(log-debug (format "Looking up ~v with query id ~v"
original-question (dns-message-id request-message)))
(transition/no-state
(send-message original-question)
(let-fresh (wait-id)
(name-endpoint wait-id
(subscriber (answered-question 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)) (actor*
#:name (list 'packet-relay req-id)
;; TODO: pay attention to recursion-desired flag
(match (dns-message-questions request-message)
['()
;; No questions!
(send! (answer->reply #f (empty-complete-answer)))]
[(cons original-question _)
;; At least one question
(log-debug (format "Looking up ~v with query id ~v"
original-question (dns-message-id request-message)))
(send! original-question)
(react (stop-when (message (answered-question original-question $answer))
(log-debug "Final answer to ~v with query id ~v is ~v"
original-question
(dns-message-id request-message)
answer)
(send! (answer->reply original-question answer))))])))
;; (: glueless-question-handler : CompiledZone Question UdpAddress -> 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 (actor #:name (list 'glueless-question-handler q)
(let-fresh (relay) (stop-when (message (answered-question restarted-question $ans))
(name-endpoint relay ;; We got the answer to our restarted question; now transform
(subscriber (answered-question restarted-question (wild)) ;; it into an answer to the original question, to unblock the
(on-message ;; original questioner.
[(answered-question (== restarted-question) ans) (send! (answered-question q ans)))
;; We got the answer to our restarted question; now transform (on-start (question-handler roots-only-zone restarted-question client-sock))))
;; 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 (question-handler roots-only-zone restarted-question client-sock)))))
;; (: question-dispatcher : CompiledZone CompiledZone UdpAddress -> (Transition CompiledZone)) ;; (: question-dispatcher : CompiledZone CompiledZone UdpAddress -> Void)
(define (question-dispatcher seed-zone roots-only client-sock) (define (question-dispatcher seed-zone roots-only client-sock)
;; (: transition-and-set-timers : CompiledZone (Setof (Pairof DomainName Real))
;; -> (Transition CompiledZone))
(define (transition-and-set-timers new-zone timers)
(transition new-zone
(for/list ([timerspec timers])
(match-define (cons name ttl) timerspec)
(send-message (set-timer (list 'check-dns-expiry name) (* ttl 1000) 'relative)))))
(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) (actor #:name 'question-dispatcher
;; TODO: consider deduping questions here too? (field [zone cleaned-seed-zone])
(subscriber `(debug-dump) (on-start (set-timers! initial-timers))
(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))])))
(subscriber (question (wild) (wild) (wild) (wild))
(match-state zone
(on-message
[(? question? q)
(transition zone
(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 (glueless-question-handler roots-only q client-sock)))]
[else
(name-process (list 'question-handler q)
(spawn (question-handler zone q client-sock)))]))])))
(subscriber (network-reply (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 (timer-expired (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)))])))))
(struct question-state (zone q client-sock nameservers-tried retry-count) #:transparent) (define (set-timers! timers)
(for/list ([timerspec timers])
(match-define (cons name ttl) timerspec)
(send! (set-timer (list 'check-dns-expiry name) (* ttl 1000) 'relative))))
(struct expanding-cnames (q accumulator remaining-count) #:transparent) ;; TODO: consider deduping questions here too?
;; (define-type QHState (U QuestionState ExpandingCNAMEs)) (on (message `(debug-dump))
(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)
)
;; (: question-handler : CompiledZone Question UdpAddress -> (Transition QHState)) (on (message ($ q (question _ _ _ _)))
(define (question-handler zone q client-sock) (cond
(retry-question (question-state zone q client-sock (set) 0))) [(question-cyclic? q)
(log-warning (format "Cyclic question ~v" q))
(send! (answered-question q (empty-complete-answer)))]
[(question-too-glueless? q)
(log-warning (format "Overly-glueless question ~v" q))
(glueless-question-handler roots-only q client-sock)]
[else
(question-handler (zone) q client-sock)]))
;; (: send-empty-reply : QHState Question -> (Transition QHState)) (on (message (network-reply _ $answer))
(define (send-empty-reply w q) (define-values (new-zone timers) (incorporate-complete-answer answer (zone) #t))
(transition w (send-message (answered-question q (empty-complete-answer))))) (zone new-zone)
(set-timers! timers))
;; (: retry-question : QHState -> (Transition QHState)) (on (message (timer-expired (list 'check-dns-expiry (? domain? $name))
(define (retry-question w) (? number? $now-msec)))
(match w (zone (zone-expire-name (zone) name (/ now-msec 1000.0))))))
[(question-state _ q _ _ 20) ;; TODO: is this a sensible limit?
;; Too many retries, i.e. too many referrals. ;; (: send-empty-reply! : Question -> Void)
(log-error (format "Too many retries: ~v" w)) (define (send-empty-reply! q)
(send-empty-reply w q)] (send! (answered-question q (empty-complete-answer))))
[(question-state zone q client-sock nameservers-tried old-retry-count)
;; Credit remaining. Try once more (perhaps for the first time, in fact). ;; (: question-handler : CompiledZone Question UdpAddress -> Void)
(define resolution-result (resolve-from-zone q zone #f nameservers-tried)) (define (question-handler zone0 q client-sock)
(log-debug (format "Resolution result: ~v" resolution-result)) (actor*
(match resolution-result #:name (list 'question-handler q)
[#f ;; We're not authoritative so this is just a signal that we can't answer usefully (let retry-question ((zone zone0)
(send-empty-reply w q)] (nameservers-tried (set))
[(referral zone-origin nameserver-rrs _) (retry-count 0))
(define referral-id (gensym 'referral)) (if (= retry-count 20) ;; TODO: is this a sensible limit?
(log-debug (format "Referral for ~v id ~v to ~v servers ~v" ;; Too many retries, i.e. too many referrals.
q referral-id (domain-labels zone-origin) (begin (log-error (format "Too many retries: ~v" q))
(map domain-labels (set-map nameserver-rrs rr-rdata-domain-name)))) (send-empty-reply! q))
(transition w ;; Credit remaining. Try once more (perhaps for the first time, in fact).
(network-query client-sock (let ((resolution-result (resolve-from-zone q zone #f nameservers-tried)))
q (log-debug (format "Resolution result: ~v" resolution-result))
zone-origin
(map rr-rdata-domain-name (set->list nameserver-rrs)) (match resolution-result
referral-id) [#f ;; We're not authoritative so this is just a signal that we can't answer usefully
(name-endpoint referral-id (send-empty-reply! q)]
(subscriber (network-reply referral-id (wild))
(match-state w [(referral zone-origin nameserver-rrs _)
(on-message (define referral-id (gensym 'referral))
[(network-reply (== referral-id) #f) ;; name-error/NXDOMAIN (log-debug (format "Referral for ~v id ~v to ~v servers ~v"
(transition w q referral-id (domain-labels zone-origin)
(delete-endpoint referral-id) (map domain-labels (set-map nameserver-rrs rr-rdata-domain-name))))
(send-message (answered-question q #f)))] (network-query client-sock
[(network-reply (== referral-id) ans) q
(let-values (((new-zone ignored-timers) zone-origin
(incorporate-complete-answer ans zone #f))) (map rr-rdata-domain-name (set->list nameserver-rrs))
(when (log-level? (current-logger) 'debug) referral-id)
(log-debug (format "Referral ~v results in origin ~v:~n" (react (stop-when
referral-id zone-origin)) (message (network-reply referral-id $ans))
(for ([k (set-union (list->set (hash-keys zone)) (cond [(not ans) ;; name-error/NXDOMAIN
(list->set (hash-keys new-zone)))] (send! (answered-question q #f))]
#:when (in-bailiwick? k zone-origin)) [else
(log-debug (format "Old ~v ~v~nNew ~v ~v" (define-values (new-zone _ignored-timers)
k (hash-ref zone k (lambda () 'missing)) (incorporate-complete-answer ans zone #f))
k (hash-ref new-zone k (lambda () 'missing))))) (when (log-level? (current-logger) 'debug)
(log-debug "=-=-=-=-=-=")) (log-debug "Referral ~v results in origin ~v:~n"
(define nameserver-names referral-id zone-origin)
(list->set (for ([k (set-union (list->set (hash-keys zone))
(for/list ([rr nameserver-rrs]) (list->set (hash-keys new-zone)))]
(rr-rdata-domain-name rr)))) #:when (in-bailiwick? k zone-origin))
(sequence-actions (log-debug "Old ~v ~v~nNew ~v ~v"
(retry-question (struct-copy question-state w k (hash-ref zone k (lambda () 'missing))
[nameservers-tried (set-union nameservers-tried k (hash-ref new-zone k (lambda () 'missing))))
nameserver-names)] (log-debug "=-=-=-=-=-="))
[zone new-zone] (define nameserver-names
[retry-count (+ old-retry-count 1)])) (for/set ([rr nameserver-rrs]) (rr-rdata-domain-name rr)))
(delete-endpoint referral-id)))])))))] (retry-question new-zone
[(? complete-answer? ans) (set-union nameservers-tried nameserver-names)
(transition w (send-message (answered-question q ans)))] (+ retry-count 1))])))]
[(partial-answer base cnames)
(transition (expanding-cnames q base (length cnames)) [(? complete-answer? ans)
(map (lambda (cname) (send! (answered-question q ans))]
;; TODO: record chains of CNAMEs to avoid pathologically-long chains
(define cname-q (cname-question cname q)) [(partial-answer base cnames)
(list (send-message cname-q) ;; TODO: record chains of CNAMEs to avoid pathologically-long chains
(let-fresh (subscription-id) (react (field [acc base]
(name-endpoint subscription-id [remaining (length cnames)])
(subscriber (answered-question cname-q (wild)) (on-start (for [(cname cnames)]
(match-state (expanding-cnames q acc remaining) (define cname-q (cname-question cname q))
(on-message (react (on-start (send! cname-q))
[(answered-question (== cname-q) ans) (stop-when (message (answered-question cname-q $ans))
(let () (acc (if ans (merge-answers (acc) ans) (acc)))
(define new-acc (if ans (merge-answers acc ans) acc)) (remaining (- (remaining) 1))))))
(define new-remaining (- remaining 1)) (stop-when (rising-edge (zero? (remaining)))
(define new-w (expanding-cnames q new-acc new-remaining)) (send! (answered-question q (acc)))))]))))))
(transition new-w
(delete-endpoint subscription-id)
(if (zero? new-remaining)
(send-message (answered-question q new-acc))
'())))])))))))
cnames))])]))
(require "test-rrs.rkt") (require "test-rrs.rkt")
(require racket/file) (require racket/file)

31
tk-dns.rkt
View File

@ -39,31 +39,34 @@
(define (dns-read-driver s) (define (dns-read-driver s)
(actor (actor
#:name (list 'dns-read-driver s)
(on (message (inbound (udp-packet $source s #""))) (on (message (inbound (udp-packet $source s #"")))
(log-info "Debug dump packet received") (log-info "Debug dump packet received")
(send! `(debug-dump))) (send! `(debug-dump)))
(on (message (inbound (udp-packet $source s $body))) (on (message (inbound (udp-packet $source s $body)))
(send! (when (positive? (bytes-length body))
(with-handlers ((exn:fail? (lambda (e) (send!
(bad-dns-packet body source s 'unparseable)))) (with-handlers ((exn:fail? (lambda (e)
(define message (packet->dns-message body)) (bad-dns-packet body source s 'unparseable))))
(case (dns-message-direction message) (define message (packet->dns-message body))
((request) (dns-request message source s)) (case (dns-message-direction message)
((response) (dns-reply message source s)))))))) ((request) (dns-request message source s))
((response) (dns-reply message source s)))))))))
(define (translate message s sink) (define (translate message s sink)
(with-handlers ((exn:fail? (lambda (e) (with-handlers ((exn:fail? (lambda (e) (bad-dns-packet message s sink 'unencodable))))
(send! (bad-dns-packet message s sink 'unencodable))))) (outbound (udp-packet s sink (dns-message->packet message)))))
(send! (outbound (udp-packet s sink (dns-message->packet message))))))
(define (dns-write-driver s) (define (dns-write-driver s)
(actor (on (message (dns-request $message s $sink)) (actor #:name (list 'dns-write-driver s)
(translate message s sink)) (on (message (dns-request $message s $sink))
(send! (translate message s sink)))
(on (message (dns-reply $message s $sink)) (on (message (dns-reply $message s $sink))
(translate message s sink)))) (send! (translate message s sink)))))
(define (dns-spy) (define (dns-spy)
(actor (on (message (dns-request $message $source $sink)) (actor #:name 'dns-spy
(on (message (dns-request $message $source $sink))
(log-info (format "DNS: ~v asks ~v ~v~n : ~v" (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))))