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. --- Crypto.hs | 4 ++-- Hash.hs | 7 +++++-- Replay.hs | 21 +++++++++------------ Role/Developer.hs | 37 +++++++++++++++++++++++++------------ Role/Downloader.hs | 6 ++++-- Role/User.hs | 25 +++++++++++++++++-------- Role/Watcher.hs | 6 ++++-- TODO | 3 --- Types.hs | 23 +++++++++++++++++++++-- 9 files changed, 87 insertions(+), 45 deletions(-) diff --git a/Crypto.hs b/Crypto.hs index d973034..e56db89 100644 --- a/Crypto.hs +++ b/Crypto.hs @@ -25,8 +25,8 @@ class Signed t where instance Hashable a => Signed (Activity a) where getSignature = activitySignature - hashExceptSignature (Activity a mp _s) = hash $ - Tagged "Activity" [hash a, hash mp] + hashExceptSignature (Activity a mp mt _s) = hash $ + Tagged "Activity" [hash a, hash mp, hash mt] instance Signed Control where getSignature = controlSignature diff --git a/Hash.hs b/Hash.hs index bef3ae0..c9b45e0 100644 --- a/Hash.hs +++ b/Hash.hs @@ -35,8 +35,8 @@ 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 mp s) = hash $ Tagged "Activity" - [hash a, hash mp, hash s] + hash (Activity a mp mt s) = hash $ Tagged "Activity" + [hash a, hash mp, hash mt, hash s] instance Hashable Entered where hash v = hash $ Tagged "Entered" @@ -62,6 +62,9 @@ instance Hashable PublicKey where instance Hashable GpgSig where hash (GpgSig v) = hash $ Tagged "GpgSig" v +instance Hashable ElapsedTime where + hash (ElapsedTime n) = hash $ Tagged "ElapsedTime" $ C8.pack $ show n + -- | Hash a list of hashes by hashing the concacenation of the hashes. instance Hashable [Hash] where hash = hash . B.concat . map (val . hashValue) diff --git a/Replay.hs b/Replay.hs index 1993ce3..8d2e3ae 100644 --- a/Replay.hs +++ b/Replay.hs @@ -9,22 +9,19 @@ import System.IO import Control.Concurrent.Thread.Delay replay :: ReplayOpts -> IO () -replay opts = go Nothing =<< streamLog (replayLogFile opts) +replay opts = go =<< streamLog (replayLogFile opts) where - go _ [] = return () - go prevts (Right l:ls) = do - case prevts of - Nothing -> return () - Just t -> - let s = loggedTimestamp l - t - ms = s * 1000000 - in delay (ceiling ms) - + go [] = return () + go (Right l:ls) = do case loggedMessage l of User (ActivityMessage a) -> do + maybe (return ()) realisticDelay (elapsedTime a) B.hPut stdout $ val $ seenData $ activity a hFlush stdout User (ControlMessage _) -> return () Developer _ -> return () - go (Just $ loggedTimestamp l) ls - go _ (Left l:_) = error $ "Failed to parse a line of the log: " ++ l + go ls + go (Left l:_) = error $ "Failed to parse a line of the log: " ++ l + +realisticDelay :: ElapsedTime -> IO () +realisticDelay (ElapsedTime n) = delay $ ceiling $ n * 1000000 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 diff --git a/TODO b/TODO index 821f5f5..8372df7 100644 --- a/TODO +++ b/TODO @@ -21,9 +21,6 @@ multiple developers, as each time a developer gets an Activity Seen, they can update their state to use the Activity Entered that it points to. -* --download gets a log without pauses, because timestamps are not - included in the wire protocol. Perhaps move the log timestamp to - data LogMessage? * Use protobuf for serialization, to make non-haskell implementations easier? * Leave the prevMessage out of Activity serialization to save BW. diff --git a/Types.hs b/Types.hs index 04855f4..c202f14 100644 --- a/Types.hs +++ b/Types.hs @@ -16,6 +16,8 @@ import Val import Memory import Serialization +import Data.Time.Clock.POSIX + -- | Things that the developer sees. data Seen = Seen { seenData :: Val @@ -48,7 +50,8 @@ instance DataSize a => DataSize (Message a) where dataSize (ControlMessage c) = dataSize c -- | An activity (either Entered or Seen) with a pointer --- to a previous Activity. +-- to a previous Activity, and the amount of time elapsed since the +-- previous Activity. -- -- The Signature is over both the data in the activity, and its pointer. -- @@ -57,13 +60,15 @@ instance DataSize a => DataSize (Message a) where data Activity a = Activity { activity :: a , prevActivity :: Maybe Hash + , elapsedTime :: Maybe ElapsedTime , activitySignature :: Signature } deriving (Show, Generic) instance DataSize a => DataSize (Activity a) where dataSize a = dataSize (activity a) - + maybe 0 dataSize (prevActivity a) + + maybe 0 dataSize (prevActivity a) + + maybe 0 dataSize (elapsedTime a) + dataSize (activitySignature a) -- | A control message, which can be sent asynchronously. @@ -136,11 +141,25 @@ newtype GpgSig = GpgSig Val instance DataSize GpgSig where dataSize (GpgSig s) = dataSize s +-- | Elapsed time in seconds. +newtype ElapsedTime = ElapsedTime Double + deriving (Show, Generic, Eq) + +mkElapsedTime :: POSIXTime -> POSIXTime -> ElapsedTime +mkElapsedTime start end = ElapsedTime $ fromRational $ toRational (end - start) + +instance DataSize ElapsedTime where + dataSize _ = 16 -- 128 bit Double + data LogMessage = User (Message Seen) | Developer (Message Entered) deriving (Show, Generic) +instance Binary ElapsedTime +instance ToJSON ElapsedTime +instance FromJSON ElapsedTime + instance DataSize LogMessage where dataSize (User a) = dataSize a dataSize (Developer a) = dataSize a -- cgit v1.2.3