From 869a49539241fc0dfd9f1bc238eccd3ab0a52971 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Tue, 1 May 2018 20:58:43 +0100
Subject: [PATCH] First sketch of `quit-dataspace!`.

---
 syndicate/dataspace.rkt                       |  1 +
 .../examples/chat-server-nested-dataspace.rkt | 26 +++++++++++++++++++
 syndicate/relay.rkt                           | 19 +++++++++++---
 3 files changed, 42 insertions(+), 4 deletions(-)
 create mode 100644 syndicate/examples/chat-server-nested-dataspace.rkt

diff --git a/syndicate/dataspace.rkt b/syndicate/dataspace.rkt
index 6c29880..512d070 100644
--- a/syndicate/dataspace.rkt
+++ b/syndicate/dataspace.rkt
@@ -21,6 +21,7 @@
 
          facet?
          facet-actor
+         facet-live?
 
          field-handle ;; TODO: shouldn't be provided - inline syntax.rkt??
          field-handle?
diff --git a/syndicate/examples/chat-server-nested-dataspace.rkt b/syndicate/examples/chat-server-nested-dataspace.rkt
new file mode 100644
index 0000000..48aec7b
--- /dev/null
+++ b/syndicate/examples/chat-server-nested-dataspace.rkt
@@ -0,0 +1,26 @@
+#lang imperative-syndicate
+
+(require/activate imperative-syndicate/drivers/tcp)
+(require racket/format)
+
+(message-struct speak (who what))
+(assertion-struct present (who))
+
+(dataspace
+ (spawn #:name 'chat-server
+        (during/spawn (inbound (tcp-connection $id (tcp-listener 5999)))
+          #:name (list 'chat-connection id)
+          (assert (outbound (tcp-accepted id)))
+          (let ((me (gensym 'user)))
+            (assert (present me))
+            (on (message (inbound (tcp-in-line id $bs)))
+                (match bs
+                  [#"/quit" (stop-current-facet)]
+                  [#"/stop-server" (quit-dataspace!)]
+                  [_ (send! (speak me (bytes->string/utf-8 bs)))])))
+          (during (present $user)
+            (on-start (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " arrived\n"))))))
+            (on-stop  (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " left\n"))))))
+            (on (message (speak user $text))
+                (send!
+                 (outbound (tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n"))))))))))
diff --git a/syndicate/relay.rkt b/syndicate/relay.rkt
index cb7c403..6dbfa1e 100644
--- a/syndicate/relay.rkt
+++ b/syndicate/relay.rkt
@@ -1,10 +1,10 @@
 #lang racket/base
 ;; Cross-layer relaying between adjacent dataspaces
-;; TODO: protocol for shutdown of a dataspace
 ;; TODO: protocol for *clean* shutdown of a dataspace
 
 (provide (struct-out inbound)
          (struct-out outbound)
+         quit-dataspace!
          dataspace)
 
 (require racket/match)
@@ -22,8 +22,13 @@
 (struct inbound (assertion) #:prefab)
 (struct outbound (assertion) #:prefab)
 
+(struct *quit-dataspace* () #:transparent)
+
 ;; TODO: inbound^n, outbound^n -- protocol/standard-relay, iow
 
+(define (quit-dataspace!)
+  (send! (*quit-dataspace*)))
+
 (define-syntax (dataspace stx)
   (syntax-parse stx
     [(_ name:name form ...)
@@ -31,14 +36,16 @@
        (let ((ds-name name.N))
          (spawn #:name ds-name
                 (define outer-facet (current-facet))
+                (begin/dataflow (void)) ;; eww. dummy endpoint to keep the root facet alive
                 (define (schedule-inner!)
                   (push-script!
                    (facet-actor outer-facet)
                    (lambda ()
                      (with-current-facet [outer-facet]
-                       (defer-turn! (lambda ()
-                                      (when (run-scripts! inner-ds)
-                                        (schedule-inner!))))))))
+                       (when (facet-live? outer-facet)
+                         (defer-turn! (lambda ()
+                                        (when (run-scripts! inner-ds)
+                                          (schedule-inner!)))))))))
                 (define inner-ds (make-dataspace
                                   (lambda ()
                                     (schedule-script!
@@ -92,6 +99,10 @@
                                     #t
                                     (lambda () (values (observe x) i)))))))
 
+  (on (message (*quit-dataspace*))
+      (with-current-facet [outer-facet]
+        (stop-current-facet)))
+
   (on (retracted (observe (inbound $x)))
       ;; (log-info "~a (retracted (observe (inbound ~v)))" inner-actor x)
       (with-current-facet [outer-facet]