From 1d18dcbe796820b30e0c8c1db241da95ee7566cb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 18 Apr 2017 13:04:16 -0400 Subject: improve types Including adding a timestamp to logs --- Graphviz.hs | 43 ++++++++++++++++++++++----------------- TODO | 1 + Types.hs | 30 +++++++++++++++++---------- debug-me.cabal | 1 + debug-me.hs | 64 +++++++++++++++++++++++++++++++++++----------------------- 5 files changed, 85 insertions(+), 54 deletions(-) diff --git a/Graphviz.hs b/Graphviz.hs index 9d508c8..c6ce8a9 100644 --- a/Graphviz.hs +++ b/Graphviz.hs @@ -50,29 +50,36 @@ genGraph opts ls = digraph (Str "debug-me") $ do forM_ ls $ showactivity [ xcolor Green ] where - showactivity s (ActivitySeen { activitySeen = (a, 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 $ - ActivityEntered (ar, hr) - link hr h rejstyle - _ -> return () - linkprev s a h - showactivity s (ActivityEntered { activityEntered = (a, h) }) = do + showactivity s l = case loggedActivity l of + ActivitySeen a -> 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 node (display h) $ s ++ [ textLabel $ prettyDisplay $ activity a , shape Circle ] linkprev s a h + where + h = loggedHash l linkprev s a h = case prevActivity a of Nothing -> return () Just p -> link p h s diff --git a/TODO b/TODO index 03b0a70..4dd8d07 100644 --- a/TODO +++ b/TODO @@ -1,3 +1,4 @@ +* Add timings, so logs can be replayed. * Improve JSON, removing use of "tag" * potential DOS where developer sends Activity Entered that all refer back to the first Activity Seen. This requires the user diff --git a/Types.hs b/Types.hs index fdd10a5..0e918ea 100644 --- a/Types.hs +++ b/Types.hs @@ -15,6 +15,7 @@ import Val import GHC.Generics (Generic) import Data.Aeson +import Data.Time.Clock.POSIX -- | Things that the developer sees. data Seen = Seen @@ -66,24 +67,31 @@ instance FromJSON (Activity Seen) instance ToJSON (Activity Entered) instance FromJSON (Activity Entered) +data SomeActivity + = ActivitySeen (Activity Seen) + | ActivityEntered (Activity Entered) + deriving (Show, Generic) + +instance ToJSON (SomeActivity) +instance FromJSON (SomeActivity) + -- | 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 - { activityEntered :: (Activity Entered, Hash) - } +-- +-- Note that the time stamp is included to allow replaying logs, but +-- it's not part of the provable session. +data ActivityLog = ActivityLog + { loggedActivity :: SomeActivity + , loggedHash :: Hash + , loggedTimestamp :: Timestamp + } deriving (Show, Generic) -activityLogHash :: ActivityLog -> Hash -activityLogHash (ActivitySeen (_, h)) = h -activityLogHash (ActivityEntered (_, h)) = h - instance ToJSON (ActivityLog) instance FromJSON (ActivityLog) +type Timestamp = POSIXTime + newtype Signature = Signature Val deriving (Show, Generic) diff --git a/debug-me.cabal b/debug-me.cabal index 0535172..54f1bc9 100644 --- a/debug-me.cabal +++ b/debug-me.cabal @@ -36,6 +36,7 @@ Executable debug-me , text (>= 1.2) , optparse-applicative (>= 0.12) , graphviz (== 2999.18.*) + , time (>= 1.6) Other-Modules: CmdLine Graphviz diff --git a/debug-me.hs b/debug-me.hs index 793eb2e..058e23a 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -20,6 +20,7 @@ import Data.List import Data.List.NonEmpty (NonEmpty(..), toList) import Data.Monoid import Data.Aeson +import Data.Time.Clock.POSIX main :: IO () main = do @@ -52,7 +53,7 @@ networkDelay = threadDelay 800000 -- 800 ms ; the latency to geosync orbit developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO () developer ichan ochan = withLogger "debug-me-developer.log" $ \logger -> do startact <- atomically $ readTChan ochan - logger $ ActivitySeen (startact, hash startact) + logger $ ActivitySeen startact case startact of Activity (Proto (Seen (Val b))) Nothing sig -> do B.hPut stdout b @@ -107,7 +108,7 @@ sendTtyInput ichan devstate logger = go } writeTVar devstate ds' return act - logger $ ActivityEntered (act, hash act) + logger $ ActivityEntered act go -- | Read activity from the TChan and display it to the developer. @@ -116,7 +117,7 @@ sendTtyOutput ochan devstate logger = go where go = do (v, act) <- atomically $ processOutput ochan devstate - logger $ ActivitySeen (act, hash act) + logger $ ActivitySeen act case v of ProtocolError e -> protocolError e TtyOutput b -> do @@ -201,8 +202,8 @@ 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 - let l = ActivitySeen (startact, hash startact) - logger l + logger $ ActivitySeen startact + l <- mkActivityLog (ActivitySeen startact) <$> getPOSIXTime atomically $ writeTChan ochan startact backlog <- newTVarIO $ Backlog (l :| []) _ <- sendPtyOutput p ochan backlog logger @@ -213,36 +214,48 @@ user startmsg p ichan ochan = withLogger "debug-me.log" $ \logger -> do data Backlog = Backlog (NonEmpty ActivityLog) deriving (Show) -type Logger = ActivityLog -> IO () +type Logger = SomeActivity -> IO () withLogger :: FilePath -> (Logger -> IO a) -> IO a withLogger logfile a = withFile logfile WriteMode (a . mkLogger) mkLogger :: Handle -> Logger mkLogger h a = do - L.hPut h (encode a) + l <- mkActivityLog a <$> getPOSIXTime + L.hPut h (encode l) hPutStr h "\n" hFlush h +mkActivityLog :: SomeActivity -> POSIXTime -> ActivityLog +mkActivityLog a now = ActivityLog + { loggedActivity = a + , loggedHash = case a of + ActivitySeen s -> hash s + ActivityEntered e -> hash e + , loggedTimestamp = now + } + -- | Forward things written to the Pty out the TChan. sendPtyOutput :: Pty -> TChan (Activity Seen) -> TVar Backlog -> Logger -> IO () sendPtyOutput p ochan backlog logger = go where go = do b <- readPty p + now <- getPOSIXTime act <- atomically $ do let seen = Seen (Val b) - sendDeveloper ochan backlog (Proto seen) - logger $ ActivitySeen (act, hash act) + sendDeveloper ochan backlog (Proto seen) now + logger $ ActivitySeen act go -sendDeveloper :: TChan (Activity Seen) -> TVar Backlog -> Proto Seen -> STM (Activity Seen) -sendDeveloper ochan backlog pseen = do +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 = activityLogHash prev + let prevhash = loggedHash prev let act = Activity pseen (Just prevhash) dummySignature + let l = mkActivityLog (ActivitySeen act) now writeTChan ochan act - writeTVar backlog (Backlog (ActivitySeen (act, hash act) :| toList bl)) + writeTVar backlog $ Backlog (l :| toList bl) return act -- | Read things to be entered from the TChan, verify if they're legal, @@ -252,6 +265,7 @@ sendPtyInput ichan ochan p backlog logger = go where go = do networkDelay + now <- getPOSIXTime v <- atomically $ do entered <- readTChan ichan bl <- readTVar backlog @@ -260,21 +274,21 @@ sendPtyInput ichan ochan p backlog logger = go let bl'@(Backlog bll) = truncateBacklog bl entered if isLegalEntered entered bl' then do - let l = ActivityEntered (entered, hash entered) + let l = mkActivityLog (ActivityEntered entered) now writeTVar backlog (Backlog (l :| toList bll)) - return (Right (entered, l)) + return (Right entered) else do let reject = Rejected entered - Left <$> sendDeveloper ochan backlog reject + Left <$> sendDeveloper ochan backlog reject now case v of - Right (entered, l) -> do - logger l + 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 go Left rejact -> do - logger $ ActivitySeen (rejact, hash rejact) + logger $ ActivitySeen rejact go -- | Truncate the Backlog to remove entries older than the one @@ -296,7 +310,7 @@ truncateBacklog (Backlog (b :| l)) (Activity _ hp _) go c (x:xs) | truncationpoint x = reverse (x:c) | otherwise = go (x:c) xs - truncationpoint x@(ActivitySeen {}) = Just (activityLogHash x) == hp + truncationpoint x@(ActivityLog { loggedActivity = ActivitySeen {}}) = Just (loggedHash x) == hp truncationpoint _ = False -- | Entered activity is legal when it points to the last Seen activvity, @@ -310,14 +324,14 @@ truncateBacklog (Backlog (b :| l)) (Activity _ hp _) -- most recent Seen activity. isLegalEntered :: Activity Entered -> Backlog -> Bool isLegalEntered (Activity (Proto entered) hp sig) (Backlog (lastseen :| bl)) - | Just (activityLogHash lastseen) == hp = True + | Just (loggedHash lastseen) == hp = True | B.null (val (echoData entered)) = False -- optimisation - | any (== hp) (map (Just . activityLogHash) bl) = - let sincehp = reverse (lastseen : takeWhile (\l -> Just (activityLogHash l) /= hp) bl) - in echoData entered == mconcat (map getseen sincehp) + | any (== hp) (map (Just . loggedHash) bl) = + let sincehp = reverse (lastseen : takeWhile (\l -> Just (loggedHash l) /= hp) bl) + in echoData entered == mconcat (map (getseen . loggedActivity) sincehp) | otherwise = False where - getseen (ActivitySeen (a, _)) = case activity a of + getseen (ActivitySeen a) = case activity a of Proto s -> seenData s _ -> mempty getseen (ActivityEntered _) = mempty -- cgit v1.2.3