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, 54 insertions, 54 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