From 74003096f8018827dde28b5746a19c1e325bc68f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 14 Apr 2017 19:39:23 -0400 Subject: add --graphviz mode This commit was sponsored by Shane-o on Patreon. --- CmdLine.hs | 26 +++++++++++++++++++ Graphviz.hs | 79 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Hash.hs | 6 ++--- Types.hs | 21 ++++++++++------ debug-me.cabal | 3 +++ debug-me.hs | 27 +++++++++++++------- 6 files changed, 142 insertions(+), 20 deletions(-) create mode 100644 CmdLine.hs create mode 100644 Graphviz.hs diff --git a/CmdLine.hs b/CmdLine.hs new file mode 100644 index 0000000..667693e --- /dev/null +++ b/CmdLine.hs @@ -0,0 +1,26 @@ +module CmdLine where + +import Options.Applicative + +data CmdLine = CmdLine + { mode :: Mode + } + +data Mode = Test | Graphviz FilePath + +parseCmdLine :: Parser CmdLine +parseCmdLine = CmdLine <$> (parsegraphviz <|> pure Test) + where + parsegraphviz = Graphviz <$> option str + ( long "graphviz" + <> metavar "logfile" + <> help "visualize log file with graphviz" + ) + +getCmdLine :: IO CmdLine +getCmdLine = execParser opts + where + opts = info (helper <*> parseCmdLine) + ( fullDesc + <> header "debug-me - provable remote debugging sessions" + ) diff --git a/Graphviz.hs b/Graphviz.hs new file mode 100644 index 0000000..81ff71a --- /dev/null +++ b/Graphviz.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} + +module Graphviz (graphviz) where + +import Types + +import Data.Aeson +import Data.Char +import Data.Word +import Data.Either +import Data.Monoid +import Data.GraphViz +import Data.GraphViz.Attributes.Complete +import Data.GraphViz.Types.Generalised as G +import Data.GraphViz.Types.Monadic +import Control.Monad +import qualified Data.ByteString.Lazy as L +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as T +import Data.Text.Encoding.Error + +graphviz :: FilePath -> IO () +graphviz logfile = do + parsed <- parseLog <$> L.readFile logfile + case lefts parsed of + [] -> do + let g = genGraph (rights parsed) + f <- createImage logfile 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') + +createImage :: PrintDotRepr dg n => FilePath -> GraphvizOutput -> dg n -> IO FilePath +createImage f o g = Data.GraphViz.addExtension (runGraphvizCommand Dot g) o f + +genGraph :: [ActivityLog] -> G.DotGraph T.Text +genGraph ls = digraph (Str "debug-me") $ do + nodeAttrs [style filled] + forM_ ls $ \l -> case l of + ActivitySeen { activitySeen = (a, h) } -> do + node (display h) + [ textLabel $ display $ seenData $ activity a + , shape Circle + , xcolor Green + ] + chain a h + ActivityEntered { activityEntered = (a, h) } -> do + node (display h) + [ textLabel $ display $ enteredData $ activity a + , shape Square + , if activityEnteredAccepted l + then xcolor Green + else xcolor Red + ] + chain a h + where + chain a h = case prevActivity a of + Nothing -> return () + Just p -> display p --> display h + +xcolor :: X11Color -> Attribute +xcolor c = Color [toWC $ X11Color c] + +class Display t where + display :: t -> T.Text + +instance Display Val where + display (Val b) = T.decodeUtf8With lenientDecode (L.fromStrict b) + +instance Display Hash where + display (Hash m h) = T.pack (show m) <> display h diff --git a/Hash.hs b/Hash.hs index f2b8d75..53be540 100644 --- a/Hash.hs +++ b/Hash.hs @@ -9,11 +9,11 @@ import qualified Data.ByteString.Char8 as C8 import qualified Crypto.Hash as H class Hashable a where - hash :: a -> HashPointer + hash :: a -> Hash instance Hashable B.ByteString where -- Encodes the SHA256 using base16 format - hash = HashPointer SHA256 . Val . C8.pack . show . sha256 + hash = Hash SHA256 . Val . C8.pack . show . sha256 instance Hashable Val where hash (Val v) = hash v @@ -22,7 +22,7 @@ sha256 :: B.ByteString -> H.Digest H.SHA256 sha256 = H.hash -- | Hash the concacenation of the hashes. -instance Hashable [HashPointer] where +instance Hashable [Hash] where hash = hash . B.concat . map (val . hashValue) instance Hashable a => Hashable (Activity a) where diff --git a/Types.hs b/Types.hs index a439c7c..7837f71 100644 --- a/Types.hs +++ b/Types.hs @@ -1,5 +1,11 @@ {-# LANGUAGE DeriveGeneric, FlexibleInstances #-} +{- | Main types for debug-me + - + - Note that changing types in ways that change the JSON serialization + - changes debug-me's wire format. + -} + module Types ( module Types, Val(..) @@ -37,7 +43,7 @@ instance FromJSON Entered -- The Signature is over both the data in the activity, and its pointer. data Activity a = Activity { activity :: a - , prevActivity :: (Maybe HashPointer) + , prevActivity :: (Maybe Hash) , signature :: Signature } deriving (Show, Generic) @@ -50,11 +56,11 @@ instance FromJSON (Activity Entered) -- | A log of Activity both Entered and Seen. data ActivityLog = ActivitySeen - { activitySeen :: Activity Seen + { activitySeen :: (Activity Seen, Hash) } | ActivityEntered - { activityEntered :: Activity Entered - , activityEnteredAccepted :: Bool + { activityEnteredAccepted :: Bool + , activityEntered :: (Activity Entered, Hash) } deriving (Show, Generic) @@ -67,15 +73,14 @@ newtype Signature = Signature Val instance ToJSON Signature instance FromJSON Signature --- | A hash pointer to something that hashes to this value. -data HashPointer = HashPointer +data Hash = Hash { hashMethod :: HashMethod , hashValue :: Val } deriving (Show, Generic, Eq) -instance ToJSON HashPointer -instance FromJSON HashPointer +instance ToJSON Hash +instance FromJSON Hash -- | We use SHA256. (SHA3 is included to future proof, and because it -- improves the generated JSON.) diff --git a/debug-me.cabal b/debug-me.cabal index 0fee6ad..0535172 100644 --- a/debug-me.cabal +++ b/debug-me.cabal @@ -35,7 +35,10 @@ Executable debug-me , sandi (>= 0.4) , text (>= 1.2) , optparse-applicative (>= 0.12) + , graphviz (== 2999.18.*) Other-Modules: + CmdLine + Graphviz Hash Pty Types diff --git a/debug-me.hs b/debug-me.hs index 162ca1b..075ca17 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -5,6 +5,8 @@ module Main where import Types import Hash import Pty +import CmdLine +import Graphviz import Control.Concurrent import Control.Concurrent.Async @@ -20,6 +22,13 @@ import Data.Aeson main :: IO () main = do + c <- getCmdLine + case mode c of + Test -> test + Graphviz logfile -> graphviz logfile + +test :: IO () +test = do exitstatus <- go ">>> debug-me session starting" putStrLn "" putStrLn ">>> debug-me session is done" @@ -53,7 +62,7 @@ developer ichan ochan = do return () data DeveloperState = DeveloperState - { lastSeen :: HashPointer + { lastSeen :: Hash , sentSince :: B.ByteString } deriving (Show) @@ -112,7 +121,7 @@ sendTtyOutput ochan devstate = go 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 (Seen (Val (startmsg <> "\r\n"))) Nothing dummySignature - logger (ActivitySeen startact) + logger $ ActivitySeen (startact, hash startact) atomically $ writeTChan ochan startact backlog <- newTVarIO $ Backlog ((hash startact, startact) :| []) _ <- sendPtyOutput p ochan backlog logger @@ -120,7 +129,7 @@ user startmsg p ichan ochan = withLogger "debug-me.log" $ \logger -> do return () -- | Log of recent output, with the most recent output first. -data Backlog = Backlog (NonEmpty (HashPointer, Activity Seen)) +data Backlog = Backlog (NonEmpty (Hash, Activity Seen)) deriving (Show) type Logger = ActivityLog -> IO () @@ -129,8 +138,8 @@ withLogger :: FilePath -> (Logger -> IO a) -> IO a withLogger logfile a = withFile logfile WriteMode (a . mkLogger) mkLogger :: Handle -> Logger -mkLogger h l = do - L.hPut h (encode l) +mkLogger h a = do + L.hPut h (encode a) hPutStr h "\n" hFlush h @@ -147,7 +156,7 @@ sendPtyOutput p ochan backlog logger = go writeTChan ochan act writeTVar backlog (Backlog ((hash act, act) :| toList bl)) return act - logger (ActivitySeen act) + logger $ ActivitySeen (act, hash act) go -- | Read things to be entered from the TChan, verify if they're legal, @@ -171,11 +180,11 @@ sendPtyInput ichan p backlog logger = go return (Left (newact, bl')) case v of Right entered -> do - logger (ActivityEntered entered True) + logger $ ActivityEntered True (entered, hash entered) writePty p (val (enteredData (activity entered))) go Left (illegalentered, _bl) -> do - logger (ActivityEntered illegalentered False) + logger $ ActivityEntered False (illegalentered, hash illegalentered) -- print bl go @@ -199,7 +208,7 @@ truncateBacklog (Backlog (b :| l)) (Activity _ hp _) -- the current state of the system before manipulating it. -- -- To support typeahead on slow links, some echoData may be provided --- in the Entered activity. If the HashPointer in the activity points +-- in the Entered activity. If the prevActivity points -- to an older Seen activity, then the echoData must match the -- concatenation of all activities after that one, up to the most recent -- Seen activity. -- cgit v1.2.3