include elapsedTime in Activity

Time is relative, so the debug-me proof chain doesn't prove when things
happened, but it's still useful to have some idea of how long things
took to happen. This makes --replay work with logs gotten by --download.

Log still includes loggedTimestamp. This is a bit redundant, and is
unused now, but it's useful for log files to record when messages were
received.

This commit was sponsored by Riku Voipio.

4 files changed, 50 insertions, 24 deletions

diff --git a/Role/Developer.hs b/Role/Developer.hs
index 89ce2cf..8e27b30 100644
--- a/Role/Developer.hs
+++ b/Role/Developer.hs
@@ -20,6 +20,7 @@ import qualified Data.Text as T
 import Data.List
 import Data.Maybe
 import Control.Monad
+import Data.Time.Clock.POSIX
 
 run :: DeveloperOpts -> IO ()
 run = run' developer . debugUrl
@@ -49,6 +50,7 @@ data DeveloperState = DeveloperState
 	, enteredSince :: [Hash]
 	-- ^ Messages we've sent since the last Seen.
 	, lastActivity :: Hash
+	, lastActivityTs :: POSIXTime
 	-- ^ Last message sent or received.
 	, fromOtherDevelopersSince :: [Hash]
 	-- ^ Messages received from other developers since the last Seen.
@@ -71,6 +73,7 @@ sendTtyInput ichan devstate logger = go
 			then return ()
 			else send b
 	send b = do
+		ts <- getPOSIXTime
 		act <- atomically $ do
 			ds <- readTVar devstate
 			let ed = if lastActivity ds == lastSeen ds
@@ -83,13 +86,16 @@ sendTtyInput ichan devstate logger = go
 				, echoData = Val ed
 				}
 			let act = mkSigned (developerSessionKey ds) $
-				Activity entered (Just $ lastActivity ds)
+				Activity entered
+					(Just $ lastActivity ds)
+					(Just $ mkElapsedTime (lastActivityTs ds) ts)
 			writeTMChan ichan (ActivityMessage act)
 			let acth = hash act
 			let ds' = ds
 				{ sentSince = sentSince ds ++ [b]
 				, enteredSince = enteredSince ds ++ [acth]
 				, lastActivity = acth
+				, lastActivityTs = ts
 				}
 			writeTVar devstate ds'
 			return act
@@ -101,7 +107,8 @@ sendTtyOutput :: TMChan LogMessage -> TVar DeveloperState -> Logger -> IO ()
 sendTtyOutput ochan devstate logger = go
   where
 	go = do
-		v <- atomically $ getServerMessage ochan devstate
+		ts <- getPOSIXTime
+		v <- atomically $ getServerMessage ochan devstate ts
 		case v of
 			Nothing -> return ()
 			Just (o, l) -> do
@@ -123,8 +130,9 @@ authUser ichan ochan devstate logger = do
 	waitresp pk
   where
 	waitresp pk = do
+		ts <- getPOSIXTime
 		(o, msg) <- fromMaybe (error "Looks like that debug-me session is over.")
-			<$> atomically (getServerMessage ochan devstate)
+			<$> atomically (getServerMessage ochan devstate ts)
 		logger msg
 		emitOutput o
 		case o of
@@ -157,9 +165,9 @@ emitOutput NoOutput =
 
 -- | Get messages from server, check their signature, and make sure that they
 -- are properly chained from past messages, before returning.
-getServerMessage :: TMChan LogMessage -> TVar DeveloperState -> STM (Maybe (Output, LogMessage))
-getServerMessage ochan devstate = do
-	let ignore = getServerMessage ochan devstate
+getServerMessage :: TMChan LogMessage -> TVar DeveloperState -> POSIXTime -> STM (Maybe (Output, LogMessage))
+getServerMessage ochan devstate ts = do
+	let ignore = getServerMessage ochan devstate ts
 	mmsg <- readTMChan ochan
 	case mmsg of
 		Nothing -> return Nothing
@@ -193,8 +201,8 @@ getServerMessage ochan devstate = do
 					return (Just (NoOutput, Developer msg))
 				else ignore
   where
-	processuser ds (ActivityMessage act@(Activity (Seen (Val b)) _ _)) = do
-		let (legal, ds') = isLegalSeen act ds
+	processuser ds (ActivityMessage act@(Activity (Seen (Val b)) _ _ _)) = do
+		let (legal, ds') = isLegalSeen act ds ts
 		if legal
 			then do
 				writeTVar devstate ds'
@@ -227,9 +235,10 @@ getServerMessage ochan devstate = do
 -- ones, and returns an updated DeveloperState.
 --
 -- Does not check the signature.
-isLegalSeen :: Activity Seen -> DeveloperState -> (Bool, DeveloperState)
-isLegalSeen (Activity _ Nothing _) ds = (False, ds)
-isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _) ds
+isLegalSeen :: Activity Seen -> DeveloperState -> POSIXTime -> (Bool, DeveloperState)
+isLegalSeen (Activity _ Nothing _ _) ds _ = (False, ds)
+isLegalSeen (Activity _ _ Nothing _) ds _ = (False, ds)
+isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _ _) ds ts
 	-- Does it chain to the last Seen activity or to
 	-- something sent by another developer since the last Seen?
 	| hp == lastSeen ds || hp `elem` fromOtherDevelopersSince ds = 
@@ -246,6 +255,7 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _) ds
 			, sentSince = ss'
 			, enteredSince = es'
 			, lastActivity = acth
+			, lastActivityTs = ts
 			, fromOtherDevelopersSince = mempty
 			}
 	-- Does it chain to something we've entered since the last Seen
@@ -265,6 +275,7 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _) ds
 				, sentSince = ss'
 				, enteredSince = es'
 				, lastActivity = acth
+				, lastActivityTs = ts
 				, fromOtherDevelopersSince = mempty
 				}
   where
@@ -289,16 +300,18 @@ processSessionStart ochan logger = do
 		<$> atomically (readTMChan ochan)
 	logger startmsg
 	let (starthash, output) = case startmsg of
-		User (ActivityMessage act@(Activity (Seen (Val b)) Nothing _))
+		User (ActivityMessage act@(Activity (Seen (Val b)) Nothing Nothing _))
 			| verifySigned sigverifier act ->
 				(hash act, TtyOutput b)
 		_ -> error $ "Unexpected startup message: " ++ show startmsg
 	sk <- genMySessionKey
+	ts <- getPOSIXTime
 	st <- newTVarIO $ DeveloperState
 		{ lastSeen = starthash
 		, sentSince = mempty
 		, enteredSince = mempty
 		, lastActivity = starthash
+		, lastActivityTs = ts
 		, fromOtherDevelopersSince = mempty
 		, developerSessionKey = sk
 		, userSigVerifier = sigverifier
diff --git a/Role/Downloader.hs b/Role/Downloader.hs
index 07148e8..243410b 100644
--- a/Role/Downloader.hs
+++ b/Role/Downloader.hs
@@ -4,10 +4,11 @@ import Types
 import Log
 import CmdLine
 import SessionID
+import Role.Developer (run', processSessionStart, getServerMessage, Output(..))
 
 import Control.Concurrent.STM
 import Control.Concurrent.STM.TMChan
-import Role.Developer (run', processSessionStart, getServerMessage, Output(..))
+import Data.Time.Clock.POSIX
 
 run :: DownloadOpts -> IO ()
 run = run' downloader . downloadUrl
@@ -22,7 +23,8 @@ downloader _ichan ochan sid = do
 		go logger st
   where
 	go logger st = do
-		v <- atomically $ getServerMessage ochan st
+		ts <- getPOSIXTime
+		v <- atomically $ getServerMessage ochan st ts
 		case v of
 			Nothing -> return ()
 			Just (o, msg) -> do
diff --git a/Role/User.hs b/Role/User.hs
index 7a1c01c..fc6eaea 100644
--- a/Role/User.hs
+++ b/Role/User.hs
@@ -70,6 +70,7 @@ data UserState = UserState
 	{ backLog :: Backlog
 	, userSessionKey :: MySessionKey
 	, sigVerifier :: SigVerifier
+	, lastSeenTs :: POSIXTime
 	}
 
 -- | Start by establishing our session key, and displaying the starttxt.
@@ -83,16 +84,18 @@ startProtocol starttxt ochan logger = do
 	let c = mkSigned sk $ Control (SessionKey pk)
 	initialmessage $ ControlMessage c
 	let starttxt' = rawLine starttxt
-	let act = mkSigned sk $ Activity (Seen (Val starttxt')) Nothing
+	let act = mkSigned sk $ Activity (Seen (Val starttxt')) Nothing Nothing
 	let startmsg = ActivityMessage act
 	B.hPut stdout starttxt'
 	hFlush stdout
 	initialmessage startmsg
-	l <- mkLog (User startmsg) <$> getPOSIXTime
+	now <- getPOSIXTime
+	let l = mkLog (User startmsg) now
 	newTVarIO $ UserState
 		{ backLog = l :| []
 		, userSessionKey = sk
 		, sigVerifier = mempty
+		, lastSeenTs = now
 		}
 
 -- | Forward things the user types to the Pty.
@@ -138,10 +141,15 @@ instance SendableToDeveloper Seen where
 		let bl@(prev :| _) = backLog st
 		let msg = ActivityMessage $
 			mkSigned (userSessionKey st) $ 
-				Activity seen (loggedHash prev)
+				Activity seen
+					(loggedHash prev)
+					(Just $ mkElapsedTime (lastSeenTs st) now)
 		let l = mkLog (User msg) now
 		writeTMChan ochan msg
-		writeTVar us $ st { backLog = l :| toList bl }
+		writeTVar us $ st
+			{ backLog = l :| toList bl
+			, lastSeenTs = now
+			}
 		return msg
 
 instance SendableToDeveloper ControlAction where
@@ -252,7 +260,7 @@ checkDeveloperPublicKey ochan us logger pk = do
 -- If the Activity refers to an item not in the backlog, no truncation is
 -- done.
 truncateBacklog :: Backlog -> Activity Entered -> Backlog
-truncateBacklog (b :| l) (Activity _ (Just hp) _)
+truncateBacklog (b :| l) (Activity _ (Just hp) _ _)
 	| truncationpoint b = b :| []
 	| otherwise = b :| go [] l
   where
@@ -262,7 +270,7 @@ truncateBacklog (b :| l) (Activity _ (Just hp) _)
 		| otherwise = go (x:c) xs
 	truncationpoint x@(Log { loggedMessage = User {}}) = loggedHash x == Just hp
 	truncationpoint _ = False
-truncateBacklog bl (Activity _ Nothing _) = bl
+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
@@ -291,8 +299,9 @@ reduceBacklog (b :| l) = b :| go 0 (take 1000 l)
 --
 -- Does not check the signature.
 isLegalEntered :: Activity Entered -> UserState -> Bool
-isLegalEntered (Activity _ Nothing _) _ = False
-isLegalEntered (Activity a (Just hp) _) us
+isLegalEntered (Activity _ Nothing _ _) _ = False
+isLegalEntered (Activity _ _ Nothing _) _ = False
+isLegalEntered (Activity a (Just hp) _ _) us
 	| loggedHash lastact == Just hp = True
 	| B.null (val (echoData a)) = False -- optimisation
 	| any (== Just hp) (map loggedHash bl) =
diff --git a/Role/Watcher.hs b/Role/Watcher.hs
index c13234f..1ca0ae7 100644
--- a/Role/Watcher.hs
+++ b/Role/Watcher.hs
@@ -5,10 +5,11 @@ import Log
 import Pty
 import CmdLine
 import SessionID
+import Role.Developer (run', processSessionStart, getServerMessage, emitOutput)
 
 import Control.Concurrent.STM
 import Control.Concurrent.STM.TMChan
-import Role.Developer (run', processSessionStart, getServerMessage, emitOutput)
+import Data.Time.Clock.POSIX
 
 run :: WatchOpts -> IO ()
 run = run' watcher . watchUrl
@@ -20,7 +21,8 @@ watcher _ichan ochan _ = inRawMode $ do
 	go st
   where
 	go st = do
-		v <- atomically $ getServerMessage ochan st
+		ts <- getPOSIXTime
+		v <- atomically $ getServerMessage ochan st ts
 		case v of
 			Nothing -> return ()
 			Just (o, _msg) -> do