Remove ill-thought-out break-on-departure feature.

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)
+  (define handler
-		 (choice-evt (let ((qb (binding-queue-box b)))
+    (sync (foldl (lambda (b acc)
-			       (if (queue-empty? (unbox qb))
+		   (choice-evt (let ((qb (binding-queue-box b)))
-				   acc
+				 (if (queue-empty? (unbox qb))
-				   (choice-evt acc
+				     acc
-					       (let-values (((first rest) (dequeue (unbox qb))))
+				     (choice-evt acc
-						 (if (and (departed? first)
+						 (let-values (((first rest) (dequeue (unbox qb))))
-							  (binding-break-on-departure? b))
+						   (handle-evt (channel-put-evt (binding-out-ch b)
-						     (begin (break-thread (binding-thread b))
+										first)
-							    never-evt)
+							       (lambda (dummy)
-						     (handle-evt (channel-put-evt
+								 (lambda (state)
-								  (binding-out-ch b)
-								  first)
-								 (lambda (dummy)
 								   (set-box! qb rest)
-								   (room-main state))))))))
+								   state)))))))
-			     (handle-evt (binding-in-ch b)
+			       (handle-evt (binding-in-ch b)
-					 (lambda (message)
+					   (thread-message-handler b))
-					   (room-main (handle-binding-message state b message))))
+			       (handle-evt (thread-dead-evt (binding-thread b))
-			     (handle-evt (thread-dead-evt (binding-thread b))
+					   (thread-death-handler b))))
-					 (lambda (dummy)
+		 (handle-evt (room-state-ch state) join-message-handler)
-					   (room-main (part state b (binding-death-reason b)))))))
+		 (room-state-members state))))
-	       (handle-evt (room-state-ch state)
+  (room-main (handler state)))
-			   (match-lambda
+
-			    (`(join ,name ,break-on-departure? ,invisible?
+(define (thread-message-handler b)
-				    ,in-ch ,out-ch ,disconnect-box
+  (lambda (message)
-				    ,thread ,exit-status)
+    (lambda (state)
-			     (room-main (join state name break-on-departure? invisible?
+      (handle-binding-message state b message))))
-					      in-ch out-ch disconnect-box
+
-					      thread exit-status)))
+(define (thread-death-handler b)
-			    (unexpected (log-warning (format "room-main: unexpected message ~v"
+  (lambda (dummy)
-							     unexpected))
+    (lambda (state)
-					(room-main state))))
+      (part state b (binding-death-reason b)))))
-	       (room-state-members state))))
+
+(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))

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)

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 _)

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)