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 "network-query-sig.rkt")
|
||||||
(require "resolver-unit.rkt")
|
(require "resolver-unit.rkt")
|
||||||
(require "dump-bytes.rkt")
|
(require "dump-bytes.rkt")
|
||||||
|
(require "os.rkt")
|
||||||
(require "os-big-bang.rkt")
|
(require "os-big-bang.rkt")
|
||||||
(require "os-udp.rkt")
|
(require "os-udp.rkt")
|
||||||
|
|
||||||
|
@ -42,6 +43,10 @@
|
||||||
(struct dns-request (message source) #:prefab)
|
(struct dns-request (message source) #:prefab)
|
||||||
(struct dns-reply (message sink) #: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
|
;; start-server : UInt16 RR ListOf<RR> -> Void
|
||||||
;; Starts a server that will answer questions received on the given
|
;; 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
|
;; 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)))
|
(define zone (compile-zone-db (cons soa-rr rrs)))
|
||||||
(pretty-print zone)
|
(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
|
(define boot-server
|
||||||
(os-big-bang 'no-state
|
(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
|
(subscribe 'wait-for-server-socket
|
||||||
(message-handlers w
|
(meta-message-handlers w
|
||||||
[`(reply create-server-socket ,s)
|
[`(reply create-server-socket ,s)
|
||||||
(transition w
|
(transition w
|
||||||
(unsubscribe 'wait-for-server-socket)
|
(unsubscribe 'wait-for-server-socket)
|
||||||
(spawn (dns-read-driver s))
|
(spawn (dns-read-driver s))
|
||||||
(spawn (dns-write-driver s))
|
(spawn (dns-write-driver s))
|
||||||
|
;;(spawn (spy 'DNS-MESSAGE))
|
||||||
(subscribe 'packet-handler (packet-handler s)))]))))
|
(subscribe 'packet-handler (packet-handler s)))]))))
|
||||||
|
|
||||||
(define (packet-handler s)
|
(define (packet-handler s)
|
||||||
|
@ -81,12 +82,13 @@
|
||||||
|
|
||||||
(ground-vm (os-big-bang (void)
|
(ground-vm (os-big-bang (void)
|
||||||
(spawn udp-driver)
|
(spawn udp-driver)
|
||||||
(spawn boot-server))))
|
;;(spawn (spy 'UDP-MESSAGE))
|
||||||
|
(spawn (nested-vm boot-server)))))
|
||||||
|
|
||||||
(define (dns-read-driver s)
|
(define (dns-read-driver s)
|
||||||
(os-big-bang 'no-state
|
(os-big-bang 'no-state
|
||||||
(subscribe 'packet-reader
|
(subscribe 'packet-reader
|
||||||
(message-handlers w
|
(meta-message-handlers w
|
||||||
[(udp-packet source (== s) body)
|
[(udp-packet source (== s) body)
|
||||||
(transition w
|
(transition w
|
||||||
(send-message
|
(send-message
|
||||||
|
@ -104,7 +106,7 @@
|
||||||
(message-handlers w
|
(message-handlers w
|
||||||
[(dns-reply message sink)
|
[(dns-reply message sink)
|
||||||
(transition w
|
(transition w
|
||||||
(send-message
|
(send-meta-message
|
||||||
(with-handlers ((exn? (lambda (e) (bad-dns-packet message s sink
|
(with-handlers ((exn? (lambda (e) (bad-dns-packet message s sink
|
||||||
'unencodable))))
|
'unencodable))))
|
||||||
(udp-packet s sink (dns-message->packet message)))))]))))
|
(udp-packet s sink (dns-message->packet message)))))]))))
|
||||||
|
|
4
os.rkt
4
os.rkt
|
@ -18,6 +18,7 @@
|
||||||
make-vm
|
make-vm
|
||||||
vm?
|
vm?
|
||||||
run-vm
|
run-vm
|
||||||
|
nested-vm
|
||||||
|
|
||||||
;; Grounding out the infinite tower of VMs
|
;; Grounding out the infinite tower of VMs
|
||||||
default-pattern-predicate
|
default-pattern-predicate
|
||||||
|
@ -269,6 +270,9 @@
|
||||||
(not (queue-empty? (vm-pending-messages state)))
|
(not (queue-empty? (vm-pending-messages state)))
|
||||||
(ormap suspension-polling? (vm-suspensions 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)
|
(define (nested-vm-inert? sub)
|
||||||
|
|
Loading…
Reference in New Issue