89 lines
2.5 KiB
Racket
89 lines
2.5 KiB
Racket
#lang marketplace
|
|
;; Equivalent to chat-paper.rkt, but using the raw unsugared
|
|
;; structures rather than the friendly DSL overlay.
|
|
|
|
(require racket/match)
|
|
(require marketplace)
|
|
|
|
(make-nested-vm
|
|
(lambda (vm-pid)
|
|
(process-spec (lambda (boot-pid)
|
|
(lambda (k)
|
|
(k (transition stateless
|
|
(at-meta-level
|
|
(add-endpoint 'listener
|
|
(role 'subscriber
|
|
(tcp-channel ? (tcp-listener 5999) ?)
|
|
'observer)
|
|
listener-event-handler))))))))
|
|
#f)
|
|
|
|
(define listener-event-handler
|
|
(match-lambda
|
|
[(presence-event (role _ (tcp-channel them us _) _))
|
|
(lambda (state)
|
|
(transition state
|
|
(spawn (process-spec (lambda (pid) (lambda (k) (k (chat-session them us)))))
|
|
#f
|
|
#f)))]
|
|
[_
|
|
(lambda (state) (transition state '()))]))
|
|
|
|
(define (chat-session them us)
|
|
(define user (gensym 'user))
|
|
(transition stateless
|
|
(list (listen-to-user user them us)
|
|
(speak-to-user user them us))))
|
|
|
|
(define (listen-to-user user them us)
|
|
(list
|
|
(at-meta-level
|
|
(add-endpoint 'tcp-receiver
|
|
(role 'subscriber
|
|
(tcp-channel them us ?)
|
|
'participant)
|
|
(match-lambda
|
|
[(absence-event _ _)
|
|
(lambda (state)
|
|
(transition state (quit #f #f)))]
|
|
[(message-event _ (tcp-channel _ _ (? bytes? text)))
|
|
(lambda (state)
|
|
(transition state (send-message `(,user says ,text) 'publisher)))]
|
|
[_
|
|
(lambda (state) (transition state '()))])))
|
|
(add-endpoint 'speech-publisher
|
|
(role 'publisher
|
|
`(,user says ,?)
|
|
'participant)
|
|
(lambda (event)
|
|
(lambda (state) (transition state '()))))))
|
|
|
|
(define (speak-to-user user them us)
|
|
(define (say fmt . args)
|
|
(at-meta-level
|
|
(send-message (tcp-channel us them (apply format fmt args))
|
|
'publisher)))
|
|
(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
|
|
(add-endpoint 'tcp-sender
|
|
(role 'publisher
|
|
(tcp-channel us them ?)
|
|
'participant)
|
|
(lambda (event)
|
|
(lambda (state) (transition state '())))))
|
|
(add-endpoint 'speech-subscriber
|
|
(role 'subscriber
|
|
`(,? says ,?)
|
|
'participant)
|
|
(match-lambda
|
|
[(presence-event (role _ `(,who says ,_) _))
|
|
(lambda (state) (transition state (announce who 'arrived)))]
|
|
[(absence-event (role _ `(,who says ,_) _) _)
|
|
(lambda (state) (transition state (announce who 'departed)))]
|
|
[(message-event _ `(,who says ,what))
|
|
(lambda (state) (transition state (say "~a: ~a" who what)))]))))
|