blob: ec7078eb3bb035e035de4c7546cf4b28ef4d1be7 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
{-# LANGUAGE DeriveGeneric #-}
module Log where
import Types
import Hash
import Memory
import Serialization
import Data.Char
import Data.Either
import Data.Time.Clock.POSIX
import qualified Data.ByteString.Lazy as L
import System.IO
-- | One item in a log of 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 Log = Log
{ loggedMessage :: LogMessage
, loggedHash :: Maybe Hash
, loggedTimestamp :: Timestamp
}
deriving (Show, Generic)
instance DataSize Log where
dataSize l = dataSize (loggedMessage l)
+ maybe 0 dataSize (loggedHash l)
+ 2
instance ToJSON Log
instance FromJSON Log
data LogMessage
= User (Message Seen)
| Developer (Message Entered)
deriving (Show, Generic)
instance DataSize LogMessage where
dataSize (User a) = dataSize a
dataSize (Developer a) = dataSize a
instance ToJSON LogMessage where
toJSON = genericToJSON sumOptions
toEncoding = genericToEncoding sumOptions
instance FromJSON LogMessage where
parseJSON = genericParseJSON sumOptions
mkLog :: LogMessage -> POSIXTime -> Log
mkLog m now = Log
{ loggedMessage = m
, loggedHash = case m of
User (ActivityMessage a) -> Just (hash a)
Developer (ActivityMessage a) -> Just (hash a)
User (ControlMessage _) -> Nothing
Developer (ControlMessage _) -> Nothing
, loggedTimestamp = now
}
type Timestamp = POSIXTime
type Logger = LogMessage -> IO ()
withLogger :: FilePath -> (Logger -> IO a) -> IO a
withLogger logfile a = withFile logfile WriteMode (a . mkLogger)
mkLogger :: Handle -> Logger
mkLogger h a = do
l <- mkLog a <$> getPOSIXTime
writeLogHandle l h
writeLogHandle :: Log -> Handle -> IO ()
writeLogHandle l h = do
L.hPut h (encode l)
hPutStr h "\n"
hFlush h
parseLog :: L.ByteString -> [Either String Log]
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
|
