Variations on chat server

prospect/examples/actor/chat-no-quit-world-no-nesting.rkt

@@ -0,0 +1,38 @@
+#lang prospect
+
+(require prospect/actor)
+(require prospect/drivers/tcp)
+(require (only-in racket/string string-trim))
+
+(struct says (who what) #:prefab)
+(struct present (who) #:prefab)
+
+(define (spawn-session them us)
+  (actor (define (send-to-remote fmt . vs)
+           (send! (tcp-channel us them (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 (advertise (tcp-channel them us _)))
+                (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))
+
+                (assert (advertise (tcp-channel us them _)))
+                (on (message (tcp-channel them us $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))
+   (forever (assert (advertise (observe (tcp-channel _ us _))))
+            (on (asserted (advertise (tcp-channel $them us _)))
+                (spawn-session them us)))))

prospect/examples/actor/chat-no-quit-world.rkt

@@ -0,0 +1,39 @@
+#lang prospect
+
+(require prospect/actor)
+(require prospect/drivers/tcp)
+(require (only-in racket/string string-trim))
+
+(struct says (who what) #:prefab)
+(struct present (who) #:prefab)
+
+(define (spawn-session them us)
+  (actor (define (send-to-remote fmt . vs)
+           (send! (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))
+                  #:meta-level 1))
+
+         (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 (advertise (tcp-channel them us _)) #:meta-level 1)
+                (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))
+
+                (assert (advertise (tcp-channel us them _)) #:meta-level 1)
+                (on (message (tcp-channel them us $bs) #:meta-level 1)
+                    (send! (says user (string-trim (bytes->string/utf-8 bs))))))))
+
+(actor-body->spawn-action
+ (lambda ()
+   (perform-core-action! (spawn-tcp-driver))
+   (network (define us (tcp-listener 5999))
+            (forever (assert (advertise (observe (tcp-channel _ us _))) #:meta-level 1)
+                     (on (asserted (advertise (tcp-channel $them us _)) #:meta-level 1)
+                         (spawn-session them us))))))

prospect/examples/chat-no-quit-world-no-nesting.rkt

@@ -0,0 +1,42 @@
+#lang prospect
+
+(require (only-in racket/string string-trim))
+(require "../drivers/tcp.rkt")
+(require "../demand-matcher.rkt")
+
+(define (spawn-session them us)
+  (define user (gensym 'user))
+  (define remote-detector (compile-projection (advertise (?! (tcp-channel ? ? ?)))))
+  (define peer-detector (compile-projection (advertise `(,(?!) says ,?))))
+  (define (send-to-remote fmt . vs)
+    (message (tcp-channel us them (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-channel _ _ bs))
+              (message `(,user says ,(string-trim (bytes->string/utf-8 bs))))]
+             [(message `(,who says ,what))
+              (say who "says: ~a" what)]
+             [(? patch? p)
+              (if (patch/removed? (patch-project p remote-detector))
+                  (quit (send-to-remote "Goodbye!\n"))
+                  (let-values (((arrived departed) (patch-project/set/single p peer-detector)))
+                    (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 (advertise `(,? says ,?))) ;; observe peer presence
+          (pub `(,user says ,?)) ;; advertise our presence
+          (sub (tcp-channel them us ?)) ;; read from remote client
+          (sub (advertise (tcp-channel them us ?))) ;; monitor remote client
+          (pub (tcp-channel us them ?)) ;; we will write to remote client
+          ))))
+
+(spawn-tcp-driver)
+(spawn-demand-matcher (advertise (tcp-channel (?!) (?! (tcp-listener 5999)) ?))
+                      (observe (tcp-channel (?!) (?! (tcp-listener 5999)) ?))
+                      spawn-session)

prospect/examples/chat-no-quit-world.rkt

@@ -0,0 +1,44 @@
+#lang prospect
+
+(require (only-in racket/string string-trim))
+(require "../drivers/tcp.rkt")
+(require "../demand-matcher.rkt")
+
+(define (spawn-session them us)
+  (define user (gensym 'user))
+  (define remote-detector (compile-projection (at-meta (?!))))
+  (define peer-detector (compile-projection (advertise `(,(?!) says ,?))))
+  (define (send-to-remote fmt . vs)
+    (message (at-meta (tcp-channel us them (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 (at-meta (tcp-channel _ _ bs)))
+              (message `(,user says ,(string-trim (bytes->string/utf-8 bs))))]
+             [(message `(,who says ,what))
+              (say who "says: ~a" what)]
+             [(? patch? p)
+              (if (patch/removed? (patch-project p remote-detector))
+                  (quit (send-to-remote "Goodbye!\n"))
+                  (let-values (((arrived departed) (patch-project/set/single p peer-detector)))
+                    (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 (advertise `(,? says ,?))) ;; observe peer presence
+          (pub `(,user says ,?)) ;; advertise our presence
+          (sub (tcp-channel them us ?) #:meta-level 1) ;; read from remote client
+          (sub (advertise (tcp-channel them us ?)) #:meta-level 1) ;; monitor remote client
+          (pub (tcp-channel us them ?) #:meta-level 1) ;; we will write to remote client
+          ))))
+
+(spawn-tcp-driver)
+(spawn-world
+ (spawn-demand-matcher (advertise (tcp-channel (?!) (?! (tcp-listener 5999)) ?))
+                       (observe (tcp-channel (?!) (?! (tcp-listener 5999)) ?))
+		       #:meta-level 1
+		       spawn-session))