reorganized message types

Make Control messages be out-of-band async messages, without a pointer
to a previous message.

And then followed the type change through the code for hours..

This commit was sponsored by Nick Daly on Patreon.

1 files changed, 164 insertions, 130 deletions

diff --git a/debug-me.hs b/debug-me.hs
index cb353d9..e16576b 100644
--- a/debug-me.hs
+++ b/debug-me.hs
@@ -53,20 +53,21 @@ networkDelay :: IO ()
 networkDelay = threadDelay 800000 -- 800 ms ; the latency to geosync orbit
 -- networkDelay = threadDelay 150000 -- 150 ms ; transatlantic latency
 
-developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO ()
+developer :: TChan (Message Entered) -> TChan (Message Seen) -> IO ()
 developer ichan ochan = withLogger "debug-me-developer.log" $ \logger -> do
-	startact <- atomically $ readTChan ochan
-	logger $ ActivitySeen startact
-	case startact of
-		Activity (Proto (Seen (Val b))) Nothing sig -> do
+	startmsg <- atomically $ readTChan ochan
+	logger $ User startmsg
+	starthash <- case startmsg of
+		ActivityMessage act@(Activity (Seen (Val b)) Nothing sig) -> do
 			B.hPut stdout b
 			hFlush stdout	
-		_ -> protocolError $ "Unexpected startup: " ++ show startact
+			return (hash act)
+		_ -> protocolError $ "Unexpected startup: " ++ show startmsg
 	devstate <- newTVarIO $ DeveloperState
-		{ lastSeen = hash startact
+		{ lastSeen = starthash
 		, sentSince = mempty
 		, enteredSince = mempty
-		, lastActivity = hash startact
+		, lastActivity = starthash
 		}
 	_ <- sendTtyInput ichan devstate logger
 		`concurrently` sendTtyOutput ochan devstate logger
@@ -81,7 +82,7 @@ data DeveloperState = DeveloperState
 	deriving (Show)
 
 -- | Read things typed by the developer, and forward them to the TChan.
-sendTtyInput :: TChan (Activity Entered) -> TVar DeveloperState -> Logger -> IO ()
+sendTtyInput :: TChan (Message Entered) -> TVar DeveloperState -> Logger -> IO ()
 sendTtyInput ichan devstate logger = go
   where
 	go = do
@@ -101,8 +102,8 @@ sendTtyInput ichan devstate logger = go
 				{ enteredData = Val b
 				, echoData = Val ed
 				}
-			let act = Activity (Proto entered) (Just $ lastActivity ds) dummySignature
-			writeTChan ichan act
+			let act = Activity entered (Just $ lastActivity ds) dummySignature
+			writeTChan ichan (ActivityMessage act)
 			let acth = hash act
 			let ds' = ds
 				{ sentSince = sentSince ds ++ [b]
@@ -111,16 +112,16 @@ sendTtyInput ichan devstate logger = go
 				}
 			writeTVar devstate ds'
 			return act
-		logger $ ActivityEntered act
+		logger $ Developer $ ActivityMessage act
 		go
 
 -- | Read activity from the TChan and display it to the developer.
-sendTtyOutput :: TChan (Activity Seen) -> TVar DeveloperState -> Logger -> IO ()
+sendTtyOutput :: TChan (Message Seen) -> TVar DeveloperState -> Logger -> IO ()
 sendTtyOutput ochan devstate logger = go
   where
 	go = do
-		(v, act) <- atomically $ processOutput ochan devstate
-		logger $ ActivitySeen act
+		(v, msg) <- atomically $ processOutput ochan devstate
+		logger $ User msg
 		case v of
 			ProtocolError e -> protocolError e
 			TtyOutput b -> do
@@ -131,147 +132,178 @@ sendTtyOutput ochan devstate logger = go
 				B.hPut stdout "\a"
 				hFlush stdout
 				go
+			NoOutput -> go
 
-data Output = TtyOutput B.ByteString | Beep | ProtocolError String
+data Output = TtyOutput B.ByteString | Beep | ProtocolError String | NoOutput
 
-processOutput :: TChan (Activity Seen) -> TVar DeveloperState -> STM (Output, Activity Seen)
+processOutput :: TChan (Message Seen) -> TVar DeveloperState -> STM (Output, Message Seen)
 processOutput ochan devstate = do
-	act <- readTChan ochan
+	msg <- readTChan ochan
 	ds <- readTVar devstate
-	let (legal, ds') = isLegalSeen act ds
-	if legal
-		then case act of
-			Activity (Proto (Seen (Val b))) _ _ -> do
+	-- TODO check sig before doing anything else
+	o <- case msg of
+		ActivityMessage act@(Activity (Seen (Val b)) _ _) -> do
+			let (legal, ds') = isLegalSeen act ds
+			if legal
+				then do
+					writeTVar devstate ds'
+					return (TtyOutput b)
+				else return (ProtocolError $ "Illegal Seen value: " ++ show (act, hash act) ++ "\n" ++ show ds)
+		ControlMessage (Control c _) -> case c of
+			Rejected _ -> do
+				-- When they rejected a message we sent,
+				-- anything we sent subsequently will
+				-- also be rejected, so forget about it.
+				let ds' = ds
+					{ sentSince = mempty
+					, enteredSince = mempty
+					}
 				writeTVar devstate ds'
-				return (TtyOutput b, act)
-			Activity (Rejected _) _ _ -> do
- 				writeTVar devstate ds'
-				return (Beep, act)
-		else return (ProtocolError $ "Illegal Seen value: " ++ show (act, hash act) ++ "\n" ++ show ds, act)
+				return Beep
+			SessionKey _ -> return NoOutput
+			SessionKeyAccepted _ -> return NoOutput
+			SessionKeyRejected _ -> return NoOutput
+	return (o, msg)
 
--- | Check if the Seen activity is legal, and returns an updated
--- DeveloperState.
+-- | Check if the Seen activity is legal, forming a chain with previous
+-- ones, and returns an updated DeveloperState.
 isLegalSeen :: Activity Seen -> DeveloperState -> (Bool, DeveloperState)
-isLegalSeen act@(Activity p (Just hp) sig) ds
-	-- Does it chain to the last Seen value?
-	| hp == lastSeen ds = case p of
-		Rejected _ -> yesrej
-		Proto (Seen (Val b)) ->
-			-- Trim sentSince and enteredSince to
-			-- values after the Seen value.
+isLegalSeen act@(Activity (Seen (Val b)) (Just hp) sig) ds
+	-- Does it chain to the last Seen activity?
+	| hp == lastSeen ds = 
+		-- Trim sentSince and enteredSince to
+		-- values after the Seen value.
+		let ss = sentSince ds
+		    es = enteredSince ds
+		    n = B.length b
+		    (ss', es') = if b `B.isPrefixOf` mconcat ss
+		    	then (drop n ss, drop n es)
+			else (mempty, mempty)
+		in yes $ DeveloperState
+			{ lastSeen = acth
+			, sentSince = ss'
+			, enteredSince = es'
+			, lastActivity = acth
+			}
+	-- Does it chain to something we've entered since the last Seen
+	-- value? Eg, user sent A, we replied B C, and the user has
+	-- now replied to B.
+	-- If so, we can drop B (and anything before it) from
+	-- enteredSince and sentSince.
+	| otherwise = case elemIndex hp (enteredSince ds) of
+		Nothing -> (False, ds)
+		Just i -> 
 			let ss = sentSince ds
 			    es = enteredSince ds
-			    n = B.length b
-			    (ss', es') = if b `B.isPrefixOf` mconcat ss
-			    	then (drop n ss, drop n es)
-				else (mempty, mempty)
+			    ss' = drop (i+1) ss
+			    es' = drop (i+1) es
 			in yes $ DeveloperState
 				{ lastSeen = acth
 				, sentSince = ss'
 				, enteredSince = es'
 				, lastActivity = acth
 				}
-	-- Does it chain to something we've entered since the last Seen
-	-- value? Eg, user sent A, we replied B C, and the user has
-	-- now replied to B.
-	-- If so, we can drop B (and anything before it) from
-	-- enteredSince and sentSince.
-	| otherwise = case elemIndex hp (enteredSince ds) of
-		Nothing -> (False, ds)
-		Just i -> case p of
-			Rejected _ -> yesrej
-			Proto (Seen (Val _)) ->
-				let ss = sentSince ds
-				    es = enteredSince ds
-				    ss' = drop (i+1) ss
-				    es' = drop (i+1) es
-				in yes $ DeveloperState
-					{ lastSeen = acth
-					, sentSince = ss'
-					, enteredSince = es'
-					, lastActivity = acth
-					}
   where
 	acth = hash act
 	yes ds' = (True, ds')
-	-- When they rejected a message we sent, anything we sent
-	-- subsequently will also be rejected, so forget about it.
-	yesrej = yes $ ds
-		{ lastSeen = acth
-		, lastActivity = acth
-		}
 isLegalSeen (Activity _ Nothing _) ds = (False, ds)
 
-user :: B.ByteString -> Pty -> TChan (Activity Entered) -> TChan (Activity Seen) -> IO ()
-user startmsg p ichan ochan = withLogger "debug-me.log" $ \logger -> do
-	let startact = Activity (Proto (Seen (Val (startmsg <> "\r\n")))) Nothing dummySignature
-	logger $ ActivitySeen startact
-	l <- mkActivityLog (ActivitySeen startact) <$> getPOSIXTime
-	atomically $ writeTChan ochan startact
-	backlog <- newTVarIO $ Backlog (l :| [])
-	_ <- sendPtyOutput p ochan backlog logger
-		`concurrently` sendPtyInput ichan ochan p backlog logger
+user :: B.ByteString -> Pty -> TChan (Message Entered) -> TChan (Message Seen) -> IO ()
+user starttxt p ichan ochan = withLogger "debug-me.log" $ \logger -> do
+	let act = Activity (Seen (Val (starttxt <> "\r\n"))) Nothing dummySignature
+	let startmsg = ActivityMessage act
+	logger $ User startmsg
+	l <- mkLog (User startmsg) <$> getPOSIXTime
+	atomically $ writeTChan ochan startmsg
+	us <- newTVarIO $ UserState
+		{ backLog = l :| []
+		}
+	_ <- sendPtyOutput p ochan us logger
+		`concurrently` sendPtyInput ichan ochan p us logger
 	return ()
 
 -- | Log of recent Activity, with the most recent first.
-data Backlog = Backlog (NonEmpty ActivityLog)
+type Backlog = NonEmpty Log
+
+data UserState = UserState
+	{ backLog :: Backlog
+	}
 	deriving (Show)
 
 -- | Forward things written to the Pty out the TChan.
-sendPtyOutput :: Pty -> TChan (Activity Seen) -> TVar Backlog -> Logger -> IO ()
-sendPtyOutput p ochan backlog logger = go
+sendPtyOutput :: Pty -> TChan (Message Seen) -> TVar UserState -> Logger -> IO ()
+sendPtyOutput p ochan us logger = go
   where
 	go = do
 		b <- readPty p
 		now <- getPOSIXTime
-		act <- atomically $ do
+		l <- atomically $ do
 			let seen = Seen (Val b)
-			sendDeveloper ochan backlog (Proto seen) now
-		logger $ ActivitySeen act
+			sendDeveloper ochan us seen now
+		logger $ User l
 		go
 
-sendDeveloper :: TChan (Activity Seen) -> TVar Backlog -> Proto Seen -> POSIXTime -> STM (Activity Seen)
-sendDeveloper ochan backlog pseen now = do
-	Backlog (bl@(prev :| _)) <- readTVar backlog
-	let prevhash = loggedHash prev
-	let act = Activity pseen (Just prevhash) dummySignature
-	let l = mkActivityLog (ActivitySeen act) now
-	writeTChan ochan act
-	writeTVar backlog $ Backlog (l :| toList bl)
-	return act
+class SendableToDeveloper t where
+	sendDeveloper :: TChan (Message Seen) -> TVar UserState -> t -> POSIXTime -> STM (Message Seen)
+
+instance SendableToDeveloper Seen where
+	sendDeveloper ochan us seen now = do
+		st <- readTVar us
+		let bl@(prev :| _) = backLog st
+		let msg = ActivityMessage $ 
+			Activity seen (loggedHash prev) dummySignature
+		let l = mkLog (User msg) now
+		writeTChan ochan msg
+		writeTVar us $ st { backLog = l :| toList bl }
+		return msg
+
+instance SendableToDeveloper ControlAction where
+	sendDeveloper ochan _us c _now = do
+		let msg = ControlMessage $ Control c dummySignature
+		-- Control messages are not kept in the backlog.
+		writeTChan ochan msg
+		return msg
 
 -- | Read things to be entered from the TChan, verify if they're legal,
 -- and send them to the Pty.
-sendPtyInput :: TChan (Activity Entered) -> TChan (Activity Seen) -> Pty -> TVar Backlog -> Logger -> IO ()
-sendPtyInput ichan ochan p backlog logger = go
+sendPtyInput :: TChan (Message Entered) -> TChan (Message Seen) -> Pty -> TVar UserState -> Logger -> IO ()
+sendPtyInput ichan ochan p us logger = go
   where
 	go = do
 		networkDelay
 		now <- getPOSIXTime
 		v <- atomically $ do
-			entered <- readTChan ichan
-			bl <- readTVar backlog
-			-- Don't need to retain backlog before the Activity
-			-- that entered references.
-			let bl'@(Backlog bll) = reduceBacklog $
-				truncateBacklog bl entered
-			if isLegalEntered entered bl'
-				then do
-					let l = mkActivityLog (ActivityEntered entered) now
-					writeTVar backlog (Backlog (l :| toList bll))
-					return (Right entered)
-				else do
-					let reject = Rejected entered
-					Left <$> sendDeveloper ochan backlog reject now
+			msg <- readTChan ichan
+			st <- readTVar us
+			-- TODO check signature first
+			case msg of
+				ActivityMessage entered -> do
+					-- Don't need to retain backlog before the Activity
+					-- that entered references.
+					let bl' = reduceBacklog $
+						truncateBacklog (backLog st) entered
+					if isLegalEntered entered (st { backLog = bl' })
+						then do
+							let l = mkLog (Developer msg) now
+							writeTVar us (st { backLog = l :| toList bl' })
+							return (Right msg)
+						else do
+							let reject = Rejected entered
+							Left <$> sendDeveloper ochan us reject now
+				ControlMessage (Control _ _) ->
+					return (Right msg)
 		case v of
-			Right entered -> do
-				logger (ActivityEntered entered)
-				case activity entered of
-					Proto e -> writePty p (val (enteredData e))
-					Rejected r -> protocolError $ "User side received a Rejected: " ++ show r
+			Right (ActivityMessage entered) -> do
+				logger $ Developer $ ActivityMessage entered
+				writePty p $ val $ enteredData $ activity entered
 				go
+			Right (ControlMessage (Control c _)) -> case c of
+				Rejected r -> protocolError $ "User side received a Rejected: " ++ show r
+				SessionKey _ -> protocolError "Adding session keys to running session not supported yet"
+				SessionKeyAccepted _ -> protocolError "User side received a SessionKeyAccepted"
+				SessionKeyRejected _ -> protocolError "User side received a SessionKeyRejected"
 			Left rejact -> do
-				logger $ ActivitySeen rejact
+				logger $ User rejact
 				go
 
 -- | Truncate the Backlog to remove entries older than the one
@@ -285,23 +317,24 @@ sendPtyInput ichan ochan p backlog logger = go
 -- If the Activity refers to an item not in the backlog, no truncation is
 -- done.
 truncateBacklog :: Backlog -> Activity Entered -> Backlog
-truncateBacklog (Backlog (b :| l)) (Activity _ hp _)
-	| truncationpoint b = Backlog (b :| [])
-	| otherwise = Backlog (b :| go [] l)
+truncateBacklog (b :| l) (Activity _ (Just hp) _)
+	| truncationpoint b = b :| []
+	| otherwise = b :| go [] l
   where
 	go c [] = reverse c
 	go c (x:xs)
 		| truncationpoint x = reverse (x:c)
 		| otherwise = go (x:c) xs
-	truncationpoint x@(ActivityLog { loggedActivity = ActivitySeen {}}) = Just (loggedHash x) == hp
+	truncationpoint x@(Log { loggedMessage = User {}}) = loggedHash x == Just hp
 	truncationpoint _ = False
+truncateBacklog bl (Activity _ Nothing _) = bl
 
 -- | To avoid DOS attacks that try to fill up the backlog and so use all
 -- memory, don't let the backlog contain more than 1000 items, or
 -- more than 16 megabytes of total data. (Excluding the most recent
 -- item).
 reduceBacklog :: Backlog -> Backlog
-reduceBacklog (Backlog (b :| l)) = Backlog (b :| go 0 (take 1000 l))
+reduceBacklog (b :| l) = b :| go 0 (take 1000 l)
   where
 	go _ [] = []
 	go n (x:xs)
@@ -317,21 +350,22 @@ reduceBacklog (Backlog (b :| l)) = Backlog (b :| go 0 (take 1000 l))
 -- to an older activity, then the echoData must match the
 -- concatenation of all Seen activities after that one, up to the
 -- last logged activity.
-isLegalEntered :: Activity Entered -> Backlog -> Bool
-isLegalEntered (Activity (Proto entered) hp sig) (Backlog (lastact :| bl))
-	| Just (loggedHash lastact) == hp = True
-	| B.null (val (echoData entered)) = False -- optimisation
-	| any (== hp) (map (Just . loggedHash) bl) =
-		let sincehp = reverse (lastact : takeWhile (\l -> Just (loggedHash l) /= hp) bl)
-		in echoData entered == mconcat (map (getseen . loggedActivity) sincehp)
+--
+-- Activities that do not enter data point to the first message
+-- sent in the debug-me session.
+isLegalEntered :: Activity Entered -> UserState -> Bool
+isLegalEntered (Activity _ Nothing _) _ = False
+isLegalEntered (Activity a (Just hp) sig) us
+	| loggedHash lastact == Just hp = True
+	| B.null (val (echoData a)) = False -- optimisation
+	| any (== Just hp) (map loggedHash bl) =
+		let sincehp = reverse (lastact : takeWhile (\l -> loggedHash l /= Just hp) bl)
+		in echoData a == mconcat (map (getseen . loggedMessage) sincehp)
 	| otherwise = False
   where
-	getseen (ActivitySeen a)  = case activity a of
-		Proto s -> seenData s
-		_ -> mempty
-	getseen (ActivityEntered _) = mempty
--- Developer should never send Rejected.
-isLegalEntered (Activity (Rejected _) _ _) _ = False 
+	(lastact :| bl) = backLog us
+	getseen (User (ActivityMessage as)) = seenData $ activity as
+	getseen _ = mempty
 
 -- | Temporary hack while user and developer share a process.
 protocolError :: String -> IO a