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

Initial progress. driver.rkt runs; now on proxy.rkt

This commit is contained in:
Tony Garnock-Jones 2016-06-06 17:07:33 -04:00
parent dc3df20d9b
commit b7bdb4065e
7 changed files with 67 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
README.md
View File

@ -2,7 +2,7 @@
This is a [Racket](http://racket-lang.org/) implementation of a DNS This is a [Racket](http://racket-lang.org/) implementation of a DNS
server and iterative resolver. It's written to work with 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 be adapted to work with other I/O substrates. (It originally used
Racket's `sync` and events directly.) 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, 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 [bitsyntax](https://github.com/tonyg/racket-bitsyntax/), and then
raco make driver.rkt proxy.rkt raco make driver.rkt proxy.rkt

7
api-untyped.rkt
View File

@ -20,8 +20,6 @@
;;; along with marketplace-dns. If not, see ;;; along with marketplace-dns. If not, see
;;; <http://www.gnu.org/licenses/>. ;;; <http://www.gnu.org/licenses/>.
(require marketplace/struct-map)
(provide (struct-out domain) (provide (struct-out domain)
downcase-labels downcase-labels
make-domain) make-domain)
@ -37,10 +35,7 @@
(struct domain (labels downcased-labels) (struct domain (labels downcased-labels)
#:transparent #:transparent
#:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2) #: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))))
;; ListOf<Bytes> -> ListOf<Bytes> ;; ListOf<Bytes> -> ListOf<Bytes>
;; Converts the 7-bit ASCII bytes in the argument to lower-case ;; Converts the 7-bit ASCII bytes in the argument to lower-case

3
api.rkt
View File

@ -63,8 +63,7 @@
(require "mapping.rkt") (require "mapping.rkt")
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require marketplace) (require syndicate)
(require marketplace/struct-map)
;; A DomainName is a (domain ListOf<Bytes>), representing a domain ;; A DomainName is a (domain ListOf<Bytes>), representing a domain
;; name. The head of the list is the leftmost label; for example, ;; name. The head of the list is the leftmost label; for example,

26
driver.rkt
View File

@ -28,9 +28,9 @@
(require "codec.rkt") (require "codec.rkt")
(require "zonedb.rkt") (require "zonedb.rkt")
(require "resolver.rkt") (require "resolver.rkt")
(require marketplace/sugar) (require syndicate/ground)
(require marketplace/support/spy) (require syndicate/actor)
(require marketplace/drivers/udp) (require syndicate/drivers/udp)
(require "tk-dns.rkt") (require "tk-dns.rkt")
;; Instantiated with a SOA record for the zone it is serving as well ;; Instantiated with a SOA record for the zone it is serving as well
@ -58,18 +58,16 @@
(display ";; Ready.\n") (display ";; Ready.\n")
(ground-vm (udp-driver) (run-ground (spawn-udp-driver)
(generic-spy 'UDP) (dataspace (dns-spy)
(spawn-vm (dns-read-driver local-addr)
(spawn (dns-spy)) (dns-write-driver local-addr)
(spawn (dns-read-driver local-addr)) (forever
(spawn (dns-write-driver local-addr)) (on (message ($ p (bad-dns-packet _ _ _ _)))
(subscriber (bad-dns-packet (wild) (wild) (wild) (wild)) (log-error (pretty-format p)))
(on-message [p (begin (log-error (pretty-format p)) '())])) (on (message ($ r (dns-request _ _ _)))
(subscriber (dns-request (wild) (wild) (wild))
(on-message [(? dns-request? r)
(let ((reply (handle-request soa-rr zone r))) (let ((reply (handle-request soa-rr zone r)))
(when reply (send-message reply)))]))))) (when reply (send! 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))

12
network-query.rkt
View File

@ -23,9 +23,9 @@
(require "api.rkt") (require "api.rkt")
(require "codec.rkt") (require "codec.rkt")
(require "zonedb.rkt") (require "zonedb.rkt")
(require marketplace/sugar) (require syndicate/actor)
(require marketplace/drivers/udp) (require syndicate/drivers/udp)
(require marketplace/drivers/timer) (require syndicate/drivers/timer)
(require "tk-dns.rkt") (require "tk-dns.rkt")
(provide network-query (provide network-query
@ -228,14 +228,14 @@
;; 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)
(name-process (list 'network-query q) (spawn #:name (list 'network-query q)
(spawn (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
#hash() #hash()
'() '()
#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)

8
proxy.rkt
View File

@ -28,10 +28,10 @@
(require "zonedb.rkt") (require "zonedb.rkt")
(require "network-query.rkt") (require "network-query.rkt")
(require "resolver.rkt") (require "resolver.rkt")
(require marketplace/sugar) (require syndicate)
(require marketplace/support/spy) (require syndicate/actor)
(require marketplace/drivers/timer) (require syndicate/drivers/timer)
(require marketplace/drivers/udp) (require syndicate/drivers/udp)
(require "tk-dns.rkt") (require "tk-dns.rkt")
(require racket/pretty) (require racket/pretty)

69
tk-dns.rkt
View File

@ -22,8 +22,8 @@
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require "codec.rkt") (require "codec.rkt")
(require marketplace/sugar) (require syndicate/actor)
(require marketplace/drivers/udp) (require syndicate/drivers/udp)
(provide (struct-out bad-dns-packet) (provide (struct-out bad-dns-packet)
(struct-out dns-request) (struct-out dns-request)
@ -36,55 +36,40 @@
(struct dns-request (message source sink) #:transparent) (struct dns-request (message source sink) #:transparent)
(struct dns-reply (message source sink) #:transparent) (struct dns-reply (message source sink) #:transparent)
;; (: dns-read-driver : UdpAddress -> (Transition Void))
(define (dns-read-driver s) (define (dns-read-driver s)
(transition (void) (actor
(at-meta-level (forever
(subscriber (udp-packet (wild) s (wild)) (on (message (udp-packet $source s #"") #:meta-level 1)
(on-message (log-info "Debug dump packet received")
[(udp-packet source (== s) #"") (send! `(debug-dump)))
(begin (log-info "Debug dump packet received") (on (message (udp-packet $source s $body) #:meta-level 1)
(send-message `(debug-dump)))] (send!
[(udp-packet source (== s) body)
(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)) (define (translate message s sink)
(define (dns-write-driver s)
;; (: translate : DNSMessage UdpAddress -> (ActionTree Void))
(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! (bad-dns-packet message s sink 'unencodable)))))
(at-meta-level (send! #:meta-level 1 (udp-packet s sink (dns-message->packet message)))))
(send-message (udp-packet s sink (dns-message->packet message))))))
(transition (void) (define (dns-write-driver s)
(subscriber (dns-request (wild) s (wild)) (actor (forever
(on-message (on (message (dns-request $message s $sink))
[(dns-request message (== s) sink) (translate message sink)])) (translate message s sink))
(subscriber (dns-reply (wild) s (wild)) (on (message (dns-reply $message s $sink))
(on-message (translate message s sink)))))
[(dns-reply message (== s) sink) (translate message sink)]))))
;; (: dns-spy : -> (Transition Void))
(define (dns-spy) (define (dns-spy)
(transition (void) (actor (forever
(observe-publishers (wild) (on (message (dns-request $message $source $sink))
(on-message (log-info (format "DNS: ~v asks ~v ~v~n : ~v"
[(dns-request message source sink)
(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))] (on (message (dns-reply $message $source $sink))
[(dns-reply message source sink) (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))]
[x
(begin (log-info (format "DNS: ~v" x))
(void))]))))