diff --git a/infra/src/Pos/Infra/Slotting/Util.hs b/infra/src/Pos/Infra/Slotting/Util.hs index 56f0064cd4a..f07c104be39 100644 --- 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 index 236d1567e13..bae72c1a4d4 100644 --- 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 index 5ed5e46ec17..2f56efe0bb9 100644 --- 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)))