[CBR-423] Added safe structured logging.

input-output-hk · Sep 20, 2018 · 3787bde · 3787bde
1 parent 6ffb31f
commit 3787bde
Show file tree

Hide file tree

Showing 3 changed files with 142 additions and 94 deletions.
diff --git a/infra/src/Pos/Infra/Slotting/Util.hs b/infra/src/Pos/Infra/Slotting/Util.hs
@@ -50,7 +50,7 @@ import           Pos.Infra.Shutdown (HasShutdownContext)
 import           Pos.Infra.Slotting.Class (MonadSlots (..))
 import           Pos.Infra.Slotting.Error (SlottingError (..))
 import           Pos.Infra.Slotting.Impl.Util (slotFromTimestamp)
-import           Pos.Util.Log.Structured (logInfoX)
+import           Pos.Util.Log.Structured (logInfoSX)
 import           Pos.Util.Util (maybeThrow)
 import           Pos.Util.Wlog (WithLogger, logDebug, logInfo, logNotice,
                      logWarning, modifyLoggerName)
@@ -192,7 +192,7 @@ onNewSlotDo epochSlots withLogging expectedSlotId onsp action = do
     recoveryRefreshDelay = 150
     logTTW timeToWait = modifyLoggerName (<> ".slotting") $ do
         logDebug $ sformat ("Waiting for "%shown%" before new slot") timeToWait
-        logInfoX $ TimeDiff timeToWait
+        logInfoSX $ TimeDiff timeToWait
 
 logNewSlotWorker :: MonadOnNewSlot ctx m => SlotCount -> m ()
 logNewSlotWorker epochSlots =

diff --git a/util/src/Pos/Util/Log/Structured.hs b/util/src/Pos/Util/Log/Structured.hs
@@ -5,13 +5,27 @@ module Pos.Util.Log.Structured
        , logNoticeX
        , logWarningX
        , logErrorX
+         -- * Safe logging
+       , logMessageSX
+       , logDebugSX
+       , logInfoSX
+       , logNoticeSX
+       , logWarningSX
+       , logErrorSX
+       , logMessagePX
+       , logDebugPX
+       , logInfoPX
+       , logNoticePX
+       , logWarningPX
+       , logErrorPX
        ) where
 
 import           Universum
 
 import           Pos.Util.Log (ToObject)
+import           Pos.Util.Log.LogSafe (selectPublicLogs, selectSecretLogs)
 import           Pos.Util.Wlog.Compatibility (HasLoggerName (..), Severity (..),
-                     logMX)
+                     logMX, logXCond)
 
 -- | Shortcut for 'logMessageX' to use according severity.
 logDebugX, logInfoX, logNoticeX, logWarningX, logErrorX
@@ -32,3 +46,43 @@ logMessageX
 logMessageX severity a = do
     name <- askLoggerName
     logMX name severity a
+
+-- | Shortcut for 'logMessageSX' to use according severity.
+logDebugSX, logInfoSX, logNoticeSX, logWarningSX, logErrorSX
+    :: (HasLoggerName m, MonadIO m, ToObject a)
+    => a -> m ()
+logDebugSX   = logMessageSX Debug
+logInfoSX    = logMessageSX Info
+logNoticeSX  = logMessageSX Notice
+logWarningSX = logMessageSX Warning
+logErrorSX   = logMessageSX Error
+
+-- | Log an item in JSON format (only for secret JSON scribes).
+logMessageSX
+    :: (HasLoggerName m, MonadIO m, ToObject a)
+    => Severity
+    -> a
+    -> m ()
+logMessageSX severity a = do
+    name <- askLoggerName
+    logXCond name severity a selectSecretLogs
+
+-- | Shortcut for 'logMessagePX' to use according severity.
+logDebugPX, logInfoPX, logNoticePX, logWarningPX, logErrorPX
+    :: (HasLoggerName m, MonadIO m, ToObject a)
+    => a -> m ()
+logDebugPX   = logMessagePX Debug
+logInfoPX    = logMessagePX Info
+logNoticePX  = logMessagePX Notice
+logWarningPX = logMessagePX Warning
+logErrorPX   = logMessagePX Error
+
+-- | Log an item in JSON format (only for public JSON scribes).
+logMessagePX
+    :: (HasLoggerName m, MonadIO m, ToObject a)
+    => Severity
+    -> a
+    -> m ()
+logMessagePX severity a = do
+    name <- askLoggerName
+    logXCond name severity a selectPublicLogs
diff --git a/util/src/Pos/Util/Wlog/Compatibility.hs b/util/src/Pos/Util/Wlog/Compatibility.hs
@@ -39,6 +39,8 @@ module Pos.Util.Wlog.Compatibility
          , getLinesLogged
            -- * Structured logging
          , logMX
+         -- * Safe structured logging
+         , logXCond
          ) where
 
 import           Control.Concurrent (modifyMVar_, myThreadId)
@@ -251,63 +253,6 @@ setupLogging' cfoKey lc = liftIO $ do
     modifyMVar_ loggingHandler $ const $ Log.setupLogging cfoKey lc
     readMVar loggingHandler
 
--- | Whether to log to given log handler.
-type SelectionMode = LogSecurityLevel -> Bool
-
--- | this emulates katip's 'logItem' function, but only outputs the message
---   to scribes which match the 'SelectionMode'
-logItemS
-    :: (Log.ToObject a, MonadIO m)
-    => LoggingHandler
-    -> a
-    -> K.Namespace
-    -> Maybe TH.Loc
-    -> K.Severity
-    -> SelectionMode
-    -> K.LogStr
-    -> m ()
-logItemS lhandler a ns loc sev cond msg = do
-    mayle <- liftIO $ Internal.getLogEnv lhandler
-    case mayle of
-        Nothing -> error "logging not yet initialized. Abort."
-        Just le -> do
-            maycfg <- liftIO $ Internal.getConfig lhandler
-            let cfg = case maycfg of
-                    Nothing -> error "No Configuration for logging found. Abort."
-                    Just c  -> c
-            let sevmin = Internal.sev2klog $ cfg ^. lcLoggerTree ^. ltMinSeverity
-            when (sev >= sevmin)
-              $ liftIO $ do
-                item <- K.Item
-                    <$> pure (K._logEnvApp le)
-                    <*> pure (K._logEnvEnv le)
-                    <*> pure sev
-                    <*> (KC.mkThreadIdText <$> myThreadId)
-                    <*> pure (K._logEnvHost le)
-                    <*> pure (K._logEnvPid le)
-                    <*> pure a
-                    <*> pure msg
-                    <*> (K._logEnvTimer le)
-                    <*> pure ((K._logEnvApp le) <> ns)
-                    <*> pure loc
-                let lhs = cfg ^. lcLoggerTree ^. ltHandlers ^.. each
-                forM_ (filterWithSafety cond lhs) (\ lh -> do
-                    case lookup (lh ^. lhName) (K._logEnvScribes le) of
-                        Nothing -> error ("Not found Scribe with name: " <> lh ^. lhName)
-                        Just scribeH -> atomically
-                            (KC.tryWriteTBQueue (KC.shChan scribeH) (KC.NewItem item)))
-            where
-              filterWithSafety :: SelectionMode -> [LogHandler] -> [LogHandler]
-              filterWithSafety condition = filter (\lh -> case _lhSecurityLevel lh of
-                  Nothing -> False
-                  Just s  -> condition s)
-
-logMCond :: MonadIO m => LoggerName -> Severity -> Text -> SelectionMode -> m ()
-logMCond name severity msg cond = do
-    let ns = K.Namespace (T.split (=='.') name)
-    lh <- liftIO $ readMVar loggingHandler
-    logItemS lh () ns Nothing (Internal.sev2klog severity) cond $ K.logStr msg
-
 getLinesLogged :: IO Integer
 getLinesLogged = do
     lh <- liftIO $ readMVar loggingHandler
@@ -334,53 +279,102 @@ centiUtcTimeF utc =
 removeAllHandlers :: IO ()
 removeAllHandlers = pure ()
 
--- | Logs an item only into JSON scribes.
+-- Safe and structured logging.
+
+-- | Whether to log to given log handler.
+type SelectionMode = LogSecurityLevel -> Bool
+type LogHandlerExclusion = [LogHandler] -> [LogHandler]
+
+logMCond :: MonadIO m => LoggerName -> Severity -> Text -> SelectionMode -> m ()
+logMCond name severity msg cond = do
+    let ns = K.Namespace (T.split (=='.') name)
+    lh <- liftIO $ readMVar loggingHandler
+    logItemCond lh
+                ()
+                ns
+                Nothing
+                (Internal.sev2klog severity)
+                (filterWithSafety cond)
+                (Just msg)
+
+-- | Keeps only 'Scribes' which match the 'SelectionMode'.
+filterWithSafety :: SelectionMode -> LogHandlerExclusion
+filterWithSafety condition = filter (\lh -> case _lhSecurityLevel lh of
+    Nothing -> False
+    Just s  -> condition s)
+
+-- | Logs an item only into JSON 'Scribes'.
 --   Also, ToJSON a => KC.LogItem (see Pos.Util.Log).
 logMX :: (MonadIO m, Log.ToObject a) => LoggerName -> Severity -> a -> m ()
 logMX name severity a = do
     let ns = K.Namespace [name]
     lh <- liftIO $ readMVar loggingHandler
-    logItemX lh a ns Nothing (Internal.sev2klog severity)
-
--- | Helper function which outputs only to JSON scribes.
-logItemX
+    logItemCond lh
+                a
+                ns
+                Nothing
+                (Internal.sev2klog severity)
+                filterJsonScribes
+                Nothing
+
+-- | Filters out 'Scribes' that are not JSON 'Scribes'.
+filterJsonScribes :: LogHandlerExclusion
+filterJsonScribes = filter (\lh -> _lhBackend lh == FileJsonBE)
+
+-- | Logs an item only into JSON 'Scribes' which match the 'SelectionMode'.
+logXCond :: (MonadIO m, Log.ToObject a) => LoggerName -> Severity -> a -> SelectionMode -> m ()
+logXCond name severity a cond = do
+    let ns = K.Namespace [name]
+    lh <- liftIO $ readMVar loggingHandler
+    logItemCond lh
+                a
+                ns
+                Nothing
+                (Internal.sev2klog severity)
+                ((filterWithSafety cond) . filterJsonScribes)
+                Nothing
+
+--  | Writes only to 'Scribes's filtered with 'LogHandlerExclusion' function.
+logItemCond
     :: (Log.ToObject a, MonadIO m)
-    => Internal.LoggingHandler
+    => LoggingHandler
     -> a
     -> K.Namespace
     -> Maybe TH.Loc
     -> K.Severity
+    -> LogHandlerExclusion
+    -> Maybe Text
     -> m ()
-logItemX lhandler a ns loc sev = do
+logItemCond lhandler a ns loc sev strainer mayMsg = do
     mayle <- liftIO $ Internal.getLogEnv lhandler
     case mayle of
         Nothing -> error "logging not yet initialized. Abort."
         Just le -> do
             maycfg <- liftIO $ Internal.getConfig lhandler
-            case maycfg of
-                Nothing  -> error "No Configuration for logging found. Abort."
-                Just cfg -> do
-                    let sevmin = Internal.sev2klog $ cfg ^. lcLoggerTree ^. ltMinSeverity
-                    when (sev >= sevmin) $
-                        liftIO $ do
-                            item <- K.Item
-                                <$> pure (K._logEnvApp le)
-                                <*> pure (K._logEnvEnv le)
-                                <*> pure sev
-                                <*> (KC.mkThreadIdText <$> myThreadId)
-                                <*> pure (K._logEnvHost le)
-                                <*> pure (K._logEnvPid le)
-                                <*> pure a
-                                <*> mempty
-                                <*> (K._logEnvTimer le)
-                                <*> pure ((K._logEnvApp le) <> ns)
-                                <*> pure loc
-                            let lhs = cfg ^. lcLoggerTree ^. ltHandlers ^.. each
-                            forM_ (filterJson lhs) (\ lh -> do
-                                case lookup (lh ^. lhName) (K._logEnvScribes le) of
-                                    Nothing -> error ("Not found Scribe with name: " <> lh ^. lhName)
-                                    Just scribeH -> atomically
-                                        (KC.tryWriteTBQueue (KC.shChan scribeH) (KC.NewItem item)))
-            where
-              filterJson :: [LogHandler] -> [LogHandler]
-              filterJson = filter (\lh -> _lhBackend lh == FileJsonBE)
+            let cfg = case maycfg of
+                    Nothing -> error "No Configuration for logging found. Abort."
+                    Just c  -> c
+            let sevmin = Internal.sev2klog $ cfg ^. lcLoggerTree ^. ltMinSeverity
+            when (sev >= sevmin)
+              $ liftIO $ do
+                threadId <- myThreadId
+                time <- K._logEnvTimer le
+                let item = K.Item {
+                      K._itemApp       = K._logEnvApp le
+                    , K._itemEnv       = K._logEnvEnv le
+                    , K._itemSeverity  = sev
+                    , K._itemThread    = KC.mkThreadIdText threadId
+                    , K._itemHost      = K._logEnvHost le
+                    , K._itemProcess   = K._logEnvPid le
+                    , K._itemPayload   = a
+                    , K._itemMessage   = maybe mempty K.logStr mayMsg
+                    , K._itemTime      = time
+                    , K._itemNamespace = (K._logEnvApp le) <> ns
+                    , K._itemLoc       = loc
+                    }
+                let lhs = cfg ^. lcLoggerTree ^. ltHandlers ^.. each
+                forM_ (strainer lhs) (\ lh -> do
+                    case lookup (lh ^. lhName) (K._logEnvScribes le) of
+                        Nothing -> error ("Not found Scribe with name: " <> lh ^. lhName)
+                        Just scribeH -> atomically
+                            (KC.tryWriteTBQueue (KC.shChan scribeH) (KC.NewItem item)))