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,

28
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)) (let ((reply (handle-request soa-rr zone r)))
(on-message [(? dns-request? r) (when reply (send! reply))))))))
(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)) ;; (define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage))

22
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)

83
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) (with-handlers ((exn:fail? (lambda (e)
(send-message (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)
(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) (define (dns-write-driver s)
;; (: translate : DNSMessage UdpAddress -> (ActionTree Void)) (actor (forever
(define (translate message sink) (on (message (dns-request $message s $sink))
(with-handlers ((exn:fail? (lambda (e) (translate message s sink))
(send-message (bad-dns-packet message s sink 'unencodable))))) (on (message (dns-reply $message s $sink))
(at-meta-level (translate message s sink)))))
(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)]))))
;; (: 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) source sink (dns-message-id message)
(begin (log-info (format "DNS: ~v asks ~v ~v~n : ~v" (dns-message-questions message))))
source sink (dns-message-id message) (on (message (dns-reply $message $source $sink))
(dns-message-questions message))) (log-info (format "DNS: ~v answers ~v~n : ~v"
(void))] source sink
[(dns-reply message source sink) message))))))
(begin (log-info (format "DNS: ~v answers ~v~n : ~v"
source sink
message))
(void))]
[x
(begin (log-info (format "DNS: ~v" x))
(void))]))))