First steps to getting the driver running with os2.
This commit is contained in:
Tony Garnock-Jones
parent
0f38c940ad
commit
fc829f172f
49
driver.rkt
49
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)
|
||||
|
|
|
|||
62
os-dns.rkt
62
os-dns.rkt
|
|
@ -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))]))))
|
||||
|
|
@ -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])))
|
||||
Loading…
Reference in New Issue