From b7bdb4065e41cfc736d83afcc7edb024997a746a Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 6 Jun 2016 17:07:33 -0400 Subject: [PATCH] Initial progress. driver.rkt runs; now on proxy.rkt --- README.md | 6 ++-- api-untyped.rkt | 7 +--- api.rkt | 3 +- driver.rkt | 28 ++++++++-------- network-query.rkt | 22 ++++++------- proxy.rkt | 8 ++--- tk-dns.rkt | 83 +++++++++++++++++++---------------------------- 7 files changed, 67 insertions(+), 90 deletions(-) diff --git a/README.md b/README.md index e97cbd3..5472577 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ This is a [Racket](http://racket-lang.org/) implementation of a DNS server and iterative resolver. It's written to work with -[Marketplace](https://github.com/tonyg/marketplace), but could readily +[Syndicate](https://github.com/tonyg/syndicate), but could readily be adapted to work with other I/O substrates. (It originally used Racket's `sync` and events directly.) @@ -18,9 +18,9 @@ equal to Racket 6.0 should work. Racket releases can be downloaded Once you have Racket installed, - raco pkg install marketplace bitsyntax + raco pkg install syndicate bitsyntax -to install Marketplace (note: will take a long time) and +to install Syndicate and [bitsyntax](https://github.com/tonyg/racket-bitsyntax/), and then raco make driver.rkt proxy.rkt diff --git a/api-untyped.rkt b/api-untyped.rkt index 4c9dce1..4ec6964 100644 --- a/api-untyped.rkt +++ b/api-untyped.rkt @@ -20,8 +20,6 @@ ;;; along with marketplace-dns. If not, see ;;; . -(require marketplace/struct-map) - (provide (struct-out domain) downcase-labels make-domain) @@ -37,10 +35,7 @@ (struct domain (labels downcased-labels) #:transparent - #:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2) - #:property prop:struct-map (lambda (f seed x) - (let-values (((labels seed) (f (domain-labels x) seed))) - (values (make-domain labels) seed)))) + #:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2)) ;; ListOf -> ListOf ;; Converts the 7-bit ASCII bytes in the argument to lower-case diff --git a/api.rkt b/api.rkt index 1067e68..2862400 100644 --- a/api.rkt +++ b/api.rkt @@ -63,8 +63,7 @@ (require "mapping.rkt") (require racket/set) (require racket/match) -(require marketplace) -(require marketplace/struct-map) +(require syndicate) ;; A DomainName is a (domain ListOf), representing a domain ;; name. The head of the list is the leftmost label; for example, diff --git a/driver.rkt b/driver.rkt index 897578f..e3046d0 100644 --- a/driver.rkt +++ b/driver.rkt @@ -28,9 +28,9 @@ (require "codec.rkt") (require "zonedb.rkt") (require "resolver.rkt") -(require marketplace/sugar) -(require marketplace/support/spy) -(require marketplace/drivers/udp) +(require syndicate/ground) +(require syndicate/actor) +(require syndicate/drivers/udp) (require "tk-dns.rkt") ;; Instantiated with a SOA record for the zone it is serving as well @@ -58,18 +58,16 @@ (display ";; Ready.\n") - (ground-vm (udp-driver) - (generic-spy 'UDP) - (spawn-vm - (spawn (dns-spy)) - (spawn (dns-read-driver local-addr)) - (spawn (dns-write-driver local-addr)) - (subscriber (bad-dns-packet (wild) (wild) (wild) (wild)) - (on-message [p (begin (log-error (pretty-format p)) '())])) - (subscriber (dns-request (wild) (wild) (wild)) - (on-message [(? dns-request? r) - (let ((reply (handle-request soa-rr zone r))) - (when reply (send-message reply)))]))))) + (run-ground (spawn-udp-driver) + (dataspace (dns-spy) + (dns-read-driver local-addr) + (dns-write-driver local-addr) + (forever + (on (message ($ p (bad-dns-packet _ _ _ _))) + (log-error (pretty-format p))) + (on (message ($ r (dns-request _ _ _))) + (let ((reply (handle-request soa-rr zone r))) + (when reply (send! reply)))))))) ;; (define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage)) diff --git a/network-query.rkt b/network-query.rkt index bebaf30..b72535c 100644 --- a/network-query.rkt +++ b/network-query.rkt @@ -23,9 +23,9 @@ (require "api.rkt") (require "codec.rkt") (require "zonedb.rkt") -(require marketplace/sugar) -(require marketplace/drivers/udp) -(require marketplace/drivers/timer) +(require syndicate/actor) +(require syndicate/drivers/udp) +(require syndicate/drivers/timer) (require "tk-dns.rkt") (provide network-query @@ -228,14 +228,14 @@ ;; UdpAddress Question DomainName (Listof DomainName) Any -> ;; (Action ParentState))) (define (network-query s q zone-origin server-names unique-id) - (name-process (list 'network-query q) - (spawn (try-next-server - (network-query-state (network-request s q zone-origin server-names unique-id) - first-timeout - #hash() - '() - #f - server-names))))) + (spawn #:name (list 'network-query q) + (try-next-server + (network-query-state (network-request s q zone-origin server-names unique-id) + first-timeout + #hash() + '() + #f + server-names)))) ;; (: try-next-server : NetworkQueryState -> (Transition NetworkQueryState)) (define (try-next-server w) diff --git a/proxy.rkt b/proxy.rkt index 597879e..a3cc58e 100644 --- a/proxy.rkt +++ b/proxy.rkt @@ -28,10 +28,10 @@ (require "zonedb.rkt") (require "network-query.rkt") (require "resolver.rkt") -(require marketplace/sugar) -(require marketplace/support/spy) -(require marketplace/drivers/timer) -(require marketplace/drivers/udp) +(require syndicate) +(require syndicate/actor) +(require syndicate/drivers/timer) +(require syndicate/drivers/udp) (require "tk-dns.rkt") (require racket/pretty) diff --git a/tk-dns.rkt b/tk-dns.rkt index 9e80332..1cc24b5 100644 --- a/tk-dns.rkt +++ b/tk-dns.rkt @@ -22,8 +22,8 @@ (require racket/set) (require racket/match) (require "codec.rkt") -(require marketplace/sugar) -(require marketplace/drivers/udp) +(require syndicate/actor) +(require syndicate/drivers/udp) (provide (struct-out bad-dns-packet) (struct-out dns-request) @@ -36,55 +36,40 @@ (struct dns-request (message source sink) #:transparent) (struct dns-reply (message source sink) #:transparent) -;; (: dns-read-driver : UdpAddress -> (Transition Void)) (define (dns-read-driver s) - (transition (void) - (at-meta-level - (subscriber (udp-packet (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)))))]))))) + (actor + (forever + (on (message (udp-packet $source s #"") #:meta-level 1) + (log-info "Debug dump packet received") + (send! `(debug-dump))) + (on (message (udp-packet $source s $body) #:meta-level 1) + (send! + (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))))))))) + +(define (translate message s sink) + (with-handlers ((exn:fail? (lambda (e) + (send! (bad-dns-packet message s sink 'unencodable))))) + (send! #:meta-level 1 (udp-packet s sink (dns-message->packet message))))) -;; (: dns-write-driver : UdpAddress -> (Transition Void)) (define (dns-write-driver s) - ;; (: translate : DNSMessage UdpAddress -> (ActionTree Void)) - (define (translate message sink) - (with-handlers ((exn:fail? (lambda (e) - (send-message (bad-dns-packet message s sink 'unencodable))))) - (at-meta-level - (send-message (udp-packet s sink (dns-message->packet message)))))) - (transition (void) - (subscriber (dns-request (wild) s (wild)) - (on-message - [(dns-request message (== s) sink) (translate message sink)])) - (subscriber (dns-reply (wild) s (wild)) - (on-message - [(dns-reply message (== s) sink) (translate message sink)])))) + (actor (forever + (on (message (dns-request $message s $sink)) + (translate message s sink)) + (on (message (dns-reply $message s $sink)) + (translate message s sink))))) -;; (: dns-spy : -> (Transition Void)) (define (dns-spy) - (transition (void) - (observe-publishers (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))])))) + (actor (forever + (on (message (dns-request $message $source $sink)) + (log-info (format "DNS: ~v asks ~v ~v~n : ~v" + source sink (dns-message-id message) + (dns-message-questions message)))) + (on (message (dns-reply $message $source $sink)) + (log-info (format "DNS: ~v answers ~v~n : ~v" + source sink + message))))))