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

WIP toward TR proxy

This commit is contained in:
Tony Garnock-Jones 2013-03-20 11:01:03 -04:00
parent 9473d1e78d
commit 7653cf545a
1 changed files with 32 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
proxy.rkt
View File

@ -37,16 +37,16 @@
(udp-driver)
(timer-driver)
(nested-vm #:debug-name 'dns-vm
(dns-spy)
(timer-relay 'timer-relay:dns)
(spawn #:debug-name 'query-id-allocator #:child (query-id-allocator))
(spawn #:debug-name 'server-dns-reader #:child (dns-read-driver server-addr))
(spawn #:debug-name 'server-dns-writer #:child (dns-write-driver server-addr))
(spawn #:debug-name 'client-dns-reader #:child (dns-read-driver client-addr))
(spawn #:debug-name 'client-dns-writer #:child (dns-write-driver client-addr))
(spawn #:debug-name 'packet-dispatcher #:child (packet-dispatcher server-addr))
(spawn #:debug-name 'question-dispatcher
#:child (question-dispatcher zone roots-only client-addr)))))
(spawn #:debug-name 'dns-spy #:child (dns-spy))
(timer-relay 'timer-relay:dns)
(spawn #:debug-name 'query-id-allocator #:child (query-id-allocator))
(spawn #:debug-name 'server-dns-reader #:child (dns-read-driver server-addr))
(spawn #:debug-name 'server-dns-writer #:child (dns-write-driver server-addr))
(spawn #:debug-name 'client-dns-reader #:child (dns-read-driver client-addr))
(spawn #:debug-name 'client-dns-writer #:child (dns-write-driver client-addr))
(spawn #:debug-name 'packet-dispatcher #:child (packet-dispatcher server-addr))
(spawn #:debug-name 'question-dispatcher
#:child (question-dispatcher zone roots-only client-addr)))))
(define (query-id-allocator)
;; TODO: track how many are allocated and throttle requests if too
@ -68,11 +68,11 @@
(define (packet-dispatcher s)
(transition (set) ;; SetOf<ActiveRequest>
(endpoint #:subscriber (bad-dns-packet (wild) (wild) (wild) (wild))
(endpoint #:subscriber (bad-dns-packet-repr (wild) (wild) (wild) (wild))
[p (begin (log-error (pretty-format p)) '())])
(endpoint #:subscriber (dns-request (wild) (wild) s)
(endpoint #:subscriber (dns-request-repr (wild) (wild) s)
#:state old-active-requests
[(and r (dns-request m source (== s))) ;; We only listen for requests on our server socket
[(and r (dns-request-repr 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.
@ -81,14 +81,14 @@
(transition (set-add old-active-requests req-id)
(spawn #:debug-name (list 'packet-relay req-id)
#:child (packet-relay req-id r)))))])
(endpoint #:subscriber (dns-reply (wild) s (wild))
(endpoint #:subscriber (dns-reply-repr (wild) s (wild))
#:state old-active-requests
[(and r (dns-reply m (== s) sink))
[(and r (dns-reply-repr m (== s) sink))
(let ((req-id (active-request sink (dns-message-id m))))
(transition (set-remove old-active-requests req-id)))])))
(define (packet-relay req-id request)
(match-define (dns-request request-message request-source request-sink) request)
(match-define (dns-request-repr request-message request-source request-sink) request)
(define (answer->reply q a)
(define-values (response-code ns us ds)
(match a
@ -96,20 +96,21 @@
(values 'name-error '() '() '())]
[(complete-answer ns us ds)
(values 'no-error (rr-set->list ns) (rr-set->list us) (rr-set->list ds))]))
(dns-reply (dns-message (dns-message-id request-message)
'response
'query
'non-authoritative
'not-truncated
(dns-message-recursion-desired request-message)
'recursion-available
response-code
(if q (list q) '())
ns
us
ds)
request-sink
request-source))
(dns-reply-repr
(dns-message (dns-message-id request-message)
'response
'query
'non-authoritative
'not-truncated
(dns-message-recursion-desired request-message)
'recursion-available
response-code
(if q (list q) '())
ns
us
ds)
request-sink
request-source))
;; TODO: pay attention to recursion-desired flag
(match (dns-message-questions request-message)
['()
@ -189,7 +190,7 @@
;; #:mode 'text
;; #:exists 'append)
'())])
(endpoint #:subscriber (question (wild) (wild) (wild) (wild))
(endpoint #:subscriber (question-repr (wild) (wild) (wild) (wild))
#:state zone
[(? question? q)
(transition zone