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.

1 files changed, 11 insertions, 14 deletions

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