diff --git a/prospect/actor.rkt b/prospect/actor.rkt index dc36146..10c3bb8 100644 --- a/prospect/actor.rkt +++ b/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! diff --git a/prospect/examples/actor/chat-simplified-internals.rkt b/prospect/examples/actor/chat-simplified-internals.rkt new file mode 100644 index 0000000..80e4afb --- /dev/null +++ b/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))) + )) diff --git a/prospect/examples/chat-simplified-internals.rkt b/prospect/examples/chat-simplified-internals.rkt new file mode 100644 index 0000000..b356fcb --- /dev/null +++ b/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)