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.

10 files changed, 332 insertions, 225 deletions

diff --git a/CmdLine.hs b/CmdLine.hs
index 2cfea7a..cf9e2b7 100644
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -1,5 +1,6 @@
 module CmdLine where
 
+import Data.Monoid
 import Options.Applicative
 
 data CmdLine = CmdLine
diff --git a/Crypto.hs b/Crypto.hs
index 8d4a350..a99d497 100644
--- a/Crypto.hs
+++ b/Crypto.hs
@@ -11,7 +11,7 @@ import Data.ByteArray (convert)
 import Data.ByteString
 
 dummySignature :: Signature
-dummySignature = OtherSignature (Val undefined)
+dummySignature = OtherSignature (Val mempty)
 
 -- | Sign any Hashable value.
 sign :: Hashable v => MySessionKey -> v -> Signature
diff --git a/Graphviz.hs b/Graphviz.hs
index b85821c..59f3bf9 100644
--- a/Graphviz.hs
+++ b/Graphviz.hs
@@ -7,7 +7,7 @@ import Hash
 import CmdLine
 import Log
 
-import Data.Char
+import Data.Char hiding (Control)
 import Data.Monoid
 import Data.GraphViz
 import Data.GraphViz.Attributes.Complete
@@ -30,42 +30,48 @@ graphviz opts = do
 createImage :: PrintDotRepr dg n => FilePath -> GraphvizOutput -> dg n -> IO FilePath
 createImage f o g = Data.GraphViz.addExtension (runGraphvizCommand Dot g) o f
 
-genGraph :: GraphvizOpts -> [ActivityLog] -> G.DotGraph T.Text
+genGraph :: GraphvizOpts -> [Log] -> G.DotGraph T.Text
 genGraph opts ls = digraph (Str "debug-me") $ do
 	nodeAttrs [style filled]
 	forM_ ls $
-		showactivity [ xcolor Green ]
+		showlog [ xcolor Green ]
   where
-	showactivity s l = case loggedActivity l of
-		ActivitySeen a -> do
+	showlog s l = case (loggedMessage l, loggedHash l) of
+		(User (ActivityMessage a), Just h) -> do
 			node (display h) $ s ++
 				[ textLabel $ prettyDisplay $ activity a
 				, shape BoxShape
 				]
-			case activity a of
-				Rejected ar -> do
-					let hr = hash ar
-					let rejstyle =
-						[ xcolor Red
-						, Style [dashed, filled]
-						]
-					showactivity rejstyle $
-						ActivityLog
-							{ loggedActivity = ActivityEntered ar
-							, loggedHash = hr
-							, loggedTimestamp = loggedTimestamp l
-							}
-					link hr h rejstyle
-				_ -> return ()
 			linkprev s a h
-		ActivityEntered a -> do
+		(Developer (ActivityMessage a), Just h) -> do
 			node (display h) $ s ++
 				[ textLabel $ prettyDisplay $ activity a
 				, shape Circle
 				]
 			linkprev s a h
-	  where
-		h = loggedHash l
+		(User (ControlMessage c), Nothing) -> showcontrol c l
+		(Developer (ControlMessage c), Nothing) -> showcontrol c l
+		_ -> return ()
+
+	showcontrol (Control (Rejected ar) _) l = do
+		let hr = hash ar
+		let rejstyle =
+			[ xcolor Red
+			, Style [dashed, filled]
+			]
+		let nodename = display $ "Rejected " <> display hr
+		node nodename $ rejstyle ++
+			[ textLabel "Rejected"
+			, shape BoxShape
+			]
+		showlog rejstyle $ Log
+			{ loggedMessage = Developer (ActivityMessage ar)
+			, loggedHash = Just hr
+			, loggedTimestamp = loggedTimestamp l
+			}
+		edge nodename (display hr) rejstyle
+	showcontrol _ _ = return ()
+
 	linkprev s a h = case prevActivity a of
 		Nothing -> return ()
 		Just p -> link p h s
@@ -114,6 +120,8 @@ instance Display Entered where
 		| B.null (val $ echoData v) = display $ enteredData v
 		| otherwise = "[" <> display (echoData v) <> "] " <> display (enteredData v)
 
-instance Display a => Display (Proto a) where
-	display (Proto a) = display a
-	display (Rejected a) = "Rejected: " <> display (activity a)
+instance Display Control where
+	display = display . control
+
+instance Display ControlAction where
+	display = T.pack . show
diff --git a/Hash.hs b/Hash.hs
index 2577c6b..e22abf3 100644
--- a/Hash.hs
+++ b/Hash.hs
@@ -38,10 +38,6 @@ instance Hashable a => Hashable (Activity a) where
 	hash (Activity a mp s) = hash $ Tagged "Activity"
 		[hash a, hash mp, 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 $ Tagged "Entered"
 		[hash (enteredData v), hash (echoData v)]
@@ -50,8 +46,15 @@ instance Hashable Seen where
 	hash v = hash $ Tagged "Seen" [hash (seenData v)]
 
 instance Hashable Signature where
-	hash (Ed25519 s) = hash $ Tagged "Ed25519" s
-	hash Unsigned = hash $ Tagged "Unsigned" (mempty :: B.ByteString)
+	hash (Ed25519Signature s) = hash $ Tagged "Ed25519Signature" s
+	hash (OtherSignature s) = hash $ Tagged "OtherSignature" s
+
+instance Hashable PublicKey where
+	hash (PublicKey v gpgsig) = hash $ Tagged "PublicKey"
+		[hash v, hash gpgsig]
+
+instance Hashable GpgSig where
+	hash (GpgSig v) = hash $ Tagged "GpgSig" v
 
 -- | Hash a list of hashes by hashing the concacenation of the hashes.
 instance Hashable [Hash] where
@@ -59,5 +62,8 @@ instance Hashable [Hash] where
 
 -- | Hash empty string for Nothing
 instance Hashable v => Hashable (Maybe v) where
-	hash Nothing = hash (mempty :: B.ByteString)
+	hash Nothing = hash ()
 	hash (Just v) = hash v
+
+instance Hashable () where
+	hash () = hash (mempty :: B.ByteString)
diff --git a/Log.hs b/Log.hs
index f483e7d..2993ad8 100644
--- a/Log.hs
+++ b/Log.hs
@@ -13,72 +13,75 @@ import Data.Time.Clock.POSIX
 import qualified Data.ByteString.Lazy as L
 import System.IO
 
--- | A log of Activity both Entered and Seen, which can be recorded to
--- prove what happened in a debug-me session.
+-- | One item in a log of a debug-me session.
 --
 -- Note that the time stamp is included to allow replaying logs, but
 -- it's not part of the provable session.
 --
 -- Note that changing this in ways that change the JSON serialization
 -- changes debug-me's log file format.
-data ActivityLog = ActivityLog
-	{ loggedActivity :: SomeActivity
-	, loggedHash :: Hash
+data Log = Log
+	{ loggedMessage :: LogMessage
+	, loggedHash :: Maybe Hash
 	, loggedTimestamp :: Timestamp
 	}
 	deriving (Show, Generic)
 
-instance DataSize ActivityLog where
-	dataSize l = dataSize (loggedActivity l) + dataSize (loggedHash l) + 2
+instance DataSize Log where
+	dataSize l = dataSize (loggedMessage l)
+		+ maybe 0 dataSize (loggedHash l)
+		+ 2
 
-instance ToJSON (ActivityLog)
-instance FromJSON (ActivityLog)
+instance ToJSON Log
+instance FromJSON Log
 
-data SomeActivity
-	= ActivitySeen (Activity Seen)
-	| ActivityEntered (Activity Entered)
+data LogMessage
+	= User (Message Seen)
+	| Developer (Message Entered)
 	deriving (Show, Generic)
 
-instance DataSize SomeActivity where
-	dataSize (ActivitySeen a) = dataSize a
-	dataSize (ActivityEntered a) = dataSize a
+instance DataSize LogMessage where
+	dataSize (User a) = dataSize a
+	dataSize (Developer a) = dataSize a
 
-instance ToJSON SomeActivity where
+instance ToJSON LogMessage where
 	toJSON = genericToJSON sumOptions
 	toEncoding = genericToEncoding sumOptions
-instance FromJSON SomeActivity where
+instance FromJSON LogMessage where
 	parseJSON = genericParseJSON sumOptions
 
-mkActivityLog :: SomeActivity -> POSIXTime -> ActivityLog
-mkActivityLog a now = ActivityLog
-	{ loggedActivity = a
-	, loggedHash = case a of
-		ActivitySeen s -> hash s
-		ActivityEntered e -> hash e
+mkLog :: LogMessage -> POSIXTime -> Log
+mkLog m now = Log
+	{ loggedMessage = m
+	, loggedHash = case m of
+		User (ActivityMessage a) -> Just (hash a)
+		Developer (ActivityMessage a) -> Just (hash a)
+		User (ControlMessage _) -> Nothing
+		Developer (ControlMessage _) -> Nothing
 	, loggedTimestamp = now
 	}
 
 type Timestamp = POSIXTime
 
-type Logger = SomeActivity -> IO ()
+type Logger = LogMessage -> IO ()
 
 withLogger :: FilePath -> (Logger -> IO a) -> IO a
 withLogger logfile a = withFile logfile WriteMode (a . mkLogger)
 
 mkLogger :: Handle -> Logger
 mkLogger h a = do
-	l <- mkActivityLog a <$> getPOSIXTime
+	l <- mkLog a <$> getPOSIXTime
 	L.hPut h (encode l)
 	hPutStr h "\n"
 	hFlush h
 
-parseLog :: L.ByteString -> [Either String ActivityLog]
+parseLog :: L.ByteString -> [Either String Log]
 parseLog = map eitherDecode' 
 	. filter (not . L.null)
 	. L.split (fromIntegral (ord '\n'))
 
 -- | Throws exception on unparsable log.
-loadLog :: FilePath -> IO [ActivityLog]
+loadLog :: FilePath -> IO [Log]
 loadLog f = do
 	parsed <- parseLog <$> L.readFile f
 	case lefts parsed of
diff --git a/Replay.hs b/Replay.hs
index b50bc40..b13012d 100644
--- a/Replay.hs
+++ b/Replay.hs
@@ -21,11 +21,10 @@ replay opts = go Nothing =<< loadLog (replayLogFile opts)
 				    ms = s * 1000000
 				in delay (ceiling ms)
 
-		case loggedActivity l of
-			ActivityEntered {} -> return ()
-			ActivitySeen a -> case activity a of
-				Rejected {} -> return ()
-				Proto s -> do
-					B.hPut stdout (val (seenData s))
-					hFlush stdout
+		case loggedMessage l of
+			User (ActivityMessage a) -> do
+				B.hPut stdout $ val $ seenData $ activity a
+				hFlush stdout
+			User (ControlMessage _) -> return ()
+			Developer _ -> return ()
 		go (Just $ loggedTimestamp l) ls
diff --git a/TODO b/TODO
index 8c37049..89f8cd9 100644
--- a/TODO
+++ b/TODO
@@ -2,6 +2,8 @@
   Do include it in the data that gets signed, so it can be recovered
   by trying each likely (recently seen) Activity as the prevMessage, and
   checking the signature.
+  (If doing this, might as well switch to SHA512, since hash size does not
+  matter.)
 * loadLog should verify the hashes (and signatures) in the log, and
   refuse to use logs that are not valid proofs of a session.
 * Encryption!
diff --git a/Types.hs b/Types.hs
index dbbb432..27c9e67 100644
--- a/Types.hs
+++ b/Types.hs
@@ -36,33 +36,60 @@ data Entered = Entered
 instance DataSize Entered where
 	dataSize e = dataSize (enteredData e) + dataSize (echoData e)
 
--- | 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.
+-- | A message in the protocol.
+data Message a
+	= ActivityMessage (Activity a)
+	| ControlMessage Control
 	deriving (Show, Generic)
 
-instance DataSize a => DataSize (Proto a) where
-	dataSize (Proto a) = dataSize a
-	dataSize (Rejected a) = dataSize a
+instance DataSize a => DataSize (Message a) where
+	dataSize (ActivityMessage a) = dataSize a
+	dataSize (ControlMessage c) = dataSize c
 
--- | A Proto activity (either Entered or Seen) with a pointer
--- to the Activity before this one.
+-- | An activity (either Entered or Seen) with a pointer
+-- to a previous Activity.
 --
 -- The Signature is over both the data in the activity, and its pointer.
 data Activity a = Activity
-	{ activity :: Proto a
-	, prevActivity :: (Maybe Hash)
-	, signature :: Signature
+	{ activity :: a
+	, prevActivity :: Maybe Hash
+	, activitySignature :: Signature
 	}
 	deriving (Show, Generic)
 
 instance DataSize a => DataSize (Activity a) where
 	dataSize a = dataSize (activity a) 
 		+ maybe 0 dataSize (prevActivity a) 
-		+ dataSize (signature a)
+		+ dataSize (activitySignature a)
+
+-- | A control message, which can be sent asynchronously.
+data Control = Control
+	{ control :: ControlAction
+	, controlSignature :: Signature
+	}
+	deriving (Show, Generic)
+
+instance DataSize Control where
+	dataSize c = dataSize (control c)
+		+ dataSize (controlSignature c)
+
+data ControlAction
+	= Rejected (Activity Entered)
+	-- ^ sent by user to indicate when an Entered value was rejected.
+	| SessionKey PublicKey
+	-- ^ sent by user at start, and later by developer,
+	-- to indicate their session key
+	| SessionKeyAccepted PublicKey
+	-- ^ sent by the user to in response to SessionKey
+	| SessionKeyRejected PublicKey
+	-- ^ sent by the user to in response to SessionKey
+	deriving (Show, Generic)
+
+instance DataSize ControlAction where
+	dataSize (Rejected a) = dataSize a
+	dataSize (SessionKey k) = dataSize k
+	dataSize (SessionKeyAccepted k) = dataSize k
+	dataSize (SessionKeyRejected k) = dataSize k
 
 data Hash = Hash
 	{ hashMethod :: HashMethod
@@ -80,14 +107,30 @@ data HashMethod = SHA256 | SHA3
 	deriving (Show, Generic, Eq)
 
 data Signature 
-	= Ed25519 Val
-	| Unsigned
+	= Ed25519Signature Val
+	| OtherSignature Val
 	-- ^ Not used, but included to future-proof the JSON format.
 	deriving (Show, Generic)
 
 instance DataSize Signature where
-	dataSize (Ed25519 _) = 64
-	dataSize Unsigned = 0
+	dataSize (Ed25519Signature v) = dataSize v
+	dataSize (OtherSignature v) = dataSize v
+
+-- | A public key used for a debug-me session.
+-- It may be signed with a gpg key.
+data PublicKey = PublicKey Val (Maybe GpgSig)
+	deriving (Show, Generic)
+
+instance DataSize PublicKey where
+	-- ed25519 public keys are 32 bytes
+	dataSize (PublicKey _ ms) = 32 + maybe 0 dataSize ms
+
+-- | A signature made with a gpg key.
+newtype GpgSig = GpgSig Val
+	deriving (Show, Generic)
+
+instance DataSize GpgSig where
+	dataSize (GpgSig s) = dataSize s
 
 instance ToJSON Seen
 instance FromJSON Seen
@@ -97,21 +140,27 @@ instance ToJSON (Activity Seen)
 instance FromJSON (Activity Seen)
 instance ToJSON (Activity Entered)
 instance FromJSON (Activity Entered)
+instance ToJSON Control
+instance FromJSON Control
 instance ToJSON Hash
 instance FromJSON Hash
 instance ToJSON HashMethod
 instance FromJSON HashMethod
+instance ToJSON PublicKey
+instance FromJSON PublicKey
+instance ToJSON GpgSig
+instance FromJSON GpgSig
 
-instance ToJSON (Proto Seen) where
+instance ToJSON (Message Seen) where
 	toJSON = genericToJSON sumOptions
 	toEncoding = genericToEncoding sumOptions
-instance FromJSON (Proto Seen) where
+instance FromJSON (Message Seen) where
 	parseJSON = genericParseJSON sumOptions
 
-instance ToJSON (Proto Entered) where
+instance ToJSON (Message Entered) where
 	toJSON = genericToJSON sumOptions
 	toEncoding = genericToEncoding sumOptions
-instance FromJSON (Proto Entered) where
+instance FromJSON (Message Entered) where
 	parseJSON = genericParseJSON sumOptions
 
 instance ToJSON Signature where
@@ -120,3 +169,8 @@ instance ToJSON Signature where
 instance FromJSON Signature where
 	parseJSON = genericParseJSON sumOptions
 
+instance ToJSON ControlAction where
+	toJSON = genericToJSON sumOptions
+	toEncoding = genericToEncoding sumOptions
+instance FromJSON ControlAction where
+	parseJSON = genericParseJSON sumOptions
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
diff --git a/protocol.txt b/protocol.txt
index 67317ab..c71a84f 100644
--- a/protocol.txt
+++ b/protocol.txt
@@ -1,9 +1,9 @@
 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
+(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. 
+from.)
 
 The Activity type is the main message type. The user sends Activity
 Seen messages, and the developer responds with Activity Entered.
@@ -18,10 +18,10 @@ Activity Seen and Activity Entered messages have a prevActivity,
 which points to the Hash of a previous Activity. (And is Nothing for the
 first Activity Seen.) So a chain of messages is built up.
 
-The exact details about how these objects are hashed is not described here;
+(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.
+instead the values in the data types are hashed.)
 
 The user and developer have different points of view. For example,
 the developer could send an Activity Entered at the same time the user