From 6db845eda59f56c662089d071c1e42aacc707d85 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 26 Oct 2011 19:10:23 -0400 Subject: [PATCH] Remove ill-thought-out break-on-departure feature. --- conversation.rkt | 84 ++++++++++++++++++++++--------------------- ssh-session.rkt | 7 ++-- ssh-transport.rkt | 9 +++-- test-conversation.rkt | 5 --- 4 files changed, 55 insertions(+), 50 deletions(-) diff --git a/conversation.rkt b/conversation.rkt index cace762..451c06c 100644 --- a/conversation.rkt +++ b/conversation.rkt @@ -40,7 +40,6 @@ (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 @@ -56,9 +55,8 @@ (room name ch)) (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?)) + (make-object membership% (room-ch room) name invisible?)) (define (wait-for-members room members) (define handle (join-room room (gensym 'wait-for-members) #:invisible? #t)) @@ -86,7 +84,6 @@ (class* object% () (init room-init) (init name-init) - (init break-on-departure?-init) (init invisible?-init) (super-new) @@ -104,7 +101,7 @@ (set! connected #f) (set! reason v) v))) - (channel-put room `(join ,name ,break-on-departure?-init ,invisible?-init + (channel-put room `(join ,name ,invisible?-init ,out-ch ,in-ch ,disconnect-box ,(current-thread) ,(current-thread-exit-status))) @@ -150,40 +147,47 @@ (define (room-main state) ;;(write `(room-main ,state)) (newline) - (sync (foldl (lambda (b acc) - (choice-evt (let ((qb (binding-queue-box b))) - (if (queue-empty? (unbox qb)) - acc - (choice-evt acc - (let-values (((first rest) (dequeue (unbox qb)))) - (if (and (departed? first) - (binding-break-on-departure? b)) - (begin (break-thread (binding-thread b)) - never-evt) - (handle-evt (channel-put-evt - (binding-out-ch b) - first) - (lambda (dummy) + (define handler + (sync (foldl (lambda (b acc) + (choice-evt (let ((qb (binding-queue-box b))) + (if (queue-empty? (unbox qb)) + acc + (choice-evt acc + (let-values (((first rest) (dequeue (unbox qb)))) + (handle-evt (channel-put-evt (binding-out-ch b) + first) + (lambda (dummy) + (lambda (state) (set-box! qb rest) - (room-main state)))))))) - (handle-evt (binding-in-ch b) - (lambda (message) - (room-main (handle-binding-message state b message)))) - (handle-evt (thread-dead-evt (binding-thread b)) - (lambda (dummy) - (room-main (part state b (binding-death-reason b))))))) - (handle-evt (room-state-ch state) - (match-lambda - (`(join ,name ,break-on-departure? ,invisible? - ,in-ch ,out-ch ,disconnect-box - ,thread ,exit-status) - (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" - unexpected)) - (room-main state)))) - (room-state-members state)))) + state))))))) + (handle-evt (binding-in-ch b) + (thread-message-handler b)) + (handle-evt (thread-dead-evt (binding-thread b)) + (thread-death-handler b)))) + (handle-evt (room-state-ch state) join-message-handler) + (room-state-members state)))) + (room-main (handler state))) + +(define (thread-message-handler b) + (lambda (message) + (lambda (state) + (handle-binding-message state b message)))) + +(define (thread-death-handler b) + (lambda (dummy) + (lambda (state) + (part state b (binding-death-reason b))))) + +(define join-message-handler + (lambda (message) + (lambda (state) + (match message + (`(join ,name ,invisible? ,in-ch ,out-ch ,disconnect-box + ,thread ,exit-status) + (join state name invisible? in-ch out-ch disconnect-box + thread exit-status)) + (unexpected (log-warning (format "room-main: unexpected message ~v" unexpected)) + state))))) (define (binding-death-reason b) (define es (binding-exit-status b)) @@ -198,10 +202,10 @@ message)) state))) -(define (join state name break-on-departure? invisible? +(define (join state name invisible? in-ch out-ch disconnect-box thread exit-status) - (define b (binding name break-on-departure? invisible? + (define b (binding name invisible? in-ch out-ch disconnect-box (box (list->queue (membership-summary state))) thread exit-status)) diff --git a/ssh-session.rkt b/ssh-session.rkt index 414934b..79325bd 100644 --- a/ssh-session.rkt +++ b/ssh-session.rkt @@ -931,7 +931,7 @@ peer-identification-string #f)))) - (join-room session-room 'app #:break-on-departure? #t)) + (join-room session-room 'app)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Session API @@ -1030,7 +1030,10 @@ (define (simple-ssh-server handle channel-open-callback state) (let loop ((state state)) (match (send handle listen) - ((arrived _) (loop state)) + ((arrived _) + (loop state)) + ((and departure (departed _ _)) + (send handle depart departure)) ((says _ (rpc-request reply-to id message) _) (match message (`(open-channel ,username ,channel-type ,extra-request-data) diff --git a/ssh-transport.rkt b/ssh-transport.rkt index 55e1491..e53c263 100644 --- a/ssh-transport.rkt +++ b/ssh-transport.rkt @@ -267,7 +267,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (ssh-reader in room) - (define handle (join-room room 'read-thread #:break-on-departure? #t)) + (define handle (join-room room 'read-thread)) (define packet-size-limit (default-packet-limit)) (define (main-loop config sequence-number remaining-credit) @@ -322,12 +322,14 @@ (handle-evt (read-bytes-evt first-block-size in) (lambda (encrypted) (cond - ((eof-object? encrypted)) ;; we gracefully exit + ((eof-object? encrypted) + (send handle depart 'eof)) ;; we gracefully exit (else (handle-packet-start (decryptor encrypted)))))) never-evt) (handle-evt (send handle listen-evt) (match-lambda ((arrived _) (wait-for-event)) + ((and departure (departed _ _)) (send handle depart departure)) ((says _ (credit 'read-thread amount) _) (main-loop config sequence-number (+ remaining-credit amount))) ((says _ (? new-keys? nk) _) @@ -345,7 +347,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (ssh-writer out room) - (define handle (join-room room 'write-thread #:break-on-departure? #t)) + (define handle (join-room room 'write-thread)) (define (main-loop config sequence-number) (match-define (crypto-configuration cipher cipher-description @@ -354,6 +356,7 @@ (match (send handle listen) ((arrived _) (main-loop config sequence-number)) + ((and departure (departed _ _)) (send handle depart departure)) ((says _ (? new-keys? nk) _) (main-loop (apply-negotiated-options nk #t) sequence-number)) ((says _ 'flush _) diff --git a/test-conversation.rkt b/test-conversation.rkt index cbf14a5..e3ffc7d 100644 --- a/test-conversation.rkt +++ b/test-conversation.rkt @@ -21,11 +21,6 @@ (else (void))) (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) (display "What is your name? > " o) (flush-output o)