developer side checking of chain almost done

Seems to work well with networkDelay on both sides now.

However, typing "top" causes the "to" to be accepted, but the "p" is
rejected.

1 files changed, 96 insertions, 46 deletions

diff --git a/debug-me.hs b/debug-me.hs
index fe26e1f..07ff05b 100644
--- a/debug-me.hs
+++ b/debug-me.hs
@@ -16,6 +16,7 @@ import System.Process
 import System.Exit
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
+import Data.List
 import Data.List.NonEmpty (NonEmpty(..), toList)
 import Data.Monoid
 import Data.Aeson
@@ -55,10 +56,11 @@ developer ichan ochan = do
 		Activity (Proto (Seen (Val b))) Nothing sig -> do
 			B.hPut stdout b
 			hFlush stdout	
-		_ -> error $ "Startup protocol error, unexpected: " ++ show startact
+		_ -> protocolError $ "Unexpected startup: " ++ show startact
 	devstate <- newTVarIO $ DeveloperState
 		{ lastSeen = hash startact
 		, sentSince = mempty
+		, enteredSince = mempty
 		, lastActivity = hash startact
 		}
 	_ <- sendTtyInput ichan devstate
@@ -67,7 +69,8 @@ developer ichan ochan = do
 
 data DeveloperState = DeveloperState
 	{ lastSeen :: Hash
-	, sentSince :: B.ByteString
+	, sentSince :: [B.ByteString]
+	, enteredSince :: [Hash]
 	, lastActivity :: Hash
 	}
 	deriving (Show)
@@ -86,13 +89,15 @@ sendTtyInput ichan devstate = go
 			ds <- readTVar devstate
 			let entered = Entered
 				{ enteredData = Val b
-				, echoData = Val (sentSince ds)
+				, echoData = Val $ B.concat $ sentSince ds
 				}
 			let act = Activity (Proto entered) (Just $ lastActivity ds) dummySignature
 			writeTChan ichan act
+			let acth = hash act
 			let ds' = ds
-				{ sentSince = sentSince ds <> b
-				, lastActivity = hash act
+				{ sentSince = sentSince ds ++ [b]
+				, enteredSince = enteredSince ds ++ [acth]
+				, lastActivity = acth
 				}
 			writeTVar devstate ds'
 		go
@@ -102,43 +107,80 @@ sendTtyOutput :: TChan (Activity Seen) -> TVar DeveloperState -> IO ()
 sendTtyOutput ochan devstate = go
   where
 	go = do
-		maybe (return ()) emit =<< atomically get
-		go
-	emit b = do
-		B.hPut stdout b
-		hFlush stdout
+		v <- atomically get
+		case v of
+			Left e -> protocolError e
+			Right (Just b) -> do
+				B.hPut stdout b
+				hFlush stdout
+				go
+			Right Nothing -> 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
-					let ss = sentSince ds
-					let ss' = if b `B.isPrefixOf` ss
-						then B.drop (B.length b) ss
-						else mempty
-					let ds' = DeveloperState
-						{ lastSeen = h
-						, sentSince = ss'
-						, lastActivity = h
-						}
+		let (legal, ds') = isLegalSeen act ds
+		if legal
+			then case act of
+				Activity (Proto (Seen (Val b))) _ _ -> do
 					writeTVar devstate ds'
-					return (Just b)
-				| hp == lastActivity ds -> do
-					let ds' = DeveloperState
-						{ lastSeen = h
-						, sentSince = mempty
-						, lastActivity = h
-						}
-					writeTVar devstate ds'
-					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"
+					return $ Right $ Just b
+				Activity (Rejected _) _ _ -> do
+ 					writeTVar devstate ds'
+					return $ Right Nothing
+			else return $ Left $ "Illegal Seen value: " ++ show (act, hash act) ++ "\n" ++ show ds
+
+-- | Check if the Seen activity is legal, 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.
+			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 = h
+				, sentSince = ss'
+				, enteredSince = es'
+				, lastActivity = h
+				}
+	-- 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 b)) ->
+				let ss = sentSince ds
+				    es = enteredSince ds
+				    ss' = drop (i+1) ss
+				    es' = drop (i+1) es
+				in yes $ DeveloperState
+					{ lastSeen = h
+					, sentSince = ss'
+					, enteredSince = es'
+					, lastActivity = h
+					}
+  where
+	h = 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 = h
+		, lastActivity = h
+		}
+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
@@ -200,7 +242,7 @@ sendPtyInput ichan ochan p backlog logger = go
 			-- Don't need to retain backlog before the Activity
 			-- that entered references.
 			let bl'@(Backlog bll) = truncateBacklog bl entered
-			if isLegal entered bl'
+			if isLegalEntered entered bl'
 				then do
 					let l = ActivityEntered (entered, hash entered)
 					writeTVar backlog (Backlog (l :| toList bll))
@@ -213,7 +255,7 @@ sendPtyInput ichan ochan p backlog logger = go
 				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
+					Rejected r -> protocolError $ "User side received a Rejected: " ++ show r
 				go
 			Left rejact -> do
 				logger $ ActivitySeen (rejact, hash rejact)
@@ -234,17 +276,17 @@ truncateBacklog (Backlog (b :| l)) (Activity _ hp _)
 		| 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,
+-- | Entered activity is legal when it points to the last Seen activvity,
 -- because this guarantees that the person who entered it saw
 -- the current state of the system before manipulating it.
 --
 -- To support typeahead on slow links, some echoData may be provided
 -- in the Entered activity. If the prevActivity points
 -- to an older Seen activity, then the echoData must match the
--- 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 :| bl))
+-- concatenation of all Seen activities after that one, up to the
+-- most recent Seen activity.
+isLegalEntered :: Activity Entered -> Backlog -> Bool
+isLegalEntered (Activity (Proto entered) hp sig) (Backlog (lastseen :| bl))
 	| Just (activityLogHash lastseen) == hp = True
 	| B.null (val (echoData entered)) = False -- optimisation
 	| any (== hp) (map (Just . activityLogHash) bl) =
@@ -257,7 +299,15 @@ isLegal (Activity (Proto entered) hp sig) (Backlog (lastseen :| bl))
 		_ -> mempty
 	getseen (ActivityEntered _) = mempty
 -- Developer should never send Rejected.
-isLegal (Activity (Rejected _) _ _) _ = False 
+isLegalEntered (Activity (Rejected _) _ _) _ = False 
 
 dummySignature :: Signature
 dummySignature = Signature mempty
+
+-- | Temporary hack while user and developer share a process.
+protocolError :: String -> IO a
+protocolError e = do
+	hPutStrLn stderr e
+	hFlush stderr
+	_ <- exitWith (ExitFailure 101)
+	error e