Use a nested-vm in big-bang-driver to split the UDP and DNS layers
This commit is contained in:
parent
ad7b823e6e
commit
1f969de125
|
@ -13,6 +13,7 @@
|
|||
(require "network-query-sig.rkt")
|
||||
(require "resolver-unit.rkt")
|
||||
(require "dump-bytes.rkt")
|
||||
(require "os.rkt")
|
||||
(require "os-big-bang.rkt")
|
||||
(require "os-udp.rkt")
|
||||
|
||||
|
@ -42,6 +43,10 @@
|
|||
(struct dns-request (message source) #:prefab)
|
||||
(struct dns-reply (message sink) #:prefab)
|
||||
|
||||
;; (define (spy label)
|
||||
;; (os-big-bang 'none
|
||||
;; (subscribe 'spy (message-handlers w [x (write `(,label ,x)) (newline)]))))
|
||||
|
||||
;; start-server : UInt16 RR ListOf<RR> -> Void
|
||||
;; Starts a server that will answer questions received on the given
|
||||
;; UDP port based on the RRs it is given and the zone origin specified
|
||||
|
@ -52,21 +57,17 @@
|
|||
(define zone (compile-zone-db (cons soa-rr rrs)))
|
||||
(pretty-print zone)
|
||||
|
||||
;; TODO: STACKED VMS for different layers!
|
||||
;; That will let us do this:
|
||||
;; (lambda (unhandled state)
|
||||
;; (error 'dns-server "Unhandled packet ~v" unhandled))
|
||||
|
||||
(define boot-server
|
||||
(os-big-bang 'no-state
|
||||
(send-message `(request create-server-socket (udp new ,port-number 512)))
|
||||
(send-meta-message `(request create-server-socket (udp new ,port-number 512)))
|
||||
(subscribe 'wait-for-server-socket
|
||||
(message-handlers w
|
||||
(meta-message-handlers w
|
||||
[`(reply create-server-socket ,s)
|
||||
(transition w
|
||||
(unsubscribe 'wait-for-server-socket)
|
||||
(spawn (dns-read-driver s))
|
||||
(spawn (dns-write-driver s))
|
||||
;;(spawn (spy 'DNS-MESSAGE))
|
||||
(subscribe 'packet-handler (packet-handler s)))]))))
|
||||
|
||||
(define (packet-handler s)
|
||||
|
@ -81,12 +82,13 @@
|
|||
|
||||
(ground-vm (os-big-bang (void)
|
||||
(spawn udp-driver)
|
||||
(spawn boot-server))))
|
||||
;;(spawn (spy 'UDP-MESSAGE))
|
||||
(spawn (nested-vm boot-server)))))
|
||||
|
||||
(define (dns-read-driver s)
|
||||
(os-big-bang 'no-state
|
||||
(subscribe 'packet-reader
|
||||
(message-handlers w
|
||||
(meta-message-handlers w
|
||||
[(udp-packet source (== s) body)
|
||||
(transition w
|
||||
(send-message
|
||||
|
@ -104,7 +106,7 @@
|
|||
(message-handlers w
|
||||
[(dns-reply message sink)
|
||||
(transition w
|
||||
(send-message
|
||||
(send-meta-message
|
||||
(with-handlers ((exn? (lambda (e) (bad-dns-packet message s sink
|
||||
'unencodable))))
|
||||
(udp-packet s sink (dns-message->packet message)))))]))))
|
||||
|
|
4
os.rkt
4
os.rkt
|
@ -18,6 +18,7 @@
|
|||
make-vm
|
||||
vm?
|
||||
run-vm
|
||||
nested-vm
|
||||
|
||||
;; Grounding out the infinite tower of VMs
|
||||
default-pattern-predicate
|
||||
|
@ -269,6 +270,9 @@
|
|||
(not (queue-empty? (vm-pending-messages state)))
|
||||
(ormap suspension-polling? (vm-suspensions state))))
|
||||
|
||||
(define (nested-vm boot #:pattern-predicate [pattern-predicate default-pattern-predicate])
|
||||
(lambda () (run-vm (make-vm boot #:pattern-predicate pattern-predicate))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (nested-vm-inert? sub)
|
||||
|
|
Loading…
Reference in New Issue