add --graphviz mode

This commit was sponsored by Shane-o on Patreon.

6 files changed, 142 insertions, 20 deletions

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.