diff options
| -rw-r--r-- | CmdLine.hs | 18 | ||||
| -rw-r--r-- | Graphviz.hs | 24 | ||||
| -rw-r--r-- | Log.hs | 79 | ||||
| -rw-r--r-- | Replay.hs | 12 | ||||
| -rw-r--r-- | Types.hs | 28 | ||||
| -rw-r--r-- | debug-me.cabal | 2 | ||||
| -rw-r--r-- | debug-me.hs | 26 |
7 files changed, 118 insertions, 71 deletions
@@ -9,14 +9,24 @@ data CmdLine = CmdLine data Mode = Test | Graphviz GraphvizOpts + | Replay ReplayOpts data GraphvizOpts = GraphvizOpts { graphvizLogFile :: FilePath , graphvizShowHashes :: Bool } +data ReplayOpts = ReplayOpts + { replayLogFile :: FilePath + } + parseCmdLine :: Parser CmdLine -parseCmdLine = CmdLine <$> ((Graphviz <$> parsegraphviz) <|> pure Test) +parseCmdLine = CmdLine <$> parseMode + +parseMode :: Parser Mode +parseMode = (Graphviz <$> parsegraphviz) + <|> (Replay <$> parsereplay) + <|> pure Test where parsegraphviz = GraphvizOpts <$> option str @@ -28,6 +38,12 @@ parseCmdLine = CmdLine <$> ((Graphviz <$> parsegraphviz) <|> pure Test) ( long "show-hashes" <> help "display hashes in graphviz" ) + parsereplay = ReplayOpts + <$> option str + ( long "replay" + <> metavar "logfile" + <> help "replay log file" + ) getCmdLine :: IO CmdLine getCmdLine = execParser opts diff --git a/Graphviz.hs b/Graphviz.hs index c6ce8a9..b85821c 100644 --- a/Graphviz.hs +++ b/Graphviz.hs @@ -5,11 +5,9 @@ module Graphviz (graphviz) where import Types import Hash import CmdLine +import Log -import Data.Aeson import Data.Char -import Data.Word -import Data.Either import Data.Monoid import Data.GraphViz import Data.GraphViz.Attributes.Complete @@ -24,22 +22,10 @@ import Data.Text.Encoding.Error graphviz :: GraphvizOpts -> IO () graphviz opts = do - parsed <- parseLog <$> L.readFile (graphvizLogFile opts) - case lefts parsed of - [] -> do - let g = genGraph opts (rights parsed) - f <- createImage (graphvizLogFile opts) Png g - putStrLn ("Generated " ++ f) - errs -> error $ unlines errs - -parseLog :: L.ByteString -> [Either String ActivityLog] -parseLog = map eitherDecode' - . filter (not . L.null) - . L.split nl - - -nl :: Word8 -nl = fromIntegral (ord '\n') + l <- loadLog (graphvizLogFile opts) + let g = genGraph opts l + f <- createImage (graphvizLogFile opts) Png g + putStrLn ("Generated " ++ f) createImage :: PrintDotRepr dg n => FilePath -> GraphvizOutput -> dg n -> IO FilePath createImage f o g = Data.GraphViz.addExtension (runGraphvizCommand Dot g) o f @@ -0,0 +1,79 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Log where + +import Types +import Hash + +import GHC.Generics (Generic) +import Data.Aeson +import Data.Char +import Data.Either +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. +-- +-- 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 + , loggedTimestamp :: Timestamp + } + deriving (Show, Generic) + +instance ToJSON (ActivityLog) +instance FromJSON (ActivityLog) + +data SomeActivity + = ActivitySeen (Activity Seen) + | ActivityEntered (Activity Entered) + deriving (Show, Generic) + +instance ToJSON SomeActivity where + toJSON = genericToJSON sumOptions + toEncoding = genericToEncoding sumOptions +instance FromJSON SomeActivity 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 + , loggedTimestamp = now + } + +type Timestamp = POSIXTime + +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 <- mkActivityLog a <$> getPOSIXTime + L.hPut h (encode l) + hPutStr h "\n" + hFlush h + +parseLog :: L.ByteString -> [Either String ActivityLog] +parseLog = map eitherDecode' + . filter (not . L.null) + . L.split (fromIntegral (ord '\n')) + +-- | Throws exception on unparsable log. +loadLog :: FilePath -> IO [ActivityLog] +loadLog f = do + parsed <- parseLog <$> L.readFile f + case lefts parsed of + [] -> return (rights parsed) + errs -> error $ unlines errs diff --git a/Replay.hs b/Replay.hs new file mode 100644 index 0000000..599ca77 --- /dev/null +++ b/Replay.hs @@ -0,0 +1,12 @@ +module Replay where + +import Types +import Log +import CmdLine + +replay :: ReplayOpts -> IO () +replay opts = go =<< loadLog (replayLogFile opts) + where + go [] = return () + go (l:ls) = do + go ls @@ -16,7 +16,6 @@ import Val import GHC.Generics (Generic) import Data.Aeson import qualified Data.Aeson.Types as Aeson -import Data.Time.Clock.POSIX -- | Things that the developer sees. data Seen = Seen @@ -52,25 +51,6 @@ data Activity a = Activity } deriving (Show, Generic) -data SomeActivity - = ActivitySeen (Activity Seen) - | ActivityEntered (Activity Entered) - deriving (Show, Generic) - --- | A log of Activity both Entered and Seen, which can be recorded to --- prove what happened in a debug-me session. --- --- 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) - -type Timestamp = POSIXTime - newtype Signature = Signature Val deriving (Show, Generic) @@ -93,8 +73,6 @@ instance ToJSON (Activity Seen) instance FromJSON (Activity Seen) instance ToJSON (Activity Entered) instance FromJSON (Activity Entered) -instance ToJSON (ActivityLog) -instance FromJSON (ActivityLog) instance ToJSON Signature instance FromJSON Signature instance ToJSON Hash @@ -117,9 +95,3 @@ instance ToJSON (Proto Entered) where toEncoding = genericToEncoding sumOptions instance FromJSON (Proto Entered) where parseJSON = genericParseJSON sumOptions - -instance ToJSON SomeActivity where - toJSON = genericToJSON sumOptions - toEncoding = genericToEncoding sumOptions -instance FromJSON SomeActivity where - parseJSON = genericParseJSON sumOptions diff --git a/debug-me.cabal b/debug-me.cabal index 54f1bc9..37d8357 100644 --- a/debug-me.cabal +++ b/debug-me.cabal @@ -41,7 +41,9 @@ Executable debug-me CmdLine Graphviz Hash + Log Pty + Replay Types Val diff --git a/debug-me.hs b/debug-me.hs index 058e23a..0b51878 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -6,7 +6,9 @@ import Types import Hash import Pty import CmdLine +import Log import Graphviz +import Replay import Control.Concurrent import Control.Concurrent.Async @@ -15,11 +17,9 @@ import System.IO import System.Process import System.Exit import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L import Data.List import Data.List.NonEmpty (NonEmpty(..), toList) import Data.Monoid -import Data.Aeson import Data.Time.Clock.POSIX main :: IO () @@ -28,6 +28,7 @@ main = do case mode c of Test -> test Graphviz g -> graphviz g + Replay r -> replay r test :: IO () test = do @@ -214,27 +215,6 @@ user startmsg p ichan ochan = withLogger "debug-me.log" $ \logger -> do data Backlog = Backlog (NonEmpty ActivityLog) deriving (Show) -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 <- 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 |