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

7
api-untyped.rkt
View File

@ -20,8 +20,6 @@
;;; along with marketplace-dns. If not, see
;;; <http://www.gnu.org/licenses/>.
(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<Bytes> -> ListOf<Bytes>
;; 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 racket/set)
(require racket/match)
(require marketplace)
(require marketplace/struct-map)
(require syndicate)
;; A DomainName is a (domain ListOf<Bytes>), representing a domain
;; 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 "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))

22
network-query.rkt
View File

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

8
proxy.rkt
View File

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

83
tk-dns.rkt
View File

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