From 1f969de125535e180a7eaf9cbcc490399293da8d Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Mon, 16 Jan 2012 18:33:00 -0500
Subject: [PATCH] Use a nested-vm in big-bang-driver to split the UDP and DNS
 layers

---
 big-bang-driver.rkt | 22 ++++++++++++----------
 os.rkt              |  4 ++++
 2 files changed, 16 insertions(+), 10 deletions(-)

diff --git a/big-bang-driver.rkt b/big-bang-driver.rkt
index 1715d5f..3a1d7ba 100644
--- a/big-bang-driver.rkt
+++ b/big-bang-driver.rkt
@@ -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)))))]))))
diff --git a/os.rkt b/os.rkt
index 67e5813..e32e17b 100644
--- a/os.rkt
+++ b/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)