From eb44003317a0aba374a6c4cd05fa25d3703b0b3d Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Tue, 5 Dec 2017 17:32:12 +0000
Subject: [PATCH] New examples

---
 .../syndicate/examples/actor/simple-dns.rkt   | 27 ++++++++++++++++
 racket/syndicate/examples/actor/tcp-relay.rkt | 32 +++++++++++++++++++
 2 files changed, 59 insertions(+)
 create mode 100644 racket/syndicate/examples/actor/simple-dns.rkt
 create mode 100644 racket/syndicate/examples/actor/tcp-relay.rkt

diff --git a/racket/syndicate/examples/actor/simple-dns.rkt b/racket/syndicate/examples/actor/simple-dns.rkt
new file mode 100644
index 0000000..aeee485
--- /dev/null
+++ b/racket/syndicate/examples/actor/simple-dns.rkt
@@ -0,0 +1,27 @@
+#lang syndicate
+;; Sketch of a DNS intra-program protocol
+
+(assertion-struct dns-entry (name address))
+
+(require/activate syndicate/drivers/timestate)
+
+(spawn #:name 'server
+       (during (observe (dns-entry "localhost" _))
+         (on-start (printf "asserting localhost record\n"))
+         (on-stop (printf "retracting localhost record\n"))
+         (assert (dns-entry "localhost" "127.0.0.1"))))
+
+(spawn #:name 'cache
+       (on (asserted (dns-entry $name $addr))
+           (define deadline (+ (current-inexact-milliseconds) 5000))
+           (react (stop-when (asserted (later-than deadline)))
+                  (on-start (printf "caching ~a = ~a\n" name addr))
+                  (on-stop (printf "uncaching ~a = ~a\n" name addr))
+                  (assert (dns-entry name addr)))))
+
+(spawn #:name 'main
+       (stop-when (asserted (dns-entry "localhost" $addr))
+         (printf "localhost is ~a\n" addr)
+         (sleep 1)
+         (react (stop-when (asserted (dns-entry "localhost" $addr))
+                  (printf "localhost is still ~a\n" addr)))))
diff --git a/racket/syndicate/examples/actor/tcp-relay.rkt b/racket/syndicate/examples/actor/tcp-relay.rkt
new file mode 100644
index 0000000..6f6daf3
--- /dev/null
+++ b/racket/syndicate/examples/actor/tcp-relay.rkt
@@ -0,0 +1,32 @@
+#lang syndicate
+;; Simple TCP relay
+
+(require/activate syndicate/drivers/tcp2)
+
+(define (read-tcp-line id)
+  (react/suspend (k)
+    (on (message (tcp-in-line id $line-bytes))
+        (k (bytes->string/utf-8 line-bytes)))))
+
+(spawn #:name 'server
+       (during (tcp-connection $id (tcp-listener 5000))
+         (assert (tcp-accepted id))
+         (on-start (printf "Accepted ~a\n" id))
+         (on-stop (printf "Disconnected ~a\n" id))
+         (define connection-facet-id (current-facet-id))
+         (on-start (send! (tcp-out id #"Please enter the host to connect to: "))
+                   (define host (read-tcp-line id))
+                   (send! (tcp-out id #"Please enter the port to connect to: "))
+                   (define port (string->number (read-tcp-line id)))
+                   (define outbound-id (gensym 'outbound-id))
+                   (react (assert (tcp-connection outbound-id (tcp-address host port)))
+                          (during (tcp-accepted outbound-id)
+                            (on-start (printf "Connected ~a => ~a\n" id outbound-id))
+                            (on-stop (printf "Disconnected ~a => ~a\n" id outbound-id))
+                            (on-stop (stop-facet connection-facet-id))
+                            (on (message (tcp-in id $bs))
+                                (printf "Relaying ~a -> ~a: ~v\n" id outbound-id bs)
+                                (send! (tcp-out outbound-id bs)))
+                            (on (message (tcp-in outbound-id $bs))
+                                (printf "Relaying ~a <- ~a: ~v\n" id outbound-id bs)
+                                (send! (tcp-out id bs))))))))