Simplified TCP protocol chat example

prospect/actor.rkt

@@ -583,8 +583,8 @@
     (for [(edge (in-list (syntax->list edges)))
           (edge-index (in-naturals (length (syntax->list ongoings))))]
       (syntax-parse edge
-        [(E I ...)
-         (analyze-event! edge-index #'E #'((call-with-values (lambda () I ...) return!)))]))
+        [(E I0 I ...)
+         (analyze-event! edge-index #'E #'((call-with-values (lambda () I0 I ...) return!)))]))
 
     ;; ...and generic linkage-related behaviors.
     (add-event-handler!

prospect/examples/actor/chat-simplified-internals.rkt

@@ -0,0 +1,55 @@
+#lang prospect
+
+(require prospect/actor)
+(require prospect/drivers/tcp)
+(require (only-in racket/string string-trim))
+
+(struct tcp-remote-open (id) #:prefab)
+(struct tcp-local-open (id) #:prefab)
+(struct tcp-incoming-data (id bytes) #:prefab)
+(struct tcp-outgoing-data (id bytes) #:prefab)
+
+(struct says (who what) #:prefab)
+(struct present (who) #:prefab)
+
+(define (spawn-session id)
+  (actor (define (send-to-remote fmt . vs)
+           (send! (tcp-outgoing-data id (string->bytes/utf-8 (apply format fmt vs)))))
+
+         (define (say who fmt . vs)
+           (unless (equal? who user)
+             (send-to-remote "~a ~a\n" who (apply format fmt vs))))
+
+         (define user (gensym 'user))
+         (send-to-remote "Welcome, ~a.\n" user)
+
+         (until (retracted (tcp-remote-open id))
+                (assert (tcp-local-open id))
+                (assert (present user))
+
+                (on (asserted (present $who)) (say who "arrived."))
+                (on (retracted (present $who)) (say who "departed."))
+                (on (message (says $who $what)) (say who "says: ~a" what))
+
+                (on (message (tcp-incoming-data id $bs))
+                    (send! (says user (string-trim (bytes->string/utf-8 bs))))))))
+
+(actor-body->spawn-action
+ (lambda ()
+   (perform-core-action! (spawn-tcp-driver))
+
+   (define us (tcp-listener 5999))
+   (actor (forever (assert (advertise (observe (tcp-channel _ us _))))
+                   (on (asserted (advertise (tcp-channel $them us _)))
+                       (define id (seal (list them us)))
+                       (actor (state [(assert (tcp-remote-open id))
+                                      (on (message (tcp-channel them us $bs))
+                                          (send! (tcp-incoming-data id bs)))
+                                      (on (message (tcp-outgoing-data id $bs))
+                                          (send! (tcp-channel us them bs)))]
+                                [(retracted (advertise (tcp-channel them us _))) (void)]
+                                [(retracted (tcp-local-open id)) (void)])))))
+
+   (forever (on (asserted (tcp-remote-open $id))
+                (spawn-session id)))
+   ))

prospect/examples/chat-simplified-internals.rkt

@@ -0,0 +1,75 @@
+#lang prospect
+;; The chat server, using a proxy abstracting over details of the TCP
+;; driver's protocol.
+
+(require (only-in racket/string string-trim))
+(require "../drivers/tcp.rkt")
+(require "../demand-matcher.rkt")
+
+(struct tcp-remote-open (id) #:prefab)
+(struct tcp-local-open (id) #:prefab)
+(struct tcp-incoming-data (id bytes) #:prefab)
+(struct tcp-outgoing-data (id bytes) #:prefab)
+
+(struct says (who what) #:prefab)
+(struct present (who) #:prefab)
+
+(define (tcp-proxy-process them us)
+  (define id (seal (list them us)))
+  (spawn (lambda (e s)
+           (match e
+             [(message (tcp-channel _ _ bs))
+              (transition s (message (tcp-incoming-data id bs)))]
+             [(message (tcp-outgoing-data _ bs))
+              (transition s (message (tcp-channel us them bs)))]
+             [(? patch/removed?)
+              (quit)]
+             [_ #f]))
+         (void)
+         (patch-seq (sub (tcp-channel them us ?))
+                    (sub (advertise (tcp-channel them us ?)))
+                    (pub (tcp-channel us them ?))
+                    (sub (tcp-outgoing-data id ?))
+                    (assert (tcp-remote-open id))
+                    (sub (tcp-local-open id)))))
+
+(define (spawn-session id)
+  (define user (gensym 'user))
+  (define (send-to-remote fmt . vs)
+    (message (tcp-outgoing-data id (string->bytes/utf-8 (apply format fmt vs)))))
+  (define (say who fmt . vs)
+    (unless (equal? who user) (send-to-remote "~a ~a\n" who (apply format fmt vs))))
+  (list (send-to-remote "Welcome, ~a.\n" user)
+	(spawn/stateless
+         (lambda (e)
+           (match e
+             [(message (tcp-incoming-data _ bs))
+              (message (says user (string-trim (bytes->string/utf-8 bs))))]
+             [(message (says who what))
+              (say who "says: ~a" what)]
+             [(? patch? p)
+              (if (patch/removed? (patch-project p (compile-projection (tcp-remote-open id))))
+                  (quit)
+                  (let-values (((arrived departed)
+                                (patch-project/set/single p (compile-projection (present (?!))))))
+                    (list (for/list [(who arrived)] (say who "arrived."))
+                          (for/list [(who departed)] (say who "departed.")))))]
+             [#f #f]))
+         (patch-seq
+          (sub (says ? ?)) ;; read actual chat messages
+          (sub (present ?)) ;; observe peer presence
+          (assert (present user)) ;; advertise our presence
+          (sub (tcp-incoming-data id ?)) ;; read from remote client
+          (sub (tcp-remote-open id)) ;; monitor remote client
+          (assert (tcp-local-open id)) ;; indicate our end of the connection is up
+          ))))
+
+(spawn-tcp-driver)
+
+(spawn-demand-matcher (advertise (tcp-channel (?!) (?! (tcp-listener 5999)) ?))
+                      (observe (tcp-channel (?!) (?! (tcp-listener 5999)) ?))
+                      tcp-proxy-process)
+
+(spawn-demand-matcher (tcp-remote-open (?!))
+                      (tcp-local-open (?!))
+                      spawn-session)