add Rejected and tag hashes by type

Need a way for the user to indicate when an Activity Entered is Rejected.

Changed hashing to include type tags, so Acticity Entered and Activity
Seen can never hash to the same hash.

Got debug-me.hs to compile after these changes, but currently it's buggy
after Activity Entered is Rejected.

Started protocol.txt documentation.

This commit was sponsored by Francois Marier on Patreon.

1 files changed, 36 insertions, 23 deletions

diff --git a/debug-me.hs b/debug-me.hs
index 075ca17..cae0c3d 100644
--- a/debug-me.hs
+++ b/debug-me.hs
@@ -52,10 +52,10 @@ developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO ()
 developer ichan ochan = do
 	startact <- atomically $ readTChan ochan
 	case startact of
-		Activity (Seen (Val b)) Nothing sig -> do
+		Activity (Proto (Seen (Val b))) Nothing sig -> do
 			B.hPut stdout b
 			hFlush stdout	
-		_ -> return ()
+		_ -> error $ "Startup protocol error, unexpected: " ++ show startact
 	devstate <- newTVarIO (DeveloperState (hash startact) mempty)
 	_ <- sendTtyInput ichan devstate
 		`concurrently` sendTtyOutput ochan devstate
@@ -83,9 +83,11 @@ sendTtyInput ichan devstate = go
 				{ enteredData = Val b
 				, echoData = Val (sentSince ds)
 				}
-			let act = Activity entered (Just $ lastSeen ds) dummySignature
+			let act = Activity (Proto entered) (Just $ lastSeen ds) dummySignature
 			writeTChan ichan act
-			let ds' = ds { sentSince = sentSince ds <> b }
+			let ds' = ds
+				{ sentSince = sentSince ds <> b
+				}
 			writeTVar devstate ds'
 		go
 
@@ -102,7 +104,7 @@ sendTtyOutput ochan devstate = go
 		act <- readTChan ochan
 		ds <- readTVar devstate
 		case act of
-			Activity (Seen (Val b)) (Just hp) sig
+			Activity (Proto (Seen (Val b))) (Just hp) sig
 				| hp == lastSeen ds -> do
 					let ss = sentSince ds
 					let ss' = if b `B.isPrefixOf` ss
@@ -120,15 +122,15 @@ sendTtyOutput ochan devstate = go
 
 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 (Seen (Val (startmsg <> "\r\n"))) Nothing dummySignature
+	let startact = Activity (Proto (Seen (Val (startmsg <> "\r\n")))) Nothing dummySignature
 	logger $ ActivitySeen (startact, hash startact)
 	atomically $ writeTChan ochan startact
 	backlog <- newTVarIO $ Backlog ((hash startact, startact) :| [])
 	_ <- sendPtyOutput p ochan backlog logger
-		`concurrently` sendPtyInput ichan p backlog logger
+		`concurrently` sendPtyInput ichan ochan p backlog logger
 	return ()
 
--- | Log of recent output, with the most recent output first.
+-- | Log of recent Activity Seen, with the most recent first.
 data Backlog = Backlog (NonEmpty (Hash, Activity Seen))
 	deriving (Show)
 
@@ -150,19 +152,23 @@ sendPtyOutput p ochan backlog logger = go
 	go = do
 		b <- readPty p
 		act <- atomically $ do
-			Backlog (bl@((prevhash, _) :| _)) <- readTVar backlog
 			let seen = Seen (Val b)
-			let act = Activity seen (Just prevhash) dummySignature
-			writeTChan ochan act
-			writeTVar backlog (Backlog ((hash act, act) :| toList bl))
-			return act
+			sendDeveloper ochan backlog (Proto seen)
 		logger $ ActivitySeen (act, hash act)
 		go
 
+sendDeveloper :: TChan (Activity Seen) -> TVar Backlog -> Proto Seen -> STM (Activity Seen)
+sendDeveloper ochan backlog pseen = do
+	Backlog (bl@((prevhash, _) :| _)) <- readTVar backlog
+	let act = Activity pseen (Just prevhash) dummySignature
+	writeTChan ochan act
+	writeTVar backlog (Backlog ((hash act, act) :| toList bl))
+	return act
+
 -- | Read things to be entered from the TChan, verify if they're legal,
 -- and send them to the Pty.
-sendPtyInput :: TChan (Activity Entered) -> Pty -> TVar Backlog -> Logger -> IO ()
-sendPtyInput ichan p backlog logger = go
+sendPtyInput :: TChan (Activity Entered) -> TChan (Activity Seen) -> Pty -> TVar Backlog -> Logger -> IO ()
+sendPtyInput ichan ochan p backlog logger = go
   where
 	go = do
 		networkDelay
@@ -177,15 +183,17 @@ sendPtyInput ichan p backlog logger = go
 					writeTVar backlog bl'
 					return (Right newact)
 				else do
-					return (Left (newact, bl'))
+					let reject = Rejected newact
+					Left <$> sendDeveloper ochan backlog reject
 		case v of
 			Right entered -> do
-				logger $ ActivityEntered True (entered, hash entered)
-				writePty p (val (enteredData (activity entered)))
+				logger $ ActivityEntered (entered, hash entered)
+				case activity entered of
+					Proto e -> writePty p (val (enteredData e))
+					Rejected r -> error $ "Protocol error: User side received a Rejected: " ++ show r
 				go
-			Left (illegalentered, _bl) -> do
-				logger $ ActivityEntered False (illegalentered, hash illegalentered)
-				-- print bl
+			Left rejact -> do
+				logger $ ActivitySeen (rejact, hash rejact)
 				go
 
 -- | Truncate the Backlog to remove entries older than the one
@@ -213,13 +221,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 entered hp sig) (Backlog (lastseen@(lastseenhash, _lastseen) :| bl))
+isLegal (Activity (Proto entered) hp sig) (Backlog (lastseen@(lastseenhash, _lastseen) :| bl))
 	| Just lastseenhash == 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 (seenData . activity . snd) sincehp)
+		in echoData entered == mconcat (map (getdata . activity . snd) sincehp)
 	| otherwise = False
+  where
+	getdata (Proto s) = seenData s
+	getdata (Rejected _) = mempty
+-- Developer should never send Rejected.
+isLegal (Activity (Rejected _) _ _) _ = False 
 
 dummySignature :: Signature
 dummySignature = Signature mempty