2012-03-11 01:26:02 +00:00
|
|
|
#lang racket/base
|
|
|
|
|
|
|
|
(require racket/class)
|
|
|
|
(require racket/match)
|
|
|
|
|
|
|
|
(require "conversation.rkt")
|
|
|
|
(require "conversation-socket.rkt")
|
2012-03-11 17:08:04 +00:00
|
|
|
(require "standard-thread.rkt")
|
2012-03-11 01:26:02 +00:00
|
|
|
|
|
|
|
(define pool (make-room 'everybody))
|
|
|
|
|
2012-03-11 17:08:04 +00:00
|
|
|
(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))
|
2012-03-13 19:08:32 +00:00
|
|
|
(define (send-text s) (send h say (topic-publisher outbound-stream) (tcp-data s)))
|
2012-03-11 17:08:04 +00:00
|
|
|
(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")]
|
2012-03-13 19:08:32 +00:00
|
|
|
[(says (topic 'publisher (== inbound-stream) _) (tcp-data "quit"))
|
2012-03-11 17:08:04 +00:00
|
|
|
(issue-credit)
|
|
|
|
(quit-proc)
|
|
|
|
(send-text "OK, will quit accepting\n")
|
|
|
|
(loop #t)]
|
2012-03-13 19:08:32 +00:00
|
|
|
[(says (topic 'publisher (== inbound-stream) _) (tcp-data what))
|
2012-03-11 17:08:04 +00:00
|
|
|
(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)])))
|
2012-03-11 01:26:02 +00:00
|
|
|
|
|
|
|
(define (listen port-no)
|
2012-03-11 17:08:04 +00:00
|
|
|
(standard-thread
|
|
|
|
(lambda ()
|
|
|
|
(define h (join-room pool 'LISTEN-THREAD))
|
|
|
|
(define server-address (tcp-address #f port-no))
|
2012-03-13 09:29:27 +00:00
|
|
|
(send h assert! (topic-subscriber (tcp-stream (wild-address) server-address)
|
|
|
|
#:virtual? #t))
|
2012-03-11 17:08:04 +00:00
|
|
|
(define (quit-proc) (send h depart))
|
2012-03-11 01:26:02 +00:00
|
|
|
(let loop ()
|
|
|
|
(match (send h listen)
|
2012-03-13 19:05:00 +00:00
|
|
|
[(arrived (topic 'publisher (and inbound-stream (tcp-stream _ (== server-address))) #f))
|
2012-03-11 17:08:04 +00:00
|
|
|
(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)
|
2012-03-11 01:26:02 +00:00
|
|
|
|
2012-03-11 17:08:04 +00:00
|
|
|
(listen port-number)
|
2012-03-11 01:26:02 +00:00
|
|
|
|
|
|
|
(define (wait-until-pool-empty)
|
2012-03-13 09:29:27 +00:00
|
|
|
(define h (join-room pool 'POOL-WAITER))
|
2012-03-11 17:08:04 +00:00
|
|
|
(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))
|
2012-03-11 01:26:02 +00:00
|
|
|
(match (send h listen)
|
2012-03-13 09:29:27 +00:00
|
|
|
[(arrived (and x (topic _ _ #t)))
|
|
|
|
(write `(ignoring arrival of ,x)) (newline)
|
|
|
|
(loop #f count)]
|
2012-03-11 17:08:04 +00:00
|
|
|
[(arrived x)
|
|
|
|
(write `(,x arrived in pool)) (newline)
|
|
|
|
(loop #t (+ count 1))]
|
2012-03-13 09:29:27 +00:00
|
|
|
[(departed (topic _ _ #f) _) (if (= count 1)
|
|
|
|
'done
|
|
|
|
(loop #t (- count 1)))]
|
2012-03-11 17:08:04 +00:00
|
|
|
[_ (loop #f count)])))
|
2012-03-11 01:26:02 +00:00
|
|
|
(wait-until-pool-empty)
|