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.

5 files changed, 141 insertions, 44 deletions

diff --git a/Graphviz.hs b/Graphviz.hs
index 81ff71a..0809468 100644
--- a/Graphviz.hs
+++ b/Graphviz.hs
@@ -47,18 +47,16 @@ genGraph ls = digraph (Str "debug-me") $ do
 	forM_ ls $ \l -> case l of
 		ActivitySeen { activitySeen = (a, h) } -> do
 			node (display h)
-				[ textLabel $ display $ seenData $ activity a
-				, shape Circle
+				[ textLabel $ display $ activity a
+				, shape BoxShape
 				, xcolor Green
 				]
 			chain a h
 		ActivityEntered { activityEntered = (a, h) } -> do
 			node (display h)
-				[ textLabel $ display $ enteredData $ activity a
-				, shape Square
-				, if activityEnteredAccepted l
-					then xcolor Green
-					else xcolor Red
+				[ textLabel $ display $ activity a
+				, shape Circle
+				, xcolor Green
 				]
 			chain a h
   where
@@ -77,3 +75,13 @@ instance Display Val where
 
 instance Display Hash where
 	display (Hash m h) = T.pack (show m) <> display h
+
+instance Display Seen where
+	display = display . seenData
+
+instance Display Entered where
+	display = display . enteredData
+
+instance Display a => Display (Proto a) where
+	display (Proto a) = display a
+	display (Rejected a) = "Rejected " <> display (activity a)
diff --git a/Hash.hs b/Hash.hs
index 53be540..9b5fa80 100644
--- a/Hash.hs
+++ b/Hash.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}
 
 module Hash where
 
@@ -18,22 +18,46 @@ instance Hashable B.ByteString where
 instance Hashable Val where
 	hash (Val v) = hash v
 
+instance Hashable Hash where
+	hash = id
+
 sha256 :: B.ByteString -> H.Digest H.SHA256
 sha256 = H.hash
 
--- | Hash the concacenation of the hashes.
-instance Hashable [Hash] where
-	hash = hash . B.concat . map (val . hashValue)
+-- | A value tagged with a ByteString describing the type of value.
+-- This is hashed by hashing the concacenation of the hash of the
+-- bytestring and the hash of the value. This way, items of different types
+-- but with the same internal content will hash differently. For example,
+-- a Seen "foo" and a Entered "foo" should not hash the same.
+data Tagged a = Tagged B.ByteString a
+
+instance Hashable a => Hashable (Tagged a) where
+	hash (Tagged b a) = hash [hash b, hash a]
 
 instance Hashable a => Hashable (Activity a) where
-	hash (Activity a (Just p) s) = hash [hash a, p, hash s]
-	hash (Activity a Nothing s) = hash [hash a, hash s]
+	hash (Activity a (Just p) s) = hash $ Tagged "Activity"
+		[hash a, hash p, hash s]
+	hash (Activity a Nothing s) = hash $ Tagged "Activity"
+		[hash a, hash (), hash s]
+
+instance Hashable a => Hashable (Proto a) where
+	hash (Proto a) = hash $ Tagged "Proto" a
+	hash (Rejected a) = hash $ Tagged "Rejected" (hash a)
 
 instance Hashable Entered where
-	hash v = hash [hash (enteredData v), hash (echoData v)]
+	hash v = hash $ Tagged "Entered"
+		[hash (enteredData v), hash (echoData v)]
 
 instance Hashable Seen where
-	hash v = hash [hash (seenData v)]
+	hash v = hash $ Tagged "Seen" [hash (seenData v)]
 
 instance Hashable Signature where
-	hash (Signature s) = hash s
+	hash (Signature s) = hash $ Tagged "Signature" s
+
+-- | Hash a list of hashes by hashing the concacenation of the hashes.
+instance Hashable [Hash] where
+	hash = hash . B.concat . map (val . hashValue)
+
+-- | Hash empty string for ()
+instance Hashable () where
+	hash () = hash (mempty :: B.ByteString)
diff --git a/Types.hs b/Types.hs
index 7837f71..b7c5f32 100644
--- a/Types.hs
+++ b/Types.hs
@@ -37,12 +37,25 @@ data Entered = Entered
 instance ToJSON Entered
 instance FromJSON Entered
 
--- | An activity (either Entered or Seen) with a pointer
+-- | High level protocol.
+data Proto a
+	= Proto a
+	-- ^ either Entered or Seen
+	| Rejected (Activity Entered)
+	-- ^ sent by user to indicate when an Entered value was rejected.
+	deriving (Show, Generic)
+
+instance ToJSON (Proto Seen)
+instance FromJSON (Proto Seen)
+instance ToJSON (Proto Entered)
+instance FromJSON (Proto Entered)
+
+-- | A Proto activity (either Entered or Seen) with a pointer
 -- to the Activity before this one.
 --
 -- The Signature is over both the data in the activity, and its pointer.
 data Activity a = Activity
-	{ activity :: a
+	{ activity :: Proto a
 	, prevActivity :: (Maybe Hash)
 	, signature :: Signature
 	}
@@ -53,14 +66,14 @@ instance FromJSON (Activity Seen)
 instance ToJSON (Activity Entered)
 instance FromJSON (Activity Entered)
 
--- | A log of Activity both Entered and Seen.
+-- | A log of Activity both Entered and Seen, which can be recorded to
+-- prove what happened in a debug-me session.
 data ActivityLog
 	= ActivitySeen
 		{ activitySeen :: (Activity Seen, Hash)
 		}
 	| ActivityEntered
-		{ activityEnteredAccepted :: Bool
-		, activityEntered :: (Activity Entered, Hash)
+		{ activityEntered :: (Activity Entered, Hash)
 		}
 	deriving (Show, Generic)
 
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
diff --git a/protocol.txt b/protocol.txt
new file mode 100644
index 0000000..223f58a
--- /dev/null
+++ b/protocol.txt
@@ -0,0 +1,39 @@
+The debug-me protocol is a series of JSON objects, exchanged between
+the two participants, known as the user and the developer.
+
+The exact composition of the JSON objects is not described here; see
+Types.hs for the data types that JSON serialization instances are derived
+from.
+
+A debug-me session starts with the user sending an Activity Seen
+containing some introductory message. This first Activity Seen has
+Nothing as its prevActivity. All subsequent Activity sent by either the
+user or developer has a prevActivity that points to the Hash of
+the previous activity, so a chain of Activity is built up.
+
+The exact details about how these objects are hashed is not described here;
+see Hash.hs for the implementation. Note that the JSON strings are *not*
+directly hashed (to avoid tying hashing to JSON serialization details),
+instead the values in the data types are hashed.
+
+The user and developer have different points of view; the debug-me protocol
+makes sure that both sides agree on what is happening, to avoid
+disagreements. For example, the developer could send an Activity Entered
+at the same time the user is sending an Activity Seen. In this case,
+the developer didn't see something that happened while they were entering
+a command. So, when the user receives their Activity Entered, and sees that
+its prevActivity does not point to the just sent Activity Seen, the user
+will reject that input, sending back a Rejected message to let the
+developer know.
+
+This requirement that the developer always send Activity Entered that points
+to the last Activity that the user has sent/accepted is known as the
+synchronicity requirement.
+
+The synchronicity requirement can be problematic when the developer is
+entering a command, because each letter they type gets echoed back, and
+that echo happens asynchronously. To avoid needing to wait for the letter
+to be echoed back before the next letter can be entered, the debug-me
+protocol allows the developer to include echoDatta in an Activity Entered.
+
+