[CBR-213] introduce 'Trace.Named'

Signed-off-by: Alexander Diemand <[email protected]>

util/Pos/Util/Trace.hs

@@ -1,17 +1,30 @@
+{-# LANGUAGE RankNTypes #-}
 
 module Pos.Util.Trace
     ( Trace (..)
+    , TraceIO
+    , natTrace
     , trace
     , traceWith
     , noTrace
     , stdoutTrace
     -- TODO put wlog tracing into its own module.
     , wlogTrace
     , Wlog.Severity (..)
+    -- * trace setup
+    , setupLogging
+    , logTrace
+    -- * log messages
+    , logDebug
+    , logInfo
+    , logWarning
+    , logNotice
+    , logError
     ) where
 
 import           Data.Functor.Contravariant (Contravariant (..), Op (..))
 import qualified Data.Text.IO as TIO
+import qualified Pos.Util.Log as Log
 import qualified Pos.Util.Wlog as Wlog
 import           Universum hiding (trace)
 
@@ -20,9 +33,23 @@ newtype Trace m s = Trace
     { runTrace :: Op (m ()) s
     }
 
+type TraceIO = Trace IO (Log.Severity, Text)
+
 instance Contravariant (Trace m) where
     contramap f = Trace . contramap f . runTrace
 
+natTrace :: (forall x . m x -> n x) -> Trace m s -> Trace n s
+natTrace nat (Trace (Op tr)) = Trace $ Op $ nat . tr
+
+-- | setup logging and return a Trace
+setupLogging :: MonadIO m
+             => Log.LoggerConfig
+             -> Log.LoggerName
+             -> IO (Trace m (Log.Severity, Text))
+setupLogging lc ln = do
+    lh <- Log.setupLogging lc
+    return $ logTrace lh ln
+
 trace :: Trace m s -> s -> m ()
 trace = getOp . runTrace
 
@@ -44,3 +71,26 @@ stdoutTrace = Trace $ Op $ TIO.putStrLn
 wlogTrace :: Wlog.LoggerName -> Trace IO (Wlog.Severity, Text)
 wlogTrace loggerName = Trace $ Op $ \(severity, txt) ->
     Wlog.usingLoggerName loggerName $ Wlog.logMessage severity txt
+
+-- | A 'Trace' that uses logging from @Pos.Util.Log@
+logTrace :: MonadIO m
+         => Log.LoggingHandler
+         -> Log.LoggerName
+         -> Trace m (Log.Severity, Text)
+logTrace lh loggerName = Trace $ Op $ \(severity, txt) ->
+    liftIO $ Log.usingLoggerName lh loggerName $ Log.logMessage severity txt
+
+logDebug :: TraceIO -> Trace IO Text
+logDebug = contramap ((,) Log.Debug)
+
+logInfo :: TraceIO -> Trace IO Text
+logInfo = contramap ((,) Log.Info)
+
+logWarning :: TraceIO -> Trace IO Text
+logWarning = contramap ((,) Log.Warning)
+
+logNotice :: TraceIO -> Trace IO Text
+logNotice = contramap ((,) Log.Notice)
+
+logError :: TraceIO -> Trace IO Text
+logError = contramap ((,) Log.Error)

util/Pos/Util/Trace/Named.hs

@@ -0,0 +1,159 @@
+-- | 'Trace' for named logging.
+
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Pos.Util.Trace.Named
+    ( TraceNamed
+    , LogNamed (..)
+    , TrU.LogItem
+    , named
+    , setupLogging
+    , namedTrace
+    , appendName
+    -- * rexports
+    , natTrace
+    -- * log functions
+    , logMessage, logMessageS, logMessageP
+    , logDebug,   logDebugS,   logDebugP,   logDebugSP,   logDebugUnsafeP
+    , logError,   logErrorS,   logErrorP,   logErrorSP,   logErrorUnsafeP
+    , logInfo,    logInfoS,    logInfoP,    logInfoSP,    logInfoUnsafeP
+    , logNotice,  logNoticeS,  logNoticeP,  logNoticeSP,  logNoticeUnsafeP
+    , logWarning, logWarningS, logWarningP, logWarningSP, logWarningUnsafeP
+    ) where
+
+import           Universum
+
+import           Data.Functor.Contravariant (Op (..), contramap)
+import qualified Pos.Util.Log as Log
+import           Pos.Util.Log.LoggerConfig (LogSecurityLevel (..))
+import           Pos.Util.Log.LogSafe (SecuredText, logMCond, logMessageUnsafeP,
+                     selectPublicLogs, selectSecretLogs)
+import           Pos.Util.Trace (Trace (..), natTrace, traceWith)
+import qualified Pos.Util.Trace.Unstructured as TrU (LogItem (..),
+                     LogPrivacy (..))
+
+type TraceNamed m = Trace m (LogNamed TrU.LogItem)
+
+-- | Attach a 'LoggerName' to something.
+data LogNamed item = LogNamed
+    { lnName :: [Log.LoggerName]
+    , lnItem :: item
+    } deriving (Show)
+
+traceNamedItem
+    :: TraceNamed m
+    -> TrU.LogPrivacy
+    -> Log.Severity
+    -> Text
+    -> m ()
+traceNamedItem logTrace p s m =
+    traceWith (named logTrace) TrU.LogItem{ TrU.liPrivacy  = p
+                                          , TrU.liSeverity = s
+                                          , TrU.liMessage  = m
+                                          }
+
+logMessage, logMessageS, logMessageP :: TraceNamed m -> Log.Severity -> Text -> m ()
+logMessage logTrace  = traceNamedItem logTrace TrU.Both
+logMessageS logTrace = traceNamedItem logTrace TrU.Private
+logMessageP logTrace = traceNamedItem logTrace TrU.Public
+
+logDebug, logInfo, logNotice, logWarning, logError
+    :: TraceNamed m -> Text -> m ()
+logDebug logTrace   = traceNamedItem logTrace TrU.Both Log.Debug
+logInfo logTrace    = traceNamedItem logTrace TrU.Both Log.Info
+logNotice logTrace  = traceNamedItem logTrace TrU.Both Log.Notice
+logWarning logTrace = traceNamedItem logTrace TrU.Both Log.Warning
+logError logTrace   = traceNamedItem logTrace TrU.Both Log.Error
+logDebugS, logInfoS, logNoticeS, logWarningS, logErrorS
+    :: TraceNamed m -> Text -> m ()
+logDebugS logTrace   = traceNamedItem logTrace TrU.Private Log.Debug
+logInfoS logTrace    = traceNamedItem logTrace TrU.Private Log.Info
+logNoticeS logTrace  = traceNamedItem logTrace TrU.Private Log.Notice
+logWarningS logTrace = traceNamedItem logTrace TrU.Private Log.Warning
+logErrorS logTrace   = traceNamedItem logTrace TrU.Private Log.Error
+logDebugP, logInfoP, logNoticeP, logWarningP, logErrorP
+    :: TraceNamed m -> Text -> m ()
+logDebugP logTrace   = traceNamedItem logTrace TrU.Public Log.Debug
+logInfoP logTrace    = traceNamedItem logTrace TrU.Public Log.Info
+logNoticeP logTrace  = traceNamedItem logTrace TrU.Public Log.Notice
+logWarningP logTrace = traceNamedItem logTrace TrU.Public Log.Warning
+logErrorP logTrace   = traceNamedItem logTrace TrU.Public Log.Error
+logDebugSP, logInfoSP, logNoticeSP, logWarningSP, logErrorSP
+    :: Monad m => TraceNamed m -> SecuredText -> m ()
+logDebugSP logTrace   f = logDebugS logTrace (f SecretLogLevel) >> logDebugP logTrace (f PublicLogLevel)
+logInfoSP logTrace    f = logInfoS logTrace (f SecretLogLevel) >> logInfoP logTrace (f PublicLogLevel)
+logNoticeSP logTrace  f = logNoticeS logTrace (f SecretLogLevel) >> logNoticeP logTrace (f PublicLogLevel)
+logWarningSP logTrace f = logWarningS logTrace (f SecretLogLevel) >> logWarningP logTrace (f PublicLogLevel)
+logErrorSP logTrace   f = logErrorS logTrace (f SecretLogLevel) >> logErrorP logTrace (f PublicLogLevel)
+logDebugUnsafeP, logInfoUnsafeP, logNoticeUnsafeP, logWarningUnsafeP, logErrorUnsafeP
+    :: TraceNamed m -> Text -> m ()
+logDebugUnsafeP logTrace   = traceNamedItem logTrace TrU.PublicUnsafe Log.Debug
+logInfoUnsafeP logTrace    = traceNamedItem logTrace TrU.PublicUnsafe Log.Info
+logNoticeUnsafeP logTrace  = traceNamedItem logTrace TrU.PublicUnsafe Log.Notice
+logWarningUnsafeP logTrace = traceNamedItem logTrace TrU.PublicUnsafe Log.Warning
+logErrorUnsafeP logTrace   = traceNamedItem logTrace TrU.PublicUnsafe Log.Error
+
+modifyName
+    :: ([Log.LoggerName] -> [Log.LoggerName])
+    -> TraceNamed m
+    -> TraceNamed m
+modifyName k = contramap f
+  where
+    f (LogNamed name item) = LogNamed (k name) item
+
+appendName :: Log.LoggerName -> TraceNamed m -> TraceNamed m
+appendName lname = modifyName (\e -> [lname] <> e)
+
+named :: Trace m (LogNamed i) -> Trace m i
+named = contramap (LogNamed mempty)
+
+-- | setup logging and return a Trace
+setupLogging
+    :: MonadIO m
+    => Log.LoggerConfig -> Log.LoggerName -> m (TraceNamed m)
+setupLogging lc ln = do
+    lh <- liftIO $ Log.setupLogging lc
+    let nt = namedTrace lh
+    return $ appendName ln nt
+
+namedTrace
+    :: MonadIO m => Log.LoggingHandler -> TraceNamed m
+namedTrace lh = Trace $ Op $ \namedLogitem ->
+    let loggerNames =  lnName namedLogitem
+        litem = lnItem namedLogitem
+        privacy  = TrU.liPrivacy litem
+        severity = TrU.liSeverity litem
+        message  = TrU.liMessage litem
+    in
+    liftIO $ case privacy of
+        TrU.Both    -> Log.usingLoggerNames lh loggerNames $
+            Log.logMessage severity message
+        -- pass to every logging scribe
+        TrU.Public  -> Log.usingLoggerNames lh loggerNames $
+            logMCond lh severity message selectPublicLogs
+        -- pass to logging scribes that are marked as
+        -- public (LogSecurityLevel == PublicLogLevel).
+        TrU.PublicUnsafe  -> Log.usingLoggerNames lh loggerNames $
+            logMessageUnsafeP severity lh message
+        -- pass to logging scribes that are marked as
+        -- public (LogSecurityLevel == PublicLogLevel).
+        TrU.Private -> Log.usingLoggerNames lh loggerNames $
+            logMCond lh severity message selectSecretLogs
+        -- pass to logging scribes that are marked as
+        -- private (LogSecurityLevel == SecretLogLevel).
+
+{- testing:
+
+logTrace' <- setupLogging (Pos.Util.LoggerConfig.defaultInteractiveConfiguration Log.Debug) "named"
+let li = publicLogItem (Log.Debug, "testing")
+    ni = namedItem "Tests" li
+
+traceWith logTrace' ni
+traceWith (named $ appendName "more" logTrace') li
+
+
+logTrace' <- setupLogging (Pos.Util.LoggerConfig.jsonInteractiveConfiguration Log.Debug) "named"
+logDebug logTrace' "hello"
+logDebug (appendName "blabla" logTrace') "hello"
+-}

util/Pos/Util/Trace/Unstructured.hs

@@ -0,0 +1,145 @@
+-- | Unstructured logging via Pos.Util.Trace: a text message with severity
+-- and privacy levels.
+
+module Pos.Util.Trace.Unstructured
+    ( LogItem (..)
+    , LogPrivacy (..)
+
+    , publicLogItem
+    , privateLogItem
+    , publicPrivateLogItem
+
+    , setupLogging
+
+    , logDebug
+    , logError
+    , logInfo
+    , logNotice
+    , logWarning
+
+    , logDebugP
+    , logErrorP
+    , logInfoP
+    , logNoticeP
+    , logWarningP
+
+    , logDebugS
+    , logErrorS
+    , logInfoS
+    , logNoticeS
+    , logWarningS
+
+    , LogSecurityLevel (..)
+    , traceLogItemSP
+    , logDebugSP
+    , logErrorSP
+    , logInfoSP
+    , logNoticeSP
+    , logWarningSP
+    ) where
+
+import           Universum
+
+import           Data.Functor.Contravariant (Op (..))
+import qualified Pos.Util.Log as Log
+import           Pos.Util.Trace (Trace (..), traceWith)
+
+
+data LogPrivacy =
+      Public       -- only to public logs.
+    | PublicUnsafe -- only to public logs, not console.
+    | Private      -- only to private logs.
+    | Both         -- to public and private logs.
+    deriving (Show)
+
+-- | An unstructured log item.
+data LogItem = LogItem
+    { liPrivacy  :: LogPrivacy
+    , liSeverity :: Log.Severity
+    , liMessage  :: Text
+    } deriving (Show)
+
+publicLogItem :: (Log.Severity, Text) -> LogItem
+publicLogItem = uncurry (LogItem Public)
+
+privateLogItem :: (Log.Severity, Text) -> LogItem
+privateLogItem = uncurry (LogItem Private)
+
+publicPrivateLogItem :: (Log.Severity, Text) -> LogItem
+publicPrivateLogItem = uncurry (LogItem Both)
+
+traceLogItem
+    :: Trace m LogItem
+    -> LogPrivacy
+    -> Log.Severity
+    -> Text
+    -> m ()
+traceLogItem logTrace privacy severity message =
+    traceWith logTrace logItem
+  where
+    logItem = LogItem
+        { liPrivacy = privacy
+        , liSeverity = severity
+        , liMessage = message
+        }
+
+logDebug, logInfo, logNotice, logWarning, logError
+    :: Trace m LogItem -> Text -> m ()
+logDebug logTrace   = traceLogItem logTrace Both Log.Debug
+logInfo logTrace    = traceLogItem logTrace Both Log.Info
+logNotice logTrace  = traceLogItem logTrace Both Log.Notice
+logWarning logTrace = traceLogItem logTrace Both Log.Warning
+logError logTrace   = traceLogItem logTrace Both Log.Error
+
+logDebugP, logInfoP, logNoticeP, logWarningP, logErrorP
+    :: Trace m LogItem -> Text -> m ()
+logDebugP logTrace   = traceLogItem logTrace Public Log.Debug
+logInfoP logTrace    = traceLogItem logTrace Public Log.Info
+logNoticeP logTrace  = traceLogItem logTrace Public Log.Notice
+logWarningP logTrace = traceLogItem logTrace Public Log.Warning
+logErrorP logTrace   = traceLogItem logTrace Public Log.Error
+
+logDebugS, logInfoS, logNoticeS, logWarningS, logErrorS
+    :: Trace m LogItem -> Text -> m ()
+logDebugS logTrace   = traceLogItem logTrace Private Log.Debug
+logInfoS logTrace    = traceLogItem logTrace Private Log.Info
+logNoticeS logTrace  = traceLogItem logTrace Private Log.Notice
+logWarningS logTrace = traceLogItem logTrace Private Log.Warning
+logErrorS logTrace   = traceLogItem logTrace Private Log.Error
+
+type SecuredText = LogSecurityLevel -> Text
+
+data LogSecurityLevel = SecretLogLevel | PublicLogLevel
+
+-- | Log to public logs, and to private logs securely (the 'SecuredText' is
+-- run at the 'SecretLogLevel').
+traceLogItemSP
+    :: Applicative m
+    => Trace m LogItem
+    -> Log.Severity
+    -> SecuredText
+    -> m ()
+traceLogItemSP logTrace severity securedText =
+       traceLogItem logTrace Private severity (securedText SecretLogLevel)
+    *> traceLogItem logTrace Public severity  (securedText PublicLogLevel)
+
+logDebugSP, logInfoSP, logNoticeSP, logWarningSP, logErrorSP
+    :: Applicative m => Trace m LogItem -> SecuredText -> m ()
+logDebugSP logTrace   = traceLogItemSP logTrace Log.Debug
+logInfoSP logTrace    = traceLogItemSP logTrace Log.Info
+logNoticeSP logTrace  = traceLogItemSP logTrace Log.Notice
+logWarningSP logTrace = traceLogItemSP logTrace Log.Warning
+logErrorSP logTrace   = traceLogItemSP logTrace Log.Error
+
+-- | setup logging and return a Trace
+setupLogging :: MonadIO m => Log.LoggerConfig -> Log.LoggerName -> IO (Trace m LogItem)
+setupLogging lc ln = do
+    lh <- Log.setupLogging lc
+    return $ unstructuredTrace ln lh
+
+unstructuredTrace :: MonadIO m => Log.LoggerName -> Log.LoggingHandler -> Trace m LogItem
+unstructuredTrace ln lh = Trace $ Op $ \logitem ->
+    let severity = liSeverity logitem
+        message = liMessage logitem
+    in
+    liftIO $ Log.usingLoggerName lh ln $ Log.logMessage severity message