syndicate-lang
/
racket-ssh-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Add #:break-on-departure? keyword argument to join-room.

This commit is contained in:
Tony Garnock-Jones 2011-10-23 14:50:35 -04:00
parent 6fb5488274
commit fe6171201f
2 changed files with 25 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
conversation.rkt
View File

@ -30,6 +30,7 @@
(struct room-state (name ch members) #:transparent) (struct room-state (name ch members) #:transparent)
(struct binding (name ;; any (struct binding (name ;; any
break-on-departure? ;; boolean
in-ch ;; sync channel in-ch ;; sync channel
out-ch ;; sync channel out-ch ;; sync channel
disconnect-box ;; blocking-box disconnect-box ;; blocking-box
@ -43,13 +44,14 @@
(thread (lambda () (room-main (room-state name ch '())))) (thread (lambda () (room-main (room-state name ch '()))))
(room ch)) (room ch))
(define (join-room room [name (gensym 'peer)]) (define (join-room room [name (gensym 'peer)] #:break-on-departure? [break-on-departure? #f])
(make-object membership% (room-ch room) name)) (make-object membership% (room-ch room) name break-on-departure?))
(define membership% (define membership%
(class* object% () (class* object% ()
(init room-init) (init room-init)
(init name-init) (init name-init)
(init break-on-departure?-init)
(super-new) (super-new)
@ -66,7 +68,8 @@
(set! connected #f) (set! connected #f)
(set! reason v) (set! reason v)
v))) v)))
(channel-put room `(join ,name ,out-ch ,in-ch ,disconnect-box (channel-put room `(join ,name ,break-on-departure?-init
,out-ch ,in-ch ,disconnect-box
,(current-thread) ,(current-thread-exit-status))) ,(current-thread) ,(current-thread-exit-status)))
(define/public (connected?) (define/public (connected?)
@ -127,9 +130,11 @@
(room-main (part state b (binding-death-reason b))))))) (room-main (part state b (binding-death-reason b)))))))
(handle-evt (room-state-ch state) (handle-evt (room-state-ch state)
(match-lambda (match-lambda
(`(join ,name ,in-ch ,out-ch ,disconnect-box (`(join ,name ,break-on-departure?
,in-ch ,out-ch ,disconnect-box
,thread ,exit-status) ,thread ,exit-status)
(room-main (join state name in-ch out-ch disconnect-box (room-main (join state name break-on-departure?
in-ch out-ch disconnect-box
thread exit-status))) thread exit-status)))
(unexpected (log-warning (format "room-main: unexpected message ~v" (unexpected (log-warning (format "room-main: unexpected message ~v"
unexpected)) unexpected))
@ -149,8 +154,11 @@
message)) message))
state))) state)))
(define (join state name in-ch out-ch disconnect-box thread exit-status) (define (join state name break-on-departure?
(define b (binding name in-ch out-ch disconnect-box in-ch out-ch disconnect-box
thread exit-status)
(define b (binding name break-on-departure?
in-ch out-ch disconnect-box
(box (list->queue (membership-summary state))) (box (list->queue (membership-summary state)))
thread exit-status)) thread exit-status))
(broadcast (add-binding state b) b (arrived name))) (broadcast (add-binding state b) b (arrived name)))
@ -180,4 +188,7 @@
(define (enqueue-message! b message) (define (enqueue-message! b message)
(define qb (binding-queue-box b)) (define qb (binding-queue-box b))
(set-box! qb (enqueue (unbox qb) message))) (if (and (departed? message)
(binding-break-on-departure? b))
(break-thread (binding-thread b))
(set-box! qb (enqueue (unbox qb) message))))

6
test-conversation.rkt
View File

@ -6,6 +6,7 @@
(require racket/match) (require racket/match)
(require "conversation.rkt") (require "conversation.rkt")
(require "standard-thread.rkt")
(define r (make-room)) (define r (make-room))
@ -20,6 +21,11 @@
(else (void))) (else (void)))
(loop)))) (loop))))
(standard-thread (lambda ()
(define handle (join-room r 'cascade #:break-on-departure? #t))
(define-values (i o) (make-pipe))
(sync (read-bytes-evt 128 i))))
(define (interaction i o) (define (interaction i o)
(display "What is your name? > " o) (display "What is your name? > " o)
(flush-output o) (flush-output o)