summaryrefslogtreecommitdiffhomepage
path: root/Log.hs
blob: 1974b479e411324ae4ff287f22203e2287c90cec (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
94
95
96
97
98
99
100
101
{- Copyright 2017 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE DeriveGeneric #-}

module Log where

import Types
import Hash
import Memory
import JSON
import SessionID
import DotDir

import Data.Char
import Data.Time.Clock.POSIX
import qualified Data.ByteString.Lazy as L
import System.IO
import System.Directory
import System.FilePath
import Control.Exception

-- | 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 :: AnyMessage
	, 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

mkLog :: AnyMessage -> 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 = AnyMessage -> IO ()

logDir :: IO FilePath
logDir = (</> "log") <$> dotDir

withSessionLogger :: (Maybe FilePath) -> SessionID -> (Logger -> IO a) -> IO a
withSessionLogger subdir sessionid a = bracket setup cleanup go
  where
	setup = do
		basedir <- logDir
		let dir = maybe basedir (basedir </>) subdir
		createDirectoryIfMissing True dir
		return $ sessionLogFile dir sessionid
	cleanup logfile = putStrLn $ "** debug-me session was logged to " ++ logfile
	go logfile = withFile logfile WriteMode (a . mkLogger)

withLogger :: FilePath -> (Logger -> IO a) -> IO a
withLogger logfile a = withFile logfile WriteMode (a . mkLogger)

nullLogger :: Logger
nullLogger _ = return ()

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'))

-- | 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