Include Entered in the Activity chain

So when the developer makes 2 keypresses close together, they send the
second Activity Entered with the first Activity Entered as its HashPointer.
This allows the developer to prove the order they did things.

This commit was sponsored by Peter Hogg on Patreon.

1 files changed, 59 insertions, 34 deletions

diff --git a/debug-me.hs b/debug-me.hs
index cae0c3d..fe26e1f 100644
--- a/debug-me.hs
+++ b/debug-me.hs
@@ -46,7 +46,7 @@ test = do
 
 -- | 800 ms is about the latency to geosync orbit
 networkDelay :: IO ()
-networkDelay = threadDelay 150000 -- 800000
+networkDelay = threadDelay 800000 -- 150000 -- 800000
 
 developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO ()
 developer ichan ochan = do
@@ -56,7 +56,11 @@ developer ichan ochan = do
 			B.hPut stdout b
 			hFlush stdout	
 		_ -> error $ "Startup protocol error, unexpected: " ++ show startact
-	devstate <- newTVarIO (DeveloperState (hash startact) mempty)
+	devstate <- newTVarIO $ DeveloperState
+		{ lastSeen = hash startact
+		, sentSince = mempty
+		, lastActivity = hash startact
+		}
 	_ <- sendTtyInput ichan devstate
 		`concurrently` sendTtyOutput ochan devstate
 	return ()
@@ -64,6 +68,7 @@ developer ichan ochan = do
 data DeveloperState = DeveloperState
 	{ lastSeen :: Hash
 	, sentSince :: B.ByteString
+	, lastActivity :: Hash
 	}
 	deriving (Show)
 
@@ -83,10 +88,11 @@ sendTtyInput ichan devstate = go
 				{ enteredData = Val b
 				, echoData = Val (sentSince ds)
 				}
-			let act = Activity (Proto entered) (Just $ lastSeen ds) dummySignature
+			let act = Activity (Proto entered) (Just $ lastActivity ds) dummySignature
 			writeTChan ichan act
 			let ds' = ds
 				{ sentSince = sentSince ds <> b
+				, lastActivity = hash act
 				}
 			writeTVar devstate ds'
 		go
@@ -96,13 +102,15 @@ sendTtyOutput :: TChan (Activity Seen) -> TVar DeveloperState -> IO ()
 sendTtyOutput ochan devstate = go
   where
 	go = do
-		b <- atomically get
+		maybe (return ()) emit =<< atomically get
+		go
+	emit b = do
 		B.hPut stdout b
 		hFlush stdout
-		go
 	get = do
 		act <- readTChan ochan
 		ds <- readTVar devstate
+		let h = hash act
 		case act of
 			Activity (Proto (Seen (Val b))) (Just hp) sig
 				| hp == lastSeen ds -> do
@@ -111,27 +119,40 @@ sendTtyOutput ochan devstate = go
 						then B.drop (B.length b) ss
 						else mempty
 					let ds' = DeveloperState
-						{ lastSeen = hash act
+						{ lastSeen = h
 						, sentSince = ss'
+						, lastActivity = h
+						}
+					writeTVar devstate ds'
+					return (Just b)
+				| hp == lastActivity ds -> do
+					let ds' = DeveloperState
+						{ lastSeen = h
+						, sentSince = mempty
+						, lastActivity = h
 						}
 					writeTVar devstate ds'
-					return b
-			-- Got an activity out of order or
-			-- missed one somehow. Ignore it?
-			_ -> return mempty
+					return (Just b)
+				| otherwise -> error "Protocol error: Received a Seen Val out of order"
+			Activity (Rejected a) (Just hp) sig -> do
+				let ds' = ds { lastSeen = h }
+				writeTVar devstate ds'
+				return Nothing
+			Activity _ Nothing _ -> error "Protocol error: Received a Seen Val with no prevActivity"
 
 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, hash startact)
+	let l = ActivitySeen (startact, hash startact)
+	logger l
 	atomically $ writeTChan ochan startact
-	backlog <- newTVarIO $ Backlog ((hash startact, startact) :| [])
+	backlog <- newTVarIO $ Backlog (l :| [])
 	_ <- sendPtyOutput p ochan backlog logger
 		`concurrently` sendPtyInput ichan ochan p backlog logger
 	return ()
 
--- | Log of recent Activity Seen, with the most recent first.
-data Backlog = Backlog (NonEmpty (Hash, Activity Seen))
+-- | Log of recent Activity, with the most recent first.
+data Backlog = Backlog (NonEmpty ActivityLog)
 	deriving (Show)
 
 type Logger = ActivityLog -> IO ()
@@ -159,10 +180,11 @@ sendPtyOutput p ochan backlog logger = go
 
 sendDeveloper :: TChan (Activity Seen) -> TVar Backlog -> Proto Seen -> STM (Activity Seen)
 sendDeveloper ochan backlog pseen = do
-	Backlog (bl@((prevhash, _) :| _)) <- readTVar backlog
+	Backlog (bl@(prev :| _)) <- readTVar backlog
+	let prevhash = activityLogHash prev
 	let act = Activity pseen (Just prevhash) dummySignature
 	writeTChan ochan act
-	writeTVar backlog (Backlog ((hash act, act) :| toList bl))
+	writeTVar backlog (Backlog (ActivitySeen (act, hash act) :| toList bl))
 	return act
 
 -- | Read things to be entered from the TChan, verify if they're legal,
@@ -173,21 +195,22 @@ sendPtyInput ichan ochan p backlog logger = go
 	go = do
 		networkDelay
 		v <- atomically $ do
-			newact <- readTChan ichan
+			entered <- readTChan ichan
 			bl <- readTVar backlog
 			-- Don't need to retain backlog before the Activity
-			-- that newact references.
-			let bl' = truncateBacklog bl newact
-			if isLegal newact bl'
+			-- that entered references.
+			let bl'@(Backlog bll) = truncateBacklog bl entered
+			if isLegal entered bl'
 				then do
-					writeTVar backlog bl'
-					return (Right newact)
+					let l = ActivityEntered (entered, hash entered)
+					writeTVar backlog (Backlog (l :| toList bll))
+					return (Right (entered, l))
 				else do
-					let reject = Rejected newact
+					let reject = Rejected entered
 					Left <$> sendDeveloper ochan backlog reject
 		case v of
-			Right entered -> do
-				logger $ ActivityEntered (entered, hash entered)
+			Right (entered, l) -> do
+				logger l
 				case activity entered of
 					Proto e -> writePty p (val (enteredData e))
 					Rejected r -> error $ "Protocol error: User side received a Rejected: " ++ show r
@@ -203,12 +226,12 @@ sendPtyInput ichan ochan p backlog logger = go
 -- done.
 truncateBacklog :: Backlog -> Activity Entered -> Backlog
 truncateBacklog (Backlog (b :| l)) (Activity _ hp _)
-	| Just (fst b) == hp = Backlog (b :| [])
+	| Just (activityLogHash b) == hp = Backlog (b :| [])
 	| otherwise = Backlog (b :| go [] l)
   where
 	go c [] = reverse c
 	go c (x:xs)
-		| Just (fst x) == hp = reverse (x:c)
+		| Just (activityLogHash x) == hp = reverse (x:c)
 		| otherwise = go (x:c) xs
 
 -- | Entered activity is only legal if it points to the last Seen activvity,
@@ -221,16 +244,18 @@ truncateBacklog (Backlog (b :| l)) (Activity _ hp _)
 -- concatenation of all activities after that one, up to the most recent
 -- Seen activity.
 isLegal :: Activity Entered -> Backlog -> Bool
-isLegal (Activity (Proto entered) hp sig) (Backlog (lastseen@(lastseenhash, _lastseen) :| bl))
-	| Just lastseenhash == hp = True
+isLegal (Activity (Proto entered) hp sig) (Backlog (lastseen :| bl))
+	| Just (activityLogHash lastseen) == hp = True
 	| B.null (val (echoData entered)) = False -- optimisation
-	| any (== hp) (map (Just . fst) bl) =
-		let sincehp = reverse (lastseen : takeWhile (\(h, _) -> Just h /= hp) bl)
-		in echoData entered == mconcat (map (getdata . activity . snd) sincehp)
+	| any (== hp) (map (Just . activityLogHash) bl) =
+		let sincehp = reverse (lastseen : takeWhile (\l -> Just (activityLogHash l) /= hp) bl)
+		in echoData entered == mconcat (map getseen sincehp)
 	| otherwise = False
   where
-	getdata (Proto s) = seenData s
-	getdata (Rejected _) = mempty
+	getseen (ActivitySeen (a, _)) = case activity a of
+		Proto s -> seenData s
+		_ -> mempty
+	getseen (ActivityEntered _) = mempty
 -- Developer should never send Rejected.
 isLegal (Activity (Rejected _) _ _) _ = False