fix probable race in use of restoreHashes

I think there was a race where a SessionKey message had been drained
from the TChan, but not yet added to the developer state, which was
resonsible for recent instability at startup.

It manifested as protocol errors where the prevActivity hash was wrongly
Nothing.

Fixed by adding a MissingHashes type to tag things whose hashes have
been stripped, and adding back the hashes when needed, which always
happens inside atomically blocks, so won't have such a race.

9 files changed, 91 insertions, 107 deletions

diff --git a/PrevActivity.hs b/PrevActivity.hs
index 32e647d..7c5e808 100644
--- a/PrevActivity.hs
+++ b/PrevActivity.hs
@@ -5,11 +5,11 @@ import Crypto
 
 import Control.Concurrent.STM
 
--- | Remove the prevActivity from a message. Doing this before sending
+-- | Remove the hashes from a message. Doing this before sending
 -- it over the wire saves transmitting that data, without weakening
 -- security at all.
-removePrevActivityHash :: AnyMessage -> AnyMessage
-removePrevActivityHash msg = case msg of
+removeHashes :: AnyMessage -> MissingHashes AnyMessage
+removeHashes msg = MissingHashes $ case msg of
 	User (ActivityMessage a) -> User (go a)
 	Developer (ActivityMessage a) -> Developer (go a)
 	_ -> msg
@@ -18,15 +18,12 @@ removePrevActivityHash msg = case msg of
 
 type RecentActivity = STM (SigVerifier, [Hash])
 
-noRecentActivity :: RecentActivity
-noRecentActivity = return (mempty, [])
-
--- | Restore the prevActivity to a message received without one.
+-- | Restore the hashes to a message received.
 -- This needs a RecentActivity cache, and it tries hashes from that cache
--- as the prevActivity until it finds one that makes the message's
--- signature verify.
-restorePrevActivityHash :: RecentActivity -> AnyMessage -> STM AnyMessage
-restorePrevActivityHash ra msg = case msg of
+-- to find the one that was used when the message was sent, at which 
+-- point the message's signature will verify.
+restoreHashes :: RecentActivity -> MissingHashes AnyMessage -> STM AnyMessage
+restoreHashes ra (MissingHashes msg) = case msg of
 	User (ActivityMessage act) -> 
 		User . ActivityMessage <$> (go act =<< ra)
 	Developer (ActivityMessage act) ->
diff --git a/Role/Developer.hs b/Role/Developer.hs
index 56af3b4..6763e1a 100644
--- a/Role/Developer.hs
+++ b/Role/Developer.hs
@@ -40,17 +40,15 @@ import Network.URI
 run :: DeveloperOpts -> IO ()
 run = run' developer . debugUrl
 
-run' :: (TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()) -> URI -> IO ()
+run' :: (TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO ()) -> URI -> IO ()
 run' runner url = do
 	app <- do
 		let connect = ConnectMode $ T.pack $ show url
 		dsv <- newEmptyTMVarIO
-		let recentactivity = developerStateRecentActivity dsv
-		return $ clientApp connect recentactivity Developer Just $
-			runner dsv
+		return $ clientApp connect Developer Just $ runner dsv
 	void $ runClientApp app
 
-developer :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()
+developer :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO ()
 developer dsv ichan ochan sid = withSessionLogger (Just "remote") sid $ \logger -> do
 	sk <- genMySessionKey
 	(controlinput, controloutput) <- openControlWindow
@@ -82,7 +80,7 @@ developer dsv ichan ochan sid = withSessionLogger (Just "remote") sid $ \logger
 	go _ _ _ _ SessionEnded =
 		hPutStrLn stderr "\r\n** This debug-me session has already ended.\r"
 
-watchSessionReadOnly :: TMChan AnyMessage -> Logger -> TVar DeveloperState -> IO ()
+watchSessionReadOnly :: TMChan (MissingHashes AnyMessage) -> Logger -> TVar DeveloperState -> IO ()
 watchSessionReadOnly ochan logger st = loop
   where
 	loop = do
@@ -118,14 +116,11 @@ data DeveloperState = DeveloperState
 	deriving (Show)
 
 -- | RecentActivity that uses the DeveloperState.
-developerStateRecentActivity :: TMVar (TVar DeveloperState) -> RecentActivity
-developerStateRecentActivity dsv = go =<< tryReadTMVar dsv
-  where
-	go Nothing = noRecentActivity
-	go (Just ds) = do
-		st <- readTVar ds
-		let hs = lastSeen st : enteredSince st ++ fromOtherDevelopersSince st
-		return (userSigVerifier st <> developerSigVerifier st, hs)
+developerStateRecentActivity :: TVar DeveloperState -> RecentActivity
+developerStateRecentActivity devstate = do
+	st <- readTVar devstate
+	let hs = lastSeen st : enteredSince st ++ fromOtherDevelopersSince st
+	return (userSigVerifier st <> developerSigVerifier st, hs)
 
 -- | Read things typed by the developer, and forward them to the TMChan.
 sendTtyInput :: TMChan (Message Entered) -> TVar DeveloperState -> Logger -> IO ()
@@ -185,7 +180,7 @@ sendControlOutput controloutput ichan devstate logger = loop
 -- | Read activity from the TMChan and display it to the developer.
 --
 -- Control messages are forwarded on to the ControlInput.
-sendTtyOutput :: TMChan AnyMessage -> TVar DeveloperState -> TMChan ControlInput -> Logger -> IO ()
+sendTtyOutput :: TMChan (MissingHashes AnyMessage) -> TVar DeveloperState -> TMChan ControlInput -> Logger -> IO ()
 sendTtyOutput ochan devstate controlinput logger = go
   where
 	go = do
@@ -214,7 +209,7 @@ data AuthResult = Authed | AuthFailed | SessionEnded
 -- | Present our session key to the user. 
 -- Wait for them to accept or reject it, while displaying any Seen data
 -- in the meantime.
-authUser :: PerhapsSigned PublicKey -> TMChan (Message Entered) -> TMChan AnyMessage -> TVar DeveloperState -> Logger -> IO AuthResult
+authUser :: PerhapsSigned PublicKey -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> TVar DeveloperState -> Logger -> IO AuthResult
 authUser spk ichan ochan devstate logger = do
 	ds <- atomically $ readTVar devstate
 	let msg = ControlMessage $ mkSigned (developerSessionKey ds) 
@@ -263,44 +258,49 @@ emitOutput NoOutput =
 
 -- | Get messages from server, check their signature, and make sure that they
 -- are properly chained from past messages, before returning.
-getServerMessage :: TMChan AnyMessage -> TVar DeveloperState -> POSIXTime -> STM (Maybe (Output, AnyMessage))
+getServerMessage :: TMChan (MissingHashes AnyMessage) -> TVar DeveloperState -> POSIXTime -> STM (Maybe (Output, AnyMessage))
 getServerMessage ochan devstate ts = do
-	let ignore = getServerMessage ochan devstate ts
-	mmsg <- readTMChan ochan
-	case mmsg of
+	mwiremsg <- readTMChan ochan
+	case mwiremsg of
 		Nothing -> return Nothing
-		Just (User msg) -> do
-			ds <- readTVar devstate
-			-- Check user's signature before doing anything else.
-			if verifySigned (userSigVerifier ds) msg
-				then do
-					o <- processuser ds msg
-					return (Just (o, User msg))
-				else return $ Just (ProtocolError ds $ "Bad signature on message from user: " ++ show msg, User msg)
-		-- When other developers connect, learn their SessionKeys.
-		Just (Developer msg@(ControlMessage (Control (SessionKey spk) _))) -> do
-			let sigverifier = mkSigVerifier $ case spk of
-				GpgSigned pk _ -> pk
-				UnSigned pk -> pk
-			if verifySigned sigverifier msg
-				then do
-					ds <- readTVar devstate
-					let sv = developerSigVerifier ds
-					let sv' = sv `mappend` sigverifier
-					writeTVar devstate $ ds
-						{ developerSigVerifier = sv'
-						}
-					processdeveloper ds msg
-					return (Just (NoOutput, Developer msg))
-				else ignore
-		Just (Developer msg) -> do
-			ds <- readTVar devstate
-			if verifySigned (developerSigVerifier ds) msg
-				then do
-					processdeveloper ds msg
-					return (Just (NoOutput, Developer msg))
-				else ignore
+		Just msg -> process =<< restoreHashes recentactivity msg
   where
+	recentactivity = developerStateRecentActivity devstate
+
+	process (User msg) = do
+		ds <- readTVar devstate
+		-- Check user's signature before doing anything else.
+		if verifySigned (userSigVerifier ds) msg
+			then do
+				o <- processuser ds msg
+				return (Just (o, User msg))
+			else return $ Just (ProtocolError ds $ "Bad signature on message from user: " ++ show msg, User msg)
+	-- When other developers connect, learn their SessionKeys.
+	process (Developer msg@(ControlMessage (Control (SessionKey spk) _))) = do
+		let sigverifier = mkSigVerifier $ case spk of
+			GpgSigned pk _ -> pk
+			UnSigned pk -> pk
+		if verifySigned sigverifier msg
+			then do
+				ds <- readTVar devstate
+				let sv = developerSigVerifier ds
+				let sv' = sv `mappend` sigverifier
+				writeTVar devstate $ ds
+					{ developerSigVerifier = sv'
+					}
+				processdeveloper ds msg
+				return (Just (NoOutput, Developer msg))
+			else ignore
+	process (Developer msg) = do
+		ds <- readTVar devstate
+		if verifySigned (developerSigVerifier ds) msg
+			then do
+				processdeveloper ds msg
+				return (Just (NoOutput, Developer msg))
+			else ignore
+	
+	ignore = getServerMessage ochan devstate ts
+	
 	processuser ds (ActivityMessage act@(Activity (Seen (Val b)) _ _ _)) = do
 		let (legal, ds') = isLegalSeen act ds ts
 		if legal
@@ -385,9 +385,9 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _ _) ds ts
 
 -- | Start by reading the initial two messages from the user,
 -- their session key and the startup message.
-processSessionStart :: MySessionKey -> TMChan AnyMessage -> Logger -> TMVar (TVar DeveloperState) -> IO (TVar DeveloperState, Output)
+processSessionStart :: MySessionKey -> TMChan (MissingHashes AnyMessage) -> Logger -> TMVar (TVar DeveloperState) -> IO (TVar DeveloperState, Output)
 processSessionStart sk ochan logger dsv = do
-	sessionmsg <- fromMaybe (error "Did not get session initialization message")
+	MissingHashes sessionmsg <- fromMaybe (error "Did not get session initialization message")
 		<$> atomically (readTMChan ochan)
 	logger sessionmsg
 	sigverifier <- case sessionmsg of
@@ -413,7 +413,7 @@ processSessionStart sk ochan logger dsv = do
 		, developerSigVerifier = mempty
 		}
 	atomically $ putTMVar dsv st
-	startmsg <- fromMaybe (error "Did not get session startup message")
+	MissingHashes startmsg <- fromMaybe (error "Did not get session startup message")
 		<$> atomically (readTMChan ochan)
 	logger startmsg
 	let (starthash, output) = case startmsg of
diff --git a/Role/Downloader.hs b/Role/Downloader.hs
index 094e7de..d013344 100644
--- a/Role/Downloader.hs
+++ b/Role/Downloader.hs
@@ -14,7 +14,7 @@ import Data.Time.Clock.POSIX
 run :: DownloadOpts -> IO ()
 run = run' downloader . downloadUrl
 
-downloader :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()
+downloader :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO ()
 downloader dsv _ichan ochan sid = do
 	let logfile = sessionLogFile "." sid
 	putStrLn $ "Starting download to " ++ logfile
diff --git a/Role/User.hs b/Role/User.hs
index 1e842d0..e999b1c 100644
--- a/Role/User.hs
+++ b/Role/User.hs
@@ -37,8 +37,7 @@ run os = fromMaybe (ExitFailure 101) <$> connect
 		putStr "Connecting to debug-me server..."
 		hFlush stdout
 		usv <- newEmptyTMVarIO
-		let recentactivity = userStateRecentActivity usv
-		runClientApp $ clientApp (InitMode mempty) recentactivity User developerMessages $ \ochan ichan sid -> do
+		runClientApp $ clientApp (InitMode mempty) User developerMessages $ \ochan ichan sid -> do
 			let url = sessionIDUrl sid "localhost" 8081
 			putStrLn ""
 			putStrLn "Others can connect to this session and help you debug by running:"
@@ -89,14 +88,11 @@ data UserState = UserState
 	}
 
 -- | RecentActivity that uses the UserState.
-userStateRecentActivity :: TMVar (TVar UserState) -> RecentActivity
-userStateRecentActivity usv = go =<< tryReadTMVar usv
-  where
-	go Nothing = noRecentActivity
-	go (Just us) = do
-		st <- readTVar us
-		let hs = mapMaybe loggedHash $ toList $ backLog st
-		return (sigVerifier st, hs)
+userStateRecentActivity :: TVar UserState -> RecentActivity
+userStateRecentActivity us = do
+	st <- readTVar us
+	let hs = mapMaybe loggedHash $ toList $ backLog st
+	return (sigVerifier st, hs)
 
 -- | Start by establishing our session key, and displaying the starttxt.
 startProtocol :: B.ByteString -> TMChan (Message Seen) -> Logger -> IO (TVar UserState)
@@ -189,7 +185,7 @@ instance SendableToDeveloper ControlAction where
 -- | Read things to be entered from the TMChan, verify if they're legal,
 -- and send them to the Pty. Also handles control messages from the
 -- developer.
-sendPtyInput :: TMChan (Message Entered) -> TMChan (Message Seen) -> TMChan ControlInput -> Pty -> TVar UserState -> Logger -> IO ()
+sendPtyInput :: TMChan (MissingHashes (Message Entered)) -> TMChan (Message Seen) -> TMChan ControlInput -> Pty -> TVar UserState -> Logger -> IO ()
 sendPtyInput ichan ochan controlinput p us logger = go
   where
 	go = do
@@ -220,15 +216,16 @@ data Input
 -- signature of the message is only verified against the key in it), and
 -- make sure it's legal before returning it. If it's not legal, sends a
 -- Reject message.
-getDeveloperMessage :: TMChan (Message Entered) -> TMChan (Message Seen) -> TVar UserState -> POSIXTime -> STM (Maybe Input)
+getDeveloperMessage :: TMChan (MissingHashes (Message Entered)) -> TMChan (Message Seen) -> TVar UserState -> POSIXTime -> STM (Maybe Input)
 getDeveloperMessage ichan ochan us now = maybe
 	(return Nothing)
 	(\msg -> Just <$> getDeveloperMessage' msg ochan us now)
 	=<< readTMChan ichan
 
-getDeveloperMessage' :: Message Entered -> TMChan (Message Seen) -> TVar UserState -> POSIXTime -> STM Input
-getDeveloperMessage' msg ochan us now = do
+getDeveloperMessage' :: MissingHashes (Message Entered) -> TMChan (Message Seen) -> TVar UserState -> POSIXTime -> STM Input
+getDeveloperMessage' (MissingHashes wiremsg) ochan us now = do
 	st <- readTVar us
+	Developer msg <- restoreHashes (userStateRecentActivity us) (MissingHashes (Developer wiremsg))
 	case msg of
 		ControlMessage (Control (SessionKey spk) _) -> do
 			let sigverifier = mkSigVerifier $ case spk of
diff --git a/Role/Watcher.hs b/Role/Watcher.hs
index 0867da1..8ed59d5 100644
--- a/Role/Watcher.hs
+++ b/Role/Watcher.hs
@@ -14,7 +14,7 @@ import Control.Concurrent.STM.TMChan
 run :: WatchOpts -> IO ()
 run = run' watcher . watchUrl
 
-watcher :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()
+watcher :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO ()
 watcher dsv _ichan ochan sid = withSessionLogger (Just "remote") sid $ \logger -> inRawMode $ do
 	sk <- genMySessionKey
 	(st, startoutput) <- processSessionStart sk ochan logger dsv
diff --git a/Server.hs b/Server.hs
index b9f46dd..deafe41 100644
--- a/Server.hs
+++ b/Server.hs
@@ -7,7 +7,6 @@ import CmdLine
 import WebSockets
 import SessionID
 import Log
-import PrevActivity
 
 import Network.Wai
 import Network.Wai.Handler.Warp
@@ -145,7 +144,7 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(loghv, sid) -> do
 	-- (The user is allowed to send Developer messages too.. perhaps
 	-- they got them from a developer connected to them some other
 	-- way.)
-	relayfromuser mytid session = relayFromSocket conn noRecentActivity (return ()) $ \msg -> do
+	relayfromuser mytid session = relayFromSocket conn $ \msg -> do
 		l <- mkLog msg <$> getPOSIXTime
 		writeSession mytid session l
 	
@@ -184,7 +183,7 @@ developer o ssv sid conn = bracket setup cleanup go
 	
 	-- Relay all Developer amessages from the developer's websocket
 	-- to the broadcast channel.
-	relayfromdeveloper mytid session = relayFromSocket conn noRecentActivity (return ())
+	relayfromdeveloper mytid session = relayFromSocket conn
 		$ \msg -> case msg of
 			Developer _ -> do
 				l <- mkLog msg <$> getPOSIXTime
diff --git a/TODO b/TODO
index 50bd348..6975aff 100644
--- a/TODO
+++ b/TODO
@@ -1,6 +1,3 @@
-* Multiple --downloads at the same time or close together fail
-  with "thread blocked indefinitely in an STM transaction"
-  Also see it occasionally when connecting with what was --debug.
 * 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/Types.hs b/Types.hs
index 78c59a2..7622f6a 100644
--- a/Types.hs
+++ b/Types.hs
@@ -64,6 +64,10 @@ data Activity a = Activity
 	}
 	deriving (Show, Generic)
 
+-- | Used when a value has had its hashes erased for more efficient
+-- transfer over the wire.
+data MissingHashes a = MissingHashes a
+
 instance DataSize a => DataSize (Activity a) where
 	dataSize a = dataSize (activity a) 
 		+ maybe 0 dataSize (prevActivity a)
diff --git a/WebSockets.hs b/WebSockets.hs
index 7cb140b..bbf21e3 100644
--- a/WebSockets.hs
+++ b/WebSockets.hs
@@ -63,12 +63,11 @@ runClientApp app = do
 -- | Make a client that sends and receives AnyMessages over a websocket.
 clientApp
 	:: Mode
-	-> RecentActivity
 	-> (sent -> AnyMessage)
 	-> (AnyMessage -> Maybe received)
-	-> (TMChan sent -> TMChan received -> SessionID -> IO a)
+	-> (TMChan sent -> TMChan (MissingHashes received) -> SessionID -> IO a)
 	-> ClientApp a
-clientApp mode recentactivity mksent filterreceived a conn = do
+clientApp mode mksent filterreceived a conn = do
 	-- Ping every 30 seconds to avoid timeouts caused by proxies etc.
 	forkPingThread conn 30
 	_v <- negotiateWireVersion conn
@@ -85,10 +84,10 @@ clientApp mode recentactivity mksent filterreceived a conn = do
 		sthread <- async $ relayToSocket conn mksent $
 			atomically (readTMChan schan)
 		rthread <- async $ do
-			relayFromSocket conn recentactivity (waitTillDrained rchan) $ \v -> do
+			relayFromSocket conn $ \v -> do
 				case filterreceived v of
 					Nothing -> return ()
-					Just r -> atomically $ writeTMChan rchan r
+					Just r -> atomically $ writeTMChan rchan (MissingHashes r)
 			-- Server sent Done, so close channels.
 			atomically $ do
 				closeTMChan schan
@@ -104,24 +103,14 @@ clientApp mode recentactivity mksent filterreceived a conn = do
 		void $ waitCatch rthread
 	go sid (schan, rchan, _, _) = a schan rchan sid
 
-waitTillDrained :: TMChan a -> IO ()
-waitTillDrained c = atomically $ do
-	e <- isEmptyTMChan c
-	if e
-		then return ()
-		else retry
-
-relayFromSocket :: Connection -> RecentActivity -> IO () -> (AnyMessage -> IO ()) -> IO ()
-relayFromSocket conn recentactivity waitprevprocessed sender = go
+relayFromSocket :: Connection -> (AnyMessage -> IO ()) -> IO ()
+relayFromSocket conn sender = go
   where
 	go = do
 		r <- receiveData conn
 		case r of
 			AnyMessage msg -> do
-				waitprevprocessed
-				msg' <- atomically $
-					restorePrevActivityHash recentactivity msg
-				sender msg'
+				sender msg
 				go
 			Done -> return ()
 			WireProtocolError e -> protocolError conn e
@@ -135,8 +124,9 @@ relayToSocket conn mksent getter = go
 		case mmsg of
 			Nothing -> return ()
 			Just msg -> do
-				sendBinaryData conn $ AnyMessage $
-					removePrevActivityHash $ mksent msg
+				let MissingHashes wiremsg =
+					removeHashes $ mksent msg
+				sendBinaryData conn $ AnyMessage wiremsg
 				go
 
 -- | Framing protocol used over a websocket connection.