From 52f9c68869fa8956db55980f0b36ba817f825ffb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 26 Apr 2017 16:15:43 -0400 Subject: 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. --- Role/Developer.hs | 37 +++++++++++++++++++++++++------------ Role/Downloader.hs | 6 ++++-- Role/User.hs | 25 +++++++++++++++++-------- Role/Watcher.hs | 6 ++++-- 4 files changed, 50 insertions(+), 24 deletions(-) (limited to 'Role') 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 -- cgit v1.2.3