/
Formatter.hs
244 lines (234 loc) · 8.89 KB
/
Formatter.hs
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
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Cardano.Logging.Formatter (
humanFormatter
, metricsFormatter
, machineFormatter
, forwardFormatter
) where
import qualified Control.Tracer as T
import Data.Aeson ((.=))
import qualified Data.Aeson as AE
import qualified Data.ByteString.Lazy as BS
import Data.List (intersperse)
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack, stripPrefix)
import Data.Text.Encoding (decodeUtf8)
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder as TB
import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)
import Cardano.Logging.Types
import Control.Concurrent (myThreadId)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Network.HostName
-- | Format this trace as metrics
metricsFormatter
:: forall a m . (LogFormatting a, MonadIO m)
=> Text
-> Trace m FormattedMessage
-> m (Trace m a)
metricsFormatter application (Trace tr) = do
let trr = mkTracer
pure $ Trace (T.arrow trr)
where
mkTracer = T.emit $
\ case
(lc, Nothing, v) ->
let metrics = asMetrics v
in T.traceWith tr (lc { lcNamespace = application : lcNamespace lc}
, Nothing
, FormattedMetrics metrics)
(lc, Just ctrl, _v) ->
T.traceWith tr (lc { lcNamespace = application : lcNamespace lc}
, Just ctrl
, FormattedMetrics [])
forwardFormatter
:: forall a m . (LogFormatting a, MonadIO m)
=> Text
-> Trace m FormattedMessage
-> m (Trace m a)
forwardFormatter application (Trace tr) = do
hn <- liftIO getHostName
let trr = mkTracer hn
pure $ Trace (T.arrow trr)
where
mkTracer hn = T.emit $
\ case
(lc, Nothing, v) -> do
thid <- liftIO myThreadId
time <- liftIO getCurrentTime
let fh = forHuman v
details = case lcDetails lc of
Nothing -> DRegular
Just dtl -> dtl
fm = forMachine details v
nlc = lc { lcNamespace = application : lcNamespace lc}
to = TraceObject {
toHuman = if fh == "" then Nothing else Just fh
, toMachine = if fm == mempty then Nothing else
Just $ decodeUtf8 (BS.toStrict (AE.encode fm))
, toNamespace = lcNamespace nlc
, toSeverity = case lcSeverity lc of
Nothing -> Info
Just s -> s
, toDetails = case lcDetails lc of
Nothing -> DRegular
Just d -> d
, toTimestamp = time
, toHostname = hn
, toThreadId = (pack . show) thid
}
T.traceWith tr ( nlc
, Nothing
, FormattedForwarder to)
(lc, Just ctrl, _v) -> do
thid <- liftIO myThreadId
time <- liftIO getCurrentTime
let nlc = lc { lcNamespace = application : lcNamespace lc}
to = TraceObject {
toHuman = Nothing
, toMachine = Nothing
, toNamespace = lcNamespace nlc
, toSeverity = case lcSeverity lc of
Nothing -> Info
Just s -> s
, toDetails = case lcDetails lc of
Nothing -> DRegular
Just d -> d
, toTimestamp = time
, toHostname = hn
, toThreadId = (pack . show) thid
}
T.traceWith tr ( nlc
, Just ctrl
, FormattedForwarder to)
-- | Format this trace for human readability
-- The boolean value tells, if this representation is for the console and should be colored
-- The text argument gives the application name which is prepended to the namespace
humanFormatter
:: forall a m . (LogFormatting a, MonadIO m)
=> Bool
-> Text
-> Trace m FormattedMessage
-> m (Trace m a)
humanFormatter withColor application (Trace tr) = do
hn <- liftIO getHostName
let trr = mkTracer hn
pure $ Trace (T.arrow trr)
where
mkTracer hn = T.emit $
\ case
(lc, Nothing, v) -> do
let fh = forHuman v
text <- liftIO $ formatContextHuman withColor hn application lc fh
T.traceWith tr (lc { lcNamespace = application : lcNamespace lc}
, Nothing
, FormattedHuman text)
(lc, Just ctrl, _v) -> do
T.traceWith tr (lc { lcNamespace = application : lcNamespace lc}
, Just ctrl
, FormattedHuman "")
formatContextHuman ::
Bool
-> String
-> Text
-> LoggingContext
-> Text
-> IO Text
formatContextHuman withColor hostname application LoggingContext {..} txt = do
thid <- myThreadId
time <- getCurrentTime
let severity = fromMaybe Info lcSeverity
tid = fromMaybe ((pack . show) thid)
((stripPrefix "ThreadId " . pack . show) thid)
ts = fromString $ formatTime defaultTimeLocale "%F %H:%M:%S%4Q" time
ns = colorBySeverity
withColor
severity
$ fromString hostname
<> singleton ':'
<> mconcat (intersperse (singleton '.')
(map fromText (application : lcNamespace)))
tadd = fromText " ("
<> fromString (show severity)
<> singleton ','
<> fromText tid
<> fromText ") "
pure $ toStrict
$ toLazyText
$ squareBrackets ts
<> singleton ' '
<> squareBrackets ns
<> tadd
<> fromText txt
where
squareBrackets :: Builder -> Builder
squareBrackets b = singleton '[' <> b <> singleton ']'
-- | Format this trace for machine readability
-- The detail level give a hint to the formatter
-- The text argument gives the application name which is prepended to the namespace
machineFormatter
:: forall a m . (LogFormatting a, MonadIO m)
=> Text
-> Trace m FormattedMessage
-> m (Trace m a)
machineFormatter application (Trace tr) = do
hn <- liftIO getHostName
let trr = mkTracer hn
pure $ Trace (T.arrow trr)
where
mkTracer hn = T.emit $
\case
(lc, Nothing, v) -> do
let detailLevel = case lcDetails lc of
Nothing -> DRegular
Just dl -> dl
obj <- liftIO $ formatContextMachine hn application lc (forMachine detailLevel v)
T.traceWith tr (lc { lcNamespace = application : lcNamespace lc}
, Nothing
, FormattedMachine (decodeUtf8 (BS.toStrict (AE.encode obj))))
(lc, Just c, _v) -> do
T.traceWith tr (lc { lcNamespace = application : lcNamespace lc}
, Just c
, FormattedMachine "")
formatContextMachine ::
String
-> Text
-> LoggingContext
-> AE.Object
-> IO AE.Value
formatContextMachine hostname application LoggingContext {..} obj = do
thid <- myThreadId
time <- getCurrentTime
let severity = (pack . show) (fromMaybe Info lcSeverity)
tid = fromMaybe ((pack . show) thid)
((stripPrefix "ThreadId " . pack . show) thid)
ns = application : lcNamespace
ts = pack $ formatTime defaultTimeLocale "%F %H:%M:%S%4Q" time
pure $ AE.object [ "at" .= ts
, "ns" .= ns
, "sev" .= severity
, "thread" .= tid
, "host" .= hostname
, "message" .= obj]
-- | Color a text message based on `Severity`. `Error` and more severe errors
-- are colored red, `Warning` is colored yellow, and all other messages are
-- rendered in the default color.
colorBySeverity :: Bool -> SeverityS -> Builder -> Builder
colorBySeverity withColor severity msg = case severity of
Emergency -> red msg
Alert -> red msg
Critical -> red msg
Error -> red msg
Warning -> yellow msg
_ -> msg
where
red = colorize "31"
yellow = colorize "33"
colorize c s
| withColor = "\ESC["<> c <> "m" <> s <> "\ESC[0m"
| otherwise = s