50 lines
1.4 KiB
Racket
50 lines
1.4 KiB
Racket
|
#lang marketplace
|
||
|
|
|
||
|
|
(require "../support/debug.rkt")
|
||
|
|
|
||
|
|
(debug
|
||
|
|
(nested-vm
|
||
|
|
#:debug-name 'echo
|
||
|
|
(at-meta-level
|
||
|
|
(endpoint
|
||
|
|
#:subscriber (tcp-channel ? (tcp-listener 5999) ?)
|
||
|
|
#:observer
|
||
|
|
#:conversation (tcp-channel them us _)
|
||
|
|
#:on-presence
|
||
|
|
(debug
|
||
|
|
(spawn #:debug-name (list 'session them)
|
||
|
|
#:child (chat-session them us)))))))
|
||
|
|
|
||
|
|
(define (chat-session them us)
|
||
|
|
(define user (gensym 'user))
|
||
|
|
(transition stateless
|
||
|
|
(listen-to-user user them us)
|
||
|
|
(speak-to-user user them us)))
|
||
|
|
|
||
|
|
(define (listen-to-user user them us)
|
||
|
|
(list
|
||
|
|
(endpoint #:publisher `(,user says ,?))
|
||
|
|
(at-meta-level
|
||
|
|
(endpoint #:subscriber (tcp-channel them us ?)
|
||
|
|
#:on-absence (quit)
|
||
|
|
[(tcp-channel _ _ (? bytes? text))
|
||
|
|
(send-message `(,user says ,text))]))))
|
||
|
|
|
||
|
|
(define (speak-to-user user them us)
|
||
|
|
(define (say fmt . args)
|
||
|
|
(at-meta-level
|
||
|
|
(send-message
|
||
|
|
(tcp-channel us them (apply format fmt args)))))
|
||
|
|
(define (announce who did-what)
|
||
|
|
(unless (equal? who user)
|
||
|
|
(say "~s ~s.~n" who did-what)))
|
||
|
|
(list
|
||
|
|
(say "You are ~s.~n" user)
|
||
|
|
(at-meta-level
|
||
|
|
(endpoint #:publisher (tcp-channel us them ?)))
|
||
|
|
(endpoint #:subscriber `(,? says ,?)
|
||
|
|
#:conversation `(,who says ,_)
|
||
|
|
#:on-presence (announce who 'arrived)
|
||
|
|
#:on-absence (announce who 'departed)
|
||
|
|
[`(,who says ,what) (say "~a: ~a" who what)])))
|