refactor out Log

1 files changed, 79 insertions, 0 deletions

diff --git a/Log.hs b/Log.hs
new file mode 100644
index 0000000..90f1b53
--- /dev/null
+++ b/Log.hs
@@ -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