fix connection closing

Now when the user quits, the developer also exits.

5 files changed, 47 insertions, 35 deletions

diff --git a/Role/Developer.hs b/Role/Developer.hs
index ffba5c4..64ff094 100644
--- a/Role/Developer.hs
+++ b/Role/Developer.hs
@@ -39,12 +39,10 @@ developer ichan ochan _ = withLogger "debug-me-developer.log" $ \logger -> do
 	devstate <- processSessionStart ochan logger
 	ok <- authUser ichan ochan devstate logger
 	if ok
-		then inRawMode $ do
-			_ <- sendTtyInput ichan devstate logger
-				`concurrently` sendTtyOutput ochan devstate logger
-			return ()
-		else do
-			hPutStrLn stderr "\nUser did not grant access to their terminal."
+		then inRawMode $ void $ 
+			sendTtyInput ichan devstate logger
+				`race` sendTtyOutput ochan devstate logger
+		else hPutStrLn stderr "\nUser did not grant access to their terminal."
 
 data DeveloperState = DeveloperState
 	{ lastSeen :: Hash
diff --git a/Server.hs b/Server.hs
index 527ac02..5de184d 100644
--- a/Server.hs
+++ b/Server.hs
@@ -142,13 +142,15 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(loghv, sid) -> do
 		writeSession session l
 	
 	-- Relay Developer messages from the channel to the user's websocket.
-	relaytouser userchan = relayToSocket conn $ do
+	relaytouser userchan = do
 		v <- atomically $ readTMChan userchan
-		return $ case v of
+		case v of
 			Just l -> case loggedMessage l of
-				Developer m -> Just (Developer m)
-				User _ -> Nothing
-			Nothing -> Nothing
+				Developer m -> do
+					sendBinaryData conn (LogMessage (Developer m))
+					relaytouser userchan
+				User _ -> relaytouser userchan
+			Nothing -> return ()
 
 developer ::  ServerOpts -> TVar ServerState -> SessionID -> WS.Connection -> IO ()
 developer o ssv sid conn = bracket setup cleanup go
@@ -179,17 +181,22 @@ developer o ssv sid conn = bracket setup cleanup go
 			writeSession session l
 		User _ -> return () -- developer cannot send User messages
 	
-	-- Relay user messages from the channel to the developer's websocket.
-	relaytodeveloper devchan = relayToSocket conn $ do
+	-- Relay user messages from the developer's clone of the
+	-- broadcast channel to the developer's websocket.
+	relaytodeveloper devchan = do
 		v <- atomically $ readTMChan devchan
-		return $ case v of
+		case v of
 			Just l -> case loggedMessage l of
-				User m -> Just (User m)
+				User m -> do
+					sendBinaryData conn (LogMessage (User m))
+					relaytodeveloper devchan
 				-- TODO: Relay messages from other
 				-- developers, without looping back
 				-- the developer's own messages.
-				Developer _ -> Nothing
-			Nothing -> Nothing
+				Developer _ -> relaytodeveloper devchan
+			Nothing -> do
+				sendBinaryData conn Done
+				return ()
 
 -- | Replay the log of what's happened in the session so far,
 -- and return a channel that will get new session activity.
diff --git a/TODO b/TODO
index 2562b22..280b3eb 100644
--- a/TODO
+++ b/TODO
@@ -1,4 +1,3 @@
-* Developer keeps running when user quits.
 * The current rules for when an Activity Entered is accepted allow it to
   refer to an older activity than the last one. If echoing is disabled,
   two Activity Entered could be sent, each pointing at the most recent
diff --git a/WebSockets.hs b/WebSockets.hs
index f3712a9..d8d43e7 100644
--- a/WebSockets.hs
+++ b/WebSockets.hs
@@ -30,6 +30,7 @@ import qualified Data.Text as T
 import qualified Data.ByteString.Lazy as L
 import Data.List
 import Data.Monoid
+import Control.Monad
 
 -- | Enable compression.
 connectionOptions :: ConnectionOptions
@@ -76,17 +77,25 @@ clientApp mode mksent filterreceived a conn = do
 	setup = do
 		schan <- newTMChanIO
 		rchan <- newTMChanIO
-		sthread <- async $ relayFromSocket conn $ \v ->
-			case filterreceived v of
-				Nothing -> return ()
-				Just r -> atomically $ writeTMChan rchan r
-		rthread <- async $ relayToSocket conn $
-			fmap mksent <$> atomically (readTMChan schan)
+		sthread <- async $ relayToSocket conn mksent $
+			atomically (readTMChan schan)
+		rthread <- async $ do
+			relayFromSocket conn $ \v -> do
+				case filterreceived v of
+					Nothing -> return ()
+					Just r -> atomically $ writeTMChan rchan r
+			-- Server sent Done, so close channels.
+			atomically $ do
+				closeTMChan schan
+				closeTMChan rchan
 		return (schan, rchan, sthread, rthread)
-	cleanup (_, _, sthread, rthread) = do
+	cleanup (schan, _, sthread, rthread) = do
 		sendBinaryData conn Done
-		() <- wait sthread
-		wait rthread
+		atomically $ closeTMChan schan
+		-- Wait for any more data from the server.
+		-- These often die with a ConnectionClosed.
+		void $ waitCatch sthread
+		void $ waitCatch rthread
 	go sid (schan, rchan, _, _) = a schan rchan sid
 
 relayFromSocket :: Connection -> (LogMessage -> IO ()) -> IO ()
@@ -98,21 +107,19 @@ relayFromSocket conn sender = go
 			LogMessage msg -> do
 				sender msg
 				go
-			Done -> do
-				print "GOT DONE"
-				return ()
+			Done -> return ()
 			WireProtocolError e -> protocolError conn e
 			_ -> protocolError conn "Protocol error"
 
-relayToSocket :: Connection -> (IO (Maybe LogMessage)) -> IO ()
-relayToSocket conn getter = go
+relayToSocket :: Connection -> (received -> LogMessage) -> IO (Maybe received) -> IO ()
+relayToSocket conn mksent getter = go
   where
 	go = do
 		mmsg <- getter
 		case mmsg of
 			Nothing -> return ()
 			Just msg -> do
-				sendBinaryData conn (LogMessage msg)
+				sendBinaryData conn $ LogMessage $ mksent msg
 				go
 
 -- | Framing protocol used over a websocket connection.
diff --git a/debug-me.1 b/debug-me.1
index 3c190e6..b730010 100644
--- a/debug-me.1
+++ b/debug-me.1
@@ -32,10 +32,11 @@ Replay a debug-me logfile.
 .IP "--download url"
 Download a debug-me log file from the specified url. Note that if the
 debug-me session is still in progress, this will continue downloading
-until the session ends.
+until the session ends. The proof chain in the log file is verified
+as it is downloaded, but developer gpg signatures are not verified.
 .IP "--watch url"
 Connect to a debug-me session on the specified url and display what
-happens in the session. Keystrokes will not be sent to the session.
+happens in the session. Your keystrokes will not be sent to the session.
 .IP "--graphviz logfile"
 Uses graphviz to generate a visualization of a debug-me log file.
 .IP "--show-hashes"