Skip to content
This repository was archived by the owner on Aug 18, 2020. It is now read-only.

Commit 3251c8c

Browse files
CodiePPCodiePP
committed
[CBR-213] introduce 'Trace.Named'
Signed-off-by: Alexander Diemand <[email protected]>
1 parent 74340ea commit 3251c8c

File tree

5 files changed

+565
-3
lines changed

5 files changed

+565
-3
lines changed

Diff for: ‎util/Pos/Util/Trace.hs

+51-1
Original file line numberDiff line numberDiff line change
@@ -1,28 +1,55 @@
1+
{-# LANGUAGE RankNTypes #-}
12

23
module Pos.Util.Trace
34
( Trace (..)
5+
, TraceIO
6+
, natTrace
47
, trace
58
, traceWith
69
, noTrace
710
, stdoutTrace
811
-- TODO put wlog tracing into its own module.
912
, wlogTrace
1013
, Wlog.Severity (..)
14+
-- * trace setup
15+
, setupLogging
16+
, logTrace
17+
-- * log messages
18+
, logDebug
19+
, logInfo
20+
, logWarning
21+
, logNotice
22+
, logError
1123
) where
1224

1325
import Data.Functor.Contravariant (Contravariant (..), Op (..))
1426
import qualified Data.Text.IO as TIO
15-
import qualified System.Wlog as Wlog
27+
import qualified Pos.Util.Log as Log
28+
import qualified Pos.Util.Wlog as Wlog
1629
import Universum hiding (trace)
1730

1831
-- | Abstracts logging.
1932
newtype Trace m s = Trace
2033
{ runTrace :: Op (m ()) s
2134
}
2235

36+
type TraceIO = Trace IO (Log.Severity, Text)
37+
2338
instance Contravariant (Trace m) where
2439
contramap f = Trace . contramap f . runTrace
2540

41+
natTrace :: (forall x . m x -> n x) -> Trace m s -> Trace n s
42+
natTrace nat (Trace (Op tr)) = Trace $ Op $ nat . tr
43+
44+
-- | setup logging and return a Trace
45+
setupLogging :: MonadIO m
46+
=> Log.LoggerConfig
47+
-> Log.LoggerName
48+
-> IO (Trace m (Log.Severity, Text))
49+
setupLogging lc ln = do
50+
lh <- Log.setupLogging lc
51+
return $ logTrace lh ln
52+
2653
trace :: Trace m s -> s -> m ()
2754
trace = getOp . runTrace
2855

@@ -44,3 +71,26 @@ stdoutTrace = Trace $ Op $ TIO.putStrLn
4471
wlogTrace :: Wlog.LoggerName -> Trace IO (Wlog.Severity, Text)
4572
wlogTrace loggerName = Trace $ Op $ \(severity, txt) ->
4673
Wlog.usingLoggerName loggerName $ Wlog.logMessage severity txt
74+
75+
-- | A 'Trace' that uses logging from @Pos.Util.Log@
76+
logTrace :: MonadIO m
77+
=> Log.LoggingHandler
78+
-> Log.LoggerName
79+
-> Trace m (Log.Severity, Text)
80+
logTrace lh loggerName = Trace $ Op $ \(severity, txt) ->
81+
liftIO $ Log.usingLoggerName lh loggerName $ Log.logMessage severity txt
82+
83+
logDebug :: TraceIO -> Trace IO Text
84+
logDebug = contramap ((,) Log.Debug)
85+
86+
logInfo :: TraceIO -> Trace IO Text
87+
logInfo = contramap ((,) Log.Info)
88+
89+
logWarning :: TraceIO -> Trace IO Text
90+
logWarning = contramap ((,) Log.Warning)
91+
92+
logNotice :: TraceIO -> Trace IO Text
93+
logNotice = contramap ((,) Log.Notice)
94+
95+
logError :: TraceIO -> Trace IO Text
96+
logError = contramap ((,) Log.Error)

Diff for: ‎util/Pos/Util/Trace/Named.hs

+159
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,159 @@
1+
-- | 'Trace' for named logging.
2+
3+
{-# LANGUAGE FlexibleContexts #-}
4+
{-# LANGUAGE ScopedTypeVariables #-}
5+
6+
module Pos.Util.Trace.Named
7+
( TraceNamed
8+
, LogNamed (..)
9+
, TrU.LogItem
10+
, named
11+
, setupLogging
12+
, namedTrace
13+
, appendName
14+
-- * rexports
15+
, natTrace
16+
-- * log functions
17+
, logMessage, logMessageS, logMessageP
18+
, logDebug, logDebugS, logDebugP, logDebugSP, logDebugUnsafeP
19+
, logError, logErrorS, logErrorP, logErrorSP, logErrorUnsafeP
20+
, logInfo, logInfoS, logInfoP, logInfoSP, logInfoUnsafeP
21+
, logNotice, logNoticeS, logNoticeP, logNoticeSP, logNoticeUnsafeP
22+
, logWarning, logWarningS, logWarningP, logWarningSP, logWarningUnsafeP
23+
) where
24+
25+
import Universum
26+
27+
import Data.Functor.Contravariant (Op (..), contramap)
28+
import qualified Pos.Util.Log as Log
29+
import Pos.Util.Log.LoggerConfig (LogSecurityLevel (..))
30+
import Pos.Util.Log.LogSafe (SecuredText, logMCond, logMessageUnsafeP,
31+
selectPublicLogs, selectSecretLogs)
32+
import Pos.Util.Trace (Trace (..), natTrace, traceWith)
33+
import qualified Pos.Util.Trace.Unstructured as TrU (LogItem (..),
34+
LogPrivacy (..))
35+
36+
type TraceNamed m = Trace m (LogNamed TrU.LogItem)
37+
38+
-- | Attach a 'LoggerName' to something.
39+
data LogNamed item = LogNamed
40+
{ lnName :: [Log.LoggerName]
41+
, lnItem :: item
42+
} deriving (Show)
43+
44+
traceNamedItem
45+
:: TraceNamed m
46+
-> TrU.LogPrivacy
47+
-> Log.Severity
48+
-> Text
49+
-> m ()
50+
traceNamedItem logTrace p s m =
51+
traceWith (named logTrace) TrU.LogItem{ TrU.liPrivacy = p
52+
, TrU.liSeverity = s
53+
, TrU.liMessage = m
54+
}
55+
56+
logMessage, logMessageS, logMessageP :: TraceNamed m -> Log.Severity -> Text -> m ()
57+
logMessage logTrace = traceNamedItem logTrace TrU.Both
58+
logMessageS logTrace = traceNamedItem logTrace TrU.Private
59+
logMessageP logTrace = traceNamedItem logTrace TrU.Public
60+
61+
logDebug, logInfo, logNotice, logWarning, logError
62+
:: TraceNamed m -> Text -> m ()
63+
logDebug logTrace = traceNamedItem logTrace TrU.Both Log.Debug
64+
logInfo logTrace = traceNamedItem logTrace TrU.Both Log.Info
65+
logNotice logTrace = traceNamedItem logTrace TrU.Both Log.Notice
66+
logWarning logTrace = traceNamedItem logTrace TrU.Both Log.Warning
67+
logError logTrace = traceNamedItem logTrace TrU.Both Log.Error
68+
logDebugS, logInfoS, logNoticeS, logWarningS, logErrorS
69+
:: TraceNamed m -> Text -> m ()
70+
logDebugS logTrace = traceNamedItem logTrace TrU.Private Log.Debug
71+
logInfoS logTrace = traceNamedItem logTrace TrU.Private Log.Info
72+
logNoticeS logTrace = traceNamedItem logTrace TrU.Private Log.Notice
73+
logWarningS logTrace = traceNamedItem logTrace TrU.Private Log.Warning
74+
logErrorS logTrace = traceNamedItem logTrace TrU.Private Log.Error
75+
logDebugP, logInfoP, logNoticeP, logWarningP, logErrorP
76+
:: TraceNamed m -> Text -> m ()
77+
logDebugP logTrace = traceNamedItem logTrace TrU.Public Log.Debug
78+
logInfoP logTrace = traceNamedItem logTrace TrU.Public Log.Info
79+
logNoticeP logTrace = traceNamedItem logTrace TrU.Public Log.Notice
80+
logWarningP logTrace = traceNamedItem logTrace TrU.Public Log.Warning
81+
logErrorP logTrace = traceNamedItem logTrace TrU.Public Log.Error
82+
logDebugSP, logInfoSP, logNoticeSP, logWarningSP, logErrorSP
83+
:: Monad m => TraceNamed m -> SecuredText -> m ()
84+
logDebugSP logTrace f = logDebugS logTrace (f SecretLogLevel) >> logDebugP logTrace (f PublicLogLevel)
85+
logInfoSP logTrace f = logInfoS logTrace (f SecretLogLevel) >> logInfoP logTrace (f PublicLogLevel)
86+
logNoticeSP logTrace f = logNoticeS logTrace (f SecretLogLevel) >> logNoticeP logTrace (f PublicLogLevel)
87+
logWarningSP logTrace f = logWarningS logTrace (f SecretLogLevel) >> logWarningP logTrace (f PublicLogLevel)
88+
logErrorSP logTrace f = logErrorS logTrace (f SecretLogLevel) >> logErrorP logTrace (f PublicLogLevel)
89+
logDebugUnsafeP, logInfoUnsafeP, logNoticeUnsafeP, logWarningUnsafeP, logErrorUnsafeP
90+
:: TraceNamed m -> Text -> m ()
91+
logDebugUnsafeP logTrace = traceNamedItem logTrace TrU.PublicUnsafe Log.Debug
92+
logInfoUnsafeP logTrace = traceNamedItem logTrace TrU.PublicUnsafe Log.Info
93+
logNoticeUnsafeP logTrace = traceNamedItem logTrace TrU.PublicUnsafe Log.Notice
94+
logWarningUnsafeP logTrace = traceNamedItem logTrace TrU.PublicUnsafe Log.Warning
95+
logErrorUnsafeP logTrace = traceNamedItem logTrace TrU.PublicUnsafe Log.Error
96+
97+
modifyName
98+
:: ([Log.LoggerName] -> [Log.LoggerName])
99+
-> TraceNamed m
100+
-> TraceNamed m
101+
modifyName k = contramap f
102+
where
103+
f (LogNamed name item) = LogNamed (k name) item
104+
105+
appendName :: Log.LoggerName -> TraceNamed m -> TraceNamed m
106+
appendName lname = modifyName (\e -> [lname] <> e)
107+
108+
named :: Trace m (LogNamed i) -> Trace m i
109+
named = contramap (LogNamed mempty)
110+
111+
-- | setup logging and return a Trace
112+
setupLogging
113+
:: MonadIO m
114+
=> Log.LoggerConfig -> Log.LoggerName -> m (TraceNamed m)
115+
setupLogging lc ln = do
116+
lh <- liftIO $ Log.setupLogging lc
117+
let nt = namedTrace lh
118+
return $ appendName ln nt
119+
120+
namedTrace
121+
:: MonadIO m => Log.LoggingHandler -> TraceNamed m
122+
namedTrace lh = Trace $ Op $ \namedLogitem ->
123+
let loggerNames = lnName namedLogitem
124+
litem = lnItem namedLogitem
125+
privacy = TrU.liPrivacy litem
126+
severity = TrU.liSeverity litem
127+
message = TrU.liMessage litem
128+
in
129+
liftIO $ case privacy of
130+
TrU.Both -> Log.usingLoggerNames lh loggerNames $
131+
Log.logMessage severity message
132+
-- pass to every logging scribe
133+
TrU.Public -> Log.usingLoggerNames lh loggerNames $
134+
logMCond lh severity message selectPublicLogs
135+
-- pass to logging scribes that are marked as
136+
-- public (LogSecurityLevel == PublicLogLevel).
137+
TrU.PublicUnsafe -> Log.usingLoggerNames lh loggerNames $
138+
logMessageUnsafeP severity lh message
139+
-- pass to logging scribes that are marked as
140+
-- public (LogSecurityLevel == PublicLogLevel).
141+
TrU.Private -> Log.usingLoggerNames lh loggerNames $
142+
logMCond lh severity message selectSecretLogs
143+
-- pass to logging scribes that are marked as
144+
-- private (LogSecurityLevel == SecretLogLevel).
145+
146+
{- testing:
147+
148+
logTrace' <- setupLogging (Pos.Util.LoggerConfig.defaultInteractiveConfiguration Log.Debug) "named"
149+
let li = publicLogItem (Log.Debug, "testing")
150+
ni = namedItem "Tests" li
151+
152+
traceWith logTrace' ni
153+
traceWith (named $ appendName "more" logTrace') li
154+
155+
156+
logTrace' <- setupLogging (Pos.Util.LoggerConfig.jsonInteractiveConfiguration Log.Debug) "named"
157+
logDebug logTrace' "hello"
158+
logDebug (appendName "blabla" logTrace') "hello"
159+
-}

Diff for: ‎util/Pos/Util/Trace/Unstructured.hs

+145
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,145 @@
1+
-- | Unstructured logging via Pos.Util.Trace: a text message with severity
2+
-- and privacy levels.
3+
4+
module Pos.Util.Trace.Unstructured
5+
( LogItem (..)
6+
, LogPrivacy (..)
7+
8+
, publicLogItem
9+
, privateLogItem
10+
, publicPrivateLogItem
11+
12+
, setupLogging
13+
14+
, logDebug
15+
, logError
16+
, logInfo
17+
, logNotice
18+
, logWarning
19+
20+
, logDebugP
21+
, logErrorP
22+
, logInfoP
23+
, logNoticeP
24+
, logWarningP
25+
26+
, logDebugS
27+
, logErrorS
28+
, logInfoS
29+
, logNoticeS
30+
, logWarningS
31+
32+
, LogSecurityLevel (..)
33+
, traceLogItemSP
34+
, logDebugSP
35+
, logErrorSP
36+
, logInfoSP
37+
, logNoticeSP
38+
, logWarningSP
39+
) where
40+
41+
import Universum
42+
43+
import Data.Functor.Contravariant (Op (..))
44+
import qualified Pos.Util.Log as Log
45+
import Pos.Util.Trace (Trace (..), traceWith)
46+
47+
48+
data LogPrivacy =
49+
Public -- only to public logs.
50+
| PublicUnsafe -- only to public logs, not console.
51+
| Private -- only to private logs.
52+
| Both -- to public and private logs.
53+
deriving (Show)
54+
55+
-- | An unstructured log item.
56+
data LogItem = LogItem
57+
{ liPrivacy :: LogPrivacy
58+
, liSeverity :: Log.Severity
59+
, liMessage :: Text
60+
} deriving (Show)
61+
62+
publicLogItem :: (Log.Severity, Text) -> LogItem
63+
publicLogItem = uncurry (LogItem Public)
64+
65+
privateLogItem :: (Log.Severity, Text) -> LogItem
66+
privateLogItem = uncurry (LogItem Private)
67+
68+
publicPrivateLogItem :: (Log.Severity, Text) -> LogItem
69+
publicPrivateLogItem = uncurry (LogItem Both)
70+
71+
traceLogItem
72+
:: Trace m LogItem
73+
-> LogPrivacy
74+
-> Log.Severity
75+
-> Text
76+
-> m ()
77+
traceLogItem logTrace privacy severity message =
78+
traceWith logTrace logItem
79+
where
80+
logItem = LogItem
81+
{ liPrivacy = privacy
82+
, liSeverity = severity
83+
, liMessage = message
84+
}
85+
86+
logDebug, logInfo, logNotice, logWarning, logError
87+
:: Trace m LogItem -> Text -> m ()
88+
logDebug logTrace = traceLogItem logTrace Both Log.Debug
89+
logInfo logTrace = traceLogItem logTrace Both Log.Info
90+
logNotice logTrace = traceLogItem logTrace Both Log.Notice
91+
logWarning logTrace = traceLogItem logTrace Both Log.Warning
92+
logError logTrace = traceLogItem logTrace Both Log.Error
93+
94+
logDebugP, logInfoP, logNoticeP, logWarningP, logErrorP
95+
:: Trace m LogItem -> Text -> m ()
96+
logDebugP logTrace = traceLogItem logTrace Public Log.Debug
97+
logInfoP logTrace = traceLogItem logTrace Public Log.Info
98+
logNoticeP logTrace = traceLogItem logTrace Public Log.Notice
99+
logWarningP logTrace = traceLogItem logTrace Public Log.Warning
100+
logErrorP logTrace = traceLogItem logTrace Public Log.Error
101+
102+
logDebugS, logInfoS, logNoticeS, logWarningS, logErrorS
103+
:: Trace m LogItem -> Text -> m ()
104+
logDebugS logTrace = traceLogItem logTrace Private Log.Debug
105+
logInfoS logTrace = traceLogItem logTrace Private Log.Info
106+
logNoticeS logTrace = traceLogItem logTrace Private Log.Notice
107+
logWarningS logTrace = traceLogItem logTrace Private Log.Warning
108+
logErrorS logTrace = traceLogItem logTrace Private Log.Error
109+
110+
type SecuredText = LogSecurityLevel -> Text
111+
112+
data LogSecurityLevel = SecretLogLevel | PublicLogLevel
113+
114+
-- | Log to public logs, and to private logs securely (the 'SecuredText' is
115+
-- run at the 'SecretLogLevel').
116+
traceLogItemSP
117+
:: Applicative m
118+
=> Trace m LogItem
119+
-> Log.Severity
120+
-> SecuredText
121+
-> m ()
122+
traceLogItemSP logTrace severity securedText =
123+
traceLogItem logTrace Private severity (securedText SecretLogLevel)
124+
*> traceLogItem logTrace Public severity (securedText PublicLogLevel)
125+
126+
logDebugSP, logInfoSP, logNoticeSP, logWarningSP, logErrorSP
127+
:: Applicative m => Trace m LogItem -> SecuredText -> m ()
128+
logDebugSP logTrace = traceLogItemSP logTrace Log.Debug
129+
logInfoSP logTrace = traceLogItemSP logTrace Log.Info
130+
logNoticeSP logTrace = traceLogItemSP logTrace Log.Notice
131+
logWarningSP logTrace = traceLogItemSP logTrace Log.Warning
132+
logErrorSP logTrace = traceLogItemSP logTrace Log.Error
133+
134+
-- | setup logging and return a Trace
135+
setupLogging :: MonadIO m => Log.LoggerConfig -> Log.LoggerName -> IO (Trace m LogItem)
136+
setupLogging lc ln = do
137+
lh <- Log.setupLogging lc
138+
return $ unstructuredTrace ln lh
139+
140+
unstructuredTrace :: MonadIO m => Log.LoggerName -> Log.LoggingHandler -> Trace m LogItem
141+
unstructuredTrace ln lh = Trace $ Op $ \logitem ->
142+
let severity = liSeverity logitem
143+
message = liMessage logitem
144+
in
145+
liftIO $ Log.usingLoggerName lh ln $ Log.logMessage severity message

0 commit comments

Comments
 (0)