/
Composed.hs
174 lines (156 loc) · 6.54 KB
/
Composed.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
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- HLINT ignore "Monad law, left identity" -}
module Cardano.Logging.Tracer.Composed (
traceTracerInfo
, mkCardanoTracer
, mkCardanoTracer'
, mkMetricsTracer
) where
import Cardano.Logging.Configuration
import Cardano.Logging.Formatter
import Cardano.Logging.Trace
import Cardano.Logging.TraceDispatcherMessage
import Cardano.Logging.Types
import qualified Control.Tracer as T
import Control.Monad (when)
import Data.IORef
import qualified Data.List as L
import Data.Maybe (fromMaybe, isNothing)
import qualified Data.Set as Set
import Data.Text hiding (map)
-- | Construct a tracer according to the requirements for cardano node.
-- The tracer gets a 'name', which is appended to its namespace.
-- The tracer has to be an instance of LogFormat-ting for the display of
-- messages and an instance of MetaTrace for meta information such as
-- severity, privacy, details and backends'.
-- The tracer gets the backends': 'trStdout', 'trForward' and 'mbTrEkg'
-- as arguments.
-- The returned tracer needs to be configured with a configuration.
mkCardanoTracer :: forall evt.
( LogFormatting evt
, MetaTrace evt)
=> Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe (Trace IO FormattedMessage)
-> [Text]
-> IO (Trace IO evt)
mkCardanoTracer trStdout trForward mbTrEkg tracerPrefix =
mkCardanoTracer' trStdout trForward mbTrEkg tracerPrefix noHook
where
noHook :: Trace IO evt -> IO (Trace IO evt)
noHook = pure
-- | Adds the possibility to add special tracers via the hook function
mkCardanoTracer' :: forall evt evt1.
( LogFormatting evt1
, MetaTrace evt1)
=> Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe (Trace IO FormattedMessage)
-> [Text]
-> (Trace IO evt1 -> IO (Trace IO evt))
-> IO (Trace IO evt)
mkCardanoTracer' trStdout trForward mbTrEkg tracerPrefix hook = do
internalTr <- fmap (appendPrefixNames ["Reflection"])
(withBackendsFromConfig (backendsAndFormat trStdout trForward))
-- handle the messages
messageTrace <- withBackendsFromConfig (backendsAndFormat trStdout trForward)
>>= withLimitersFromConfig internalTr
>>= traceNamespaceErrors internalTr
>>= addContextAndFilter
>>= maybeSilent isSilentTracer tracerPrefix False
>>= hook
-- handle the metrics
metricsTrace <- (maybeSilent hasNoMetrics tracerPrefix True
. filterTrace (\ (_, v) -> not (Prelude.null (asMetrics v))))
(case mbTrEkg of
Nothing -> Trace T.nullTracer
Just ekgTrace -> metricsFormatter "Cardano" ekgTrace)
>>= hook
pure (messageTrace <> metricsTrace)
where
addContextAndFilter :: Trace IO evt1 -> IO (Trace IO evt1)
addContextAndFilter tr = do
tr' <- withDetailsFromConfig tr
tr'' <- filterSeverityFromConfig tr'
pure $ withDetails
$ withSeverity
$ withPrivacy
$ withInnerNames
$ appendPrefixNames tracerPrefix tr''
traceNamespaceErrors ::
Trace IO TraceDispatcherMessage
-> Trace IO evt1
-> IO (Trace IO evt1)
traceNamespaceErrors internalTr (Trace tr) = do
pure $ Trace (T.arrow (T.emit
(\case
(lc, Right e) -> process lc (Right e)
(lc, Left e) -> T.traceWith tr (lc, Left e))))
where
process :: LoggingContext -> Either TraceControl evt1 -> IO ()
process lc cont = do
when (isNothing (lcPrivacy lc)) $
traceWith
internalTr
(UnknownNamespace (lcNSPrefix lc) (lcNSInner lc) UKFPrivacy)
when (isNothing (lcSeverity lc)) $
traceWith
internalTr
(UnknownNamespace (lcNSPrefix lc) (lcNSInner lc) UKFSeverity)
when (isNothing (lcDetails lc)) $
traceWith
internalTr
(UnknownNamespace (lcNSPrefix lc) (lcNSInner lc) UKFDetails)
T.traceWith tr (lc, cont)
backendsAndFormat ::
LogFormatting a
=> Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe [BackendConfig]
-> Trace IO x
-> IO (Trace IO a)
backendsAndFormat trStdout trForward mbBackends _ =
let backends' = fromMaybe
[EKGBackend, Forwarder, Stdout HumanFormatColoured]
mbBackends
in do
let mbForwardTrace = if Forwarder `L.elem` backends'
then Just $ filterTraceByPrivacy (Just Public)
(forwardFormatter' Nothing trForward)
else Nothing
mbStdoutTrace | Stdout HumanFormatColoured `L.elem` backends'
= Just (humanFormatter' True Nothing trStdout)
| Stdout HumanFormatUncoloured `L.elem` backends'
= Just (humanFormatter' False Nothing trStdout)
| Stdout MachineFormat `L.elem` backends'
= Just (machineFormatter' Nothing trStdout)
| otherwise = Nothing
case mbForwardTrace <> mbStdoutTrace of
Nothing -> pure $ Trace T.nullTracer
Just tr -> preFormatted backends' tr
traceTracerInfo ::
Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> ConfigReflection
-> IO ()
traceTracerInfo trStdout trForward (ConfigReflection silentRef metricsRef) = do
internalTr <- backendsAndFormat
trStdout
trForward
(Just [Forwarder, Stdout MachineFormat])
(Trace T.nullTracer)
silentSet <- readIORef silentRef
metricSet <- readIORef metricsRef
let silentList = map (intercalate (singleton '.')) (Set.toList silentSet)
let metricsList = map (intercalate (singleton '.')) (Set.toList metricSet)
traceWith (withInnerNames (appendPrefixNames ["Reflection"] internalTr))
(TracerInfo silentList metricsList)
writeIORef silentRef Set.empty
writeIORef metricsRef Set.empty
-- A basic ttracer just for metrics
mkMetricsTracer :: Maybe (Trace IO FormattedMessage) -> Trace IO FormattedMessage
mkMetricsTracer mbTrEkg = case mbTrEkg of
Nothing -> Trace T.nullTracer
Just ekgTrace -> ekgTrace