diff --git a/conversation.rkt b/conversation.rkt index 2447230..3e18ef1 100644 --- a/conversation.rkt +++ b/conversation.rkt @@ -32,6 +32,7 @@ (struct room-state (name ch members) #:transparent) (struct binding (name ;; any break-on-departure? ;; boolean + invisible? ;; boolean in-ch ;; sync channel out-ch ;; sync channel disconnect-box ;; blocking-box @@ -45,14 +46,17 @@ (thread (lambda () (room-main (room-state name ch '())))) (room name ch)) -(define (join-room room [name (gensym 'peer)] #:break-on-departure? [break-on-departure? #f]) - (make-object membership% (room-ch room) name break-on-departure?)) +(define (join-room room [name (gensym 'peer)] + #:break-on-departure? [break-on-departure? #f] + #:invisible? [invisible? #f]) + (make-object membership% (room-ch room) name break-on-departure? invisible?)) (define membership% (class* object% () (init room-init) (init name-init) (init break-on-departure?-init) + (init invisible?-init) (super-new) @@ -69,7 +73,7 @@ (set! connected #f) (set! reason v) v))) - (channel-put room `(join ,name ,break-on-departure?-init + (channel-put room `(join ,name ,break-on-departure?-init ,invisible?-init ,out-ch ,in-ch ,disconnect-box ,(current-thread) ,(current-thread-exit-status))) @@ -131,10 +135,10 @@ (room-main (part state b (binding-death-reason b))))))) (handle-evt (room-state-ch state) (match-lambda - (`(join ,name ,break-on-departure? + (`(join ,name ,break-on-departure? ,invisible? ,in-ch ,out-ch ,disconnect-box ,thread ,exit-status) - (room-main (join state name break-on-departure? + (room-main (join state name break-on-departure? invisible? in-ch out-ch disconnect-box thread exit-status))) (unexpected (log-warning (format "room-main: unexpected message ~v" @@ -155,18 +159,22 @@ message)) state))) -(define (join state name break-on-departure? +(define (join state name break-on-departure? invisible? in-ch out-ch disconnect-box thread exit-status) - (define b (binding name break-on-departure? + (define b (binding name break-on-departure? invisible? in-ch out-ch disconnect-box (box (list->queue (membership-summary state))) thread exit-status)) - (broadcast (add-binding state b) b (arrived name))) + (if invisible? + (add-binding state b) + (broadcast (add-binding state b) b (arrived name)))) (define (part state b why) (set-blocking-box! (binding-disconnect-box b) why) - (broadcast (remove-binding state b) b (departed (binding-name b) why))) + (if (binding-invisible? b) + (remove-binding state b) + (broadcast (remove-binding state b) b (departed (binding-name b) why)))) (define (membership-summary state) (map (lambda (member) (arrived (binding-name member))) diff --git a/ssh-session.rkt b/ssh-session.rkt index e739d92..45837f9 100644 --- a/ssh-session.rkt +++ b/ssh-session.rkt @@ -528,7 +528,7 @@ SSH_MSG_KEXINIT handle-msg-kexinit)) (define (spy-on room) - (define handle (join-room room (gensym 'spy))) + (define handle (join-room room (gensym 'spy) #:invisible? #t)) (define (loop) (write (list (room-name room) (send handle listen))) (newline)