diff --git a/driver.rkt b/driver.rkt index 27498e7..c006683 100644 --- a/driver.rkt +++ b/driver.rkt @@ -10,10 +10,9 @@ (require "codec.rkt") (require "zonedb.rkt") (require "resolver.rkt") -(require "../racket-matrix/os.rkt") -(require "../racket-matrix/os-big-bang.rkt") -(require "../racket-matrix/os-udp.rkt") -(require "os-dns.rkt") +(require "../racket-matrix/os2.rkt") +(require "../racket-matrix/os2-udp.rkt") +(require "os2-dns.rkt") ;; Instantiated with a SOA record for the zone it is serving as well ;; as a zone's worth of DNS data which is used to answer queries @@ -36,34 +35,24 @@ (define (start-server port-number soa-rr rrs) ;; Compile the zone hash table (define zone (compile-zone-db (cons soa-rr rrs))) - (pretty-print zone) + (define local-addr (udp-listener port-number)) - (define boot-server - (os-big-bang 'no-state - (send-meta-message `(request create-server-socket (udp new ,port-number 512))) - (subscribe/fresh wait-id - (meta-message-handlers w - [`(reply create-server-socket ,s) - (transition w - (unsubscribe wait-id) - (spawn (dns-read-driver s)) - (spawn (dns-write-driver s)) - (subscribe 'packet-handler (packet-handler s)))])))) + (display ";; Ready.\n") - (define (packet-handler s) - (message-handlers old-state - [(? bad-dns-packet? p) - (log-error (pretty-format p)) - ;; TODO: ^ perhaps use metalevel events? perhaps don't bother though - old-state] - [(? dns-request? r) - (transition old-state - (map send-message - (handle-request soa-rr zone r)))])) - - (ground-vm (os-big-bang (void) - (spawn udp-driver) - (spawn (nested-vm boot-server))))) + (ground-vm + (transition 'no-state + (spawn udp-driver) + (spawn (nested-vm + (transition 'no-state + (spawn (dns-read-driver local-addr)) + (spawn (dns-write-driver local-addr)) + (role 'error-logger (topic-subscriber (bad-dns-packet (wild) (wild) (wild) (wild))) + #:state w + [p (begin (log-error (pretty-format p)) + w)]) + (role 'request-booter (topic-subscriber (dns-request (wild) (wild) (wild))) + #:state w + [r (transition w (map send-message (handle-request soa-rr zone r)))]))))))) (define (handle-request soa-rr zone request) (match-define (dns-request request-message request-source request-sink) request) diff --git a/os-dns.rkt b/os-dns.rkt deleted file mode 100644 index 522748b..0000000 --- a/os-dns.rkt +++ /dev/null @@ -1,62 +0,0 @@ -#lang racket/base - -;; DNS drivers using os-big-bang.rkt and os-udp.rkt. - -(require racket/match) -(require "codec.rkt") -(require "../racket-matrix/os-big-bang.rkt") -(require "../racket-matrix/os-udp.rkt") - -(provide (struct-out bad-dns-packet) - (struct-out dns-request) - (struct-out dns-reply) - dns-read-driver - dns-write-driver - dns-spy) - -(struct bad-dns-packet (detail source sink reason) #:prefab) -(struct dns-request (message source sink) #:prefab) -(struct dns-reply (message source sink) #:prefab) - -(define (dns-read-driver s) - (os-big-bang 'no-state - (subscribe 'packet-reader - (meta-message-handlers w - [(udp-packet source (== s) #"") - (log-info "Debug dump packet received") - (transition w - (send-message `(debug-dump)))] - [(udp-packet source (== s) body) - (transition w - (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))))))])))) - -(define (dns-write-driver s) - (define (translate message sink) - (with-handlers ((exn:fail? (lambda (e) - (send-message (bad-dns-packet message s sink 'unencodable))))) - (send-meta-message (udp-packet s sink (dns-message->packet message))))) - (os-big-bang 'no-state - (subscribe 'packet-writer - (message-handlers w - [(dns-request message (== s) sink) (transition w (translate message sink))] - [(dns-reply message (== s) sink) (transition w (translate message sink))])))) - -(define dns-spy - (os-big-bang 'none - (subscribe 'spy - (message-handlers w - [(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)))] - [(dns-reply message source sink) - (log-info (format "DNS: ~v answers ~v~n : ~v" - source sink - message))] - [x - (log-info (format "DNS: ~v" x))])))) diff --git a/os2-dns.rkt b/os2-dns.rkt new file mode 100644 index 0000000..f332842 --- /dev/null +++ b/os2-dns.rkt @@ -0,0 +1,69 @@ +#lang racket/base +;; DNS drivers using os2.rkt and os2-udp.rkt. + +(require racket/set) +(require racket/match) +(require "codec.rkt") +(require "../racket-matrix/os2.rkt") +(require "../racket-matrix/os2-udp.rkt") + +(provide (struct-out bad-dns-packet) + (struct-out dns-request) + (struct-out dns-reply) + dns-read-driver + dns-write-driver + dns-spy) + +(struct bad-dns-packet (detail source sink reason) #:prefab) +(struct dns-request (message source sink) #:prefab) +(struct dns-reply (message source sink) #:prefab) + +(define (dns-read-driver s) + (transition 'no-state + (at-meta-level + (role 'packet-reader + (topic-subscriber (udp-packet (wild) s (wild))) + #:state w + [(udp-packet source (== s) #"") + (log-info "Debug dump packet received") + (transition w (send-message `(debug-dump)))] + [(udp-packet source (== s) body) + (transition w + (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))))))])))) + +(define (dns-write-driver s) + (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 'no-state + (role 'packet-writer + (set (topic-subscriber (dns-request (wild) s (wild))) + (topic-subscriber (dns-reply (wild) s (wild)))) + #:state w + [(dns-request message (== s) sink) (transition w (translate message sink))] + [(dns-reply message (== s) sink) (transition w (translate message sink))]))) + +(define dns-spy + (transition 'none + (role 'spy (topic-subscriber (wild) #:virtual? #t) + #:state w + [(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))) + w] + [(dns-reply message source sink) + (log-info (format "DNS: ~v answers ~v~n : ~v" + source sink + message)) + w] + [x + (log-info (format "DNS: ~v" x)) + w])))