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.

4 files changed, 67 insertions, 70 deletions

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