From 362d3a437c16c10d221caeac21e9f685d7ddf3e6 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sat, 22 Apr 2017 11:41:54 -0400
Subject: stream the log

avoid processing it in memory, and allow parse errors at end to not
prevent displaying part of it
---
 Graphviz.hs | 16 +++++++++++-----
 Log.hs      | 11 ++++-------
 Replay.hs   |  5 +++--
 3 files changed, 18 insertions(+), 14 deletions(-)

diff --git a/Graphviz.hs b/Graphviz.hs
index 59f3bf9..96ad92a 100644
--- a/Graphviz.hs
+++ b/Graphviz.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings, FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-}
 
 module Graphviz (graphviz) where
 
@@ -22,7 +22,7 @@ import Data.Text.Encoding.Error
 
 graphviz :: GraphvizOpts -> IO ()
 graphviz opts = do
-	l <- loadLog (graphvizLogFile opts)
+	l <- streamLog (graphvizLogFile opts)
 	let g = genGraph opts l
 	f <- createImage (graphvizLogFile opts) Png g
 	putStrLn ("Generated " ++ f)
@@ -30,13 +30,16 @@ graphviz opts = do
 createImage :: PrintDotRepr dg n => FilePath -> GraphvizOutput -> dg n -> IO FilePath
 createImage f o g = Data.GraphViz.addExtension (runGraphvizCommand Dot g) o f
 
-genGraph :: GraphvizOpts -> [Log] -> G.DotGraph T.Text
+genGraph :: GraphvizOpts -> [Either String Log] -> G.DotGraph T.Text
 genGraph opts ls = digraph (Str "debug-me") $ do
 	nodeAttrs [style filled]
 	forM_ ls $
 		showlog [ xcolor Green ]
   where
-	showlog s l = case (loggedMessage l, loggedHash l) of
+	showlog s (Right l) = showactivity s l
+	showlog _ (Left l) = node (display l) [xcolor Red, shape DiamondShape]
+
+	showactivity s l = case (loggedMessage l, loggedHash l) of
 		(User (ActivityMessage a), Just h) -> do
 			node (display h) $ s ++
 				[ textLabel $ prettyDisplay $ activity a
@@ -64,7 +67,7 @@ genGraph opts ls = digraph (Str "debug-me") $ do
 			[ textLabel "Rejected"
 			, shape BoxShape
 			]
-		showlog rejstyle $ Log
+		showactivity rejstyle $ Log
 			{ loggedMessage = Developer (ActivityMessage ar)
 			, loggedHash = Just hr
 			, loggedTimestamp = loggedTimestamp l
@@ -102,6 +105,9 @@ instance Display T.Text where
 		leadingws (c:_) = isSpace c
 		leadingws _ = False
 
+instance Display String where
+	display = display . T.pack
+
 instance Display Val where
 	display (Val b) = T.decodeUtf8With lenientDecode (L.fromStrict b)
 
diff --git a/Log.hs b/Log.hs
index 50c506d..6c45074 100644
--- a/Log.hs
+++ b/Log.hs
@@ -87,10 +87,7 @@ parseLog = map eitherDecode'
 	. filter (not . L.null)
 	. L.split (fromIntegral (ord '\n'))
 
--- | Throws exception on unparsable log.
-loadLog :: FilePath -> IO [Log]
-loadLog f = do
-	parsed <- parseLog <$> L.readFile f
-	case lefts parsed of
-		[] -> return (rights parsed)
-		errs -> error $ unlines errs
+-- | Streams a log without loading it all into memory.
+-- When lines cannot be parsed, they will be Left.
+streamLog :: FilePath -> IO [Either String Log]
+streamLog f = parseLog <$> L.readFile f
diff --git a/Replay.hs b/Replay.hs
index b13012d..9612d5b 100644
--- a/Replay.hs
+++ b/Replay.hs
@@ -10,10 +10,10 @@ import System.IO
 import Control.Concurrent.Thread.Delay
 
 replay :: ReplayOpts -> IO ()
-replay opts = go Nothing =<< loadLog (replayLogFile opts)
+replay opts = go Nothing =<< streamLog (replayLogFile opts)
   where
 	go _ [] = sessionDone
-	go prevts (l:ls) = do
+	go prevts (Right l:ls) = do
 		case prevts of
 			Nothing -> return ()
 			Just t ->
@@ -28,3 +28,4 @@ replay opts = go Nothing =<< loadLog (replayLogFile opts)
 			User (ControlMessage _) -> return ()
 			Developer _ -> return ()
 		go (Just $ loggedTimestamp l) ls
+	go _ (Left l:_) = error $ "Failed to parse a line of the log: " ++ l
-- 
cgit v1.2.3