74 lines
1.7 KiB
Racket
74 lines
1.7 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/class)
|
|
(require racket/match)
|
|
|
|
(require "conversation.rkt")
|
|
(require "conversation-socket.rkt")
|
|
|
|
(define pool (make-room 'everybody))
|
|
|
|
(define (handle-connection sock quit-proc)
|
|
(join-room pool)
|
|
(define h (join-room sock))
|
|
(match (send h listen)
|
|
((arrived peer-name)
|
|
(let loop ()
|
|
(send h say "Ready>> ")
|
|
(sync (handle-evt (send h listen-evt)
|
|
(match-lambda
|
|
((says _ _ 'eof)
|
|
(send h say "OK, bye\n"))
|
|
((says _ "quit" 'data)
|
|
(send h say (credit peer-name 1))
|
|
(quit-proc)
|
|
(send h say "OK, will quit accepting\n")
|
|
(loop))
|
|
((says _ what 'data)
|
|
(write what)
|
|
(newline)
|
|
(send h say (credit #f 1))
|
|
(send h say "Carry on\n")
|
|
(loop))
|
|
((departed _ _) (void))
|
|
(else (loop))))
|
|
(handle-evt (send h disconnected-evt) void))))))
|
|
|
|
(define (listen port-no)
|
|
(define r (make-room))
|
|
(tcp-server-actor r
|
|
`((initial-accept-credit 1)
|
|
(read-mode lines)
|
|
(initial-read-credit 1))
|
|
port-no)
|
|
(define h (join-room r 'main))
|
|
(match (send h listen)
|
|
((arrived listener-name)
|
|
(let loop ()
|
|
(match (send h listen)
|
|
((says _ sock 'accepted)
|
|
(thread (lambda ()
|
|
(handle-connection sock
|
|
(lambda ()
|
|
(send h depart 'told-to-quit)))))
|
|
(send h say (credit listener-name 1)))
|
|
(unexpected
|
|
(write `(unexpected ,unexpected))
|
|
(newline)))
|
|
(loop)))))
|
|
|
|
(thread (lambda ()
|
|
(join-room pool)
|
|
(listen 5001)))
|
|
|
|
(define (wait-until-pool-empty)
|
|
(define h (join-room pool))
|
|
(let loop ((count 0))
|
|
(match (send h listen)
|
|
((arrived _) (loop (+ count 1)))
|
|
((departed _ _) (if (= count 1)
|
|
'done
|
|
(loop (- count 1))))
|
|
(_ (loop count)))))
|
|
(wait-until-pool-empty)
|