96 lines
3.0 KiB
Racket
96 lines
3.0 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/class)
|
|
(require racket/match)
|
|
|
|
(require "conversation.rkt")
|
|
(require "conversation-socket.rkt")
|
|
(require "standard-thread.rkt")
|
|
|
|
(define pool (make-room 'everybody))
|
|
|
|
(struct groupchat (utterance) #:prefab)
|
|
|
|
(define (session inbound-stream quit-proc)
|
|
(define h (join-room pool 'SESSION))
|
|
(define outbound-stream (flip-stream inbound-stream))
|
|
(send h assert! (topic-publisher outbound-stream))
|
|
(send h assert! (topic-subscriber inbound-stream))
|
|
(send h assert! (topic-publisher groupchat))
|
|
(send h assert! (topic-subscriber groupchat))
|
|
(define (send-text s) (send h say (topic-publisher outbound-stream) (tcp-data #f s)))
|
|
(define (issue-credit) (send h say (topic-subscriber inbound-stream) (tcp-credit 1)))
|
|
(issue-credit)
|
|
(let loop ((prompt? #t))
|
|
(when prompt? (send-text "Ready>> "))
|
|
(match (send h listen)
|
|
[(says (topic 'publisher (== inbound-stream) _) (tcp-eof))
|
|
(send-text "OK, bye\n")]
|
|
[(says (topic 'publisher (== inbound-stream) _) (tcp-data #t "quit"))
|
|
(issue-credit)
|
|
(quit-proc)
|
|
(send-text "OK, will quit accepting\n")
|
|
(loop #t)]
|
|
[(says (topic 'publisher (== inbound-stream) _) (tcp-data #t what))
|
|
(write `(someone said ,what))
|
|
(newline)
|
|
(issue-credit)
|
|
(send-text "Carry on\n")
|
|
(send h say (topic-publisher groupchat) (groupchat what))
|
|
(loop #t)]
|
|
[(says (topic 'publisher (== groupchat) _) (groupchat what))
|
|
(send-text (string-append "CHAT: " what "\n"))
|
|
(loop #t)]
|
|
[(departed _ _)
|
|
(void)]
|
|
[_
|
|
(loop #f)])))
|
|
|
|
(define (listen port-no)
|
|
(standard-thread
|
|
(lambda ()
|
|
(define h (join-room pool 'LISTEN-THREAD))
|
|
(define server-address (tcp-address #f port-no))
|
|
(send h assert! (topic-subscriber (tcp-stream (wild-address) server-address)))
|
|
(define (quit-proc) (send h depart))
|
|
(let loop ()
|
|
(match (send h listen)
|
|
[(arrived
|
|
(topic 'publisher
|
|
(and inbound-stream (tcp-stream (tcp-address (? non-wild?) (? non-wild?))
|
|
(== server-address)))
|
|
_))
|
|
(write `(starting session for ,inbound-stream)) (newline)
|
|
(standard-thread (lambda () (session inbound-stream quit-proc)))
|
|
(loop)]
|
|
[_
|
|
(loop)])))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(tcp-driver pool)
|
|
|
|
(define port-number 5001)
|
|
(display "Listening on port ")
|
|
(display port-number)
|
|
(newline)
|
|
|
|
(listen port-number)
|
|
|
|
(define (wait-until-pool-empty)
|
|
(define h (join-room pool 'WAITER))
|
|
(send h assert! (topic-publisher (wild) #:virtual? #t))
|
|
(send h assert! (topic-subscriber (wild) #:virtual? #t))
|
|
(let loop ((show-count #t) (count 0))
|
|
(when show-count
|
|
(write `(pool has ,count members)) (newline))
|
|
(match (send h listen)
|
|
[(arrived x)
|
|
(write `(,x arrived in pool)) (newline)
|
|
(loop #t (+ count 1))]
|
|
[(departed _ _) (if (= count 1)
|
|
'done
|
|
(loop #t (- count 1)))]
|
|
[_ (loop #f count)])))
|
|
(wait-until-pool-empty)
|