From 31fe2cd92ba29f3b07d1b128b4f5a3cc8478812f Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 13 Jan 2016 11:35:03 -0500 Subject: [PATCH] Variations on chat server --- .../actor/chat-no-quit-world-no-nesting.rkt | 38 ++++++++++++++++ .../examples/actor/chat-no-quit-world.rkt | 39 ++++++++++++++++ .../chat-no-quit-world-no-nesting.rkt | 42 ++++++++++++++++++ prospect/examples/chat-no-quit-world.rkt | 44 +++++++++++++++++++ 4 files changed, 163 insertions(+) create mode 100644 prospect/examples/actor/chat-no-quit-world-no-nesting.rkt create mode 100644 prospect/examples/actor/chat-no-quit-world.rkt create mode 100644 prospect/examples/chat-no-quit-world-no-nesting.rkt create mode 100644 prospect/examples/chat-no-quit-world.rkt diff --git a/prospect/examples/actor/chat-no-quit-world-no-nesting.rkt b/prospect/examples/actor/chat-no-quit-world-no-nesting.rkt new file mode 100644 index 0000000..0bbe30d --- /dev/null +++ b/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))))) diff --git a/prospect/examples/actor/chat-no-quit-world.rkt b/prospect/examples/actor/chat-no-quit-world.rkt new file mode 100644 index 0000000..cfb9a4b --- /dev/null +++ b/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)))))) diff --git a/prospect/examples/chat-no-quit-world-no-nesting.rkt b/prospect/examples/chat-no-quit-world-no-nesting.rkt new file mode 100644 index 0000000..f381e91 --- /dev/null +++ b/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) diff --git a/prospect/examples/chat-no-quit-world.rkt b/prospect/examples/chat-no-quit-world.rkt new file mode 100644 index 0000000..ff5bae6 --- /dev/null +++ b/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))