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
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall -Werror #-}
{-# OPTIONS_GHC -Wno-missing-fields #-}
-- | A simple logger that reads `LogEntry` from a `TBChan` and dumps JSON-formatted
-- strings to `stdout`.
module Minilang.Log
( -- * Types
LoggerEnv,
-- * Constructor & Destructor
newLog,
stopLogger,
fakeLogger,
-- * Logging functions
logInfo,
logError,
withLog,
)
where
import Control.Concurrent.Async (Async, async, cancel)
import Control.Concurrent.STM (TChan, atomically, newTChan, readTChan, writeTChan)
import Control.Monad (forever)
import Control.Monad.Trans (MonadIO (..))
import Data.Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Text (Text)
import Data.Time.Clock
( UTCTime,
diffUTCTime,
getCurrentTime,
)
import System.IO (Handle, stdout, hFlush)
-- | Environment to control a logger thread.
data LoggerEnv m = LoggerEnv
{ logger :: Maybe Logger,
loggerId :: Text,
logInfo :: forall a. (ToJSON a) => a -> m (),
logError :: forall a. (ToJSON a) => a -> m (),
withLog :: forall a b. (ToJSON a) => a -> m b -> m b,
stopLogger :: m ()
}
type Logger = TChan BS.ByteString
fakeLogger :: (MonadIO m) => LoggerEnv m
fakeLogger = LoggerEnv Nothing "foo" (const $ pure ()) (const $ pure ()) (const id) (pure ())
-- | Starts an asynchronous log-processing thread and returns an initialised `LoggerEnv`.
newLog :: (MonadIO m) => Text -> m (LoggerEnv m)
newLog loggerId = liftIO $ do
chan <- liftIO $ atomically newTChan
loggerThread <- async $ runLog chan stdout
return $
LoggerEnv
{ logger = Just chan,
logInfo = logEvent' chan loggerId,
logError = logError' chan loggerId,
withLog = withLog' chan loggerId,
stopLogger = stopLogger' loggerThread,
loggerId
}
runLog :: TChan BS.ByteString -> Handle -> IO a
runLog chan hdl = forever $ do
toLog <- atomically $ readTChan chan
BS.hPutStr hdl . (<> "\n") $ toLog
hFlush hdl
stopLogger' :: (MonadIO m) => Async () -> m ()
stopLogger' = liftIO . cancel
logEvent' :: (ToJSON a, MonadIO m) => Logger -> Text -> a -> m ()
logEvent' chan logId message = do
ts <- liftIO getCurrentTime
liftIO $
atomically $
writeTChan chan $
LBS.toStrict $
encode $
object
[ "timestamp" .= ts,
"logger" .= logId,
"message" .= message
]
withLog' :: (ToJSON a, MonadIO m) => Logger -> Text -> a -> m b -> m b
withLog' chan logId message act = do
startTime <- liftIO getCurrentTime
logStart chan logId startTime message
b <- act
endTime <- liftIO getCurrentTime
logEnd chan logId startTime endTime message
pure b
logStart :: (ToJSON a, MonadIO m) => Logger -> Text -> UTCTime -> a -> m ()
logStart chan logId ts command =
liftIO $
atomically $
writeTChan chan $
LBS.toStrict $
encode $
object
[ "timestamp" .= ts,
"logger" .= logId,
"message" .= command
]
logEnd :: (ToJSON a, MonadIO m) => Logger -> Text -> UTCTime -> UTCTime -> a -> m ()
logEnd chan logId ts en outcome =
liftIO $
atomically $
writeTChan chan $
LBS.toStrict $
encode $
object
[ "timestamp" .= en,
"durationMs" .= (diffUTCTime en ts * 1000),
"logger" .= logId,
"message" .= outcome
]
logError' :: (ToJSON a, MonadIO m) => Logger -> Text -> a -> m ()
logError' chan logId err = liftIO $ do
ts <- liftIO getCurrentTime
liftIO $
atomically $
writeTChan chan $
LBS.toStrict $
encode $
object
[ "timestamp" .= ts,
"logger" .= logId,
"error" .= err
]
|
