Merge pull request #3609 from input-output-hk/andreas/CBR-423/Structu…

…red-logging-of-data-structures_PR

[CBR-423] Structured logging of data structures

core/src/Pos/Core/Slotting/TimeDiff.hs

@@ -8,12 +8,15 @@ module Pos.Core.Slotting.TimeDiff
 
 import           Universum
 
-import           Data.Time.Units (Microsecond)
+import           Data.Aeson (Value (..))
+import           Data.HashMap.Strict (singleton)
+import           Data.Time.Units (Microsecond, toMicroseconds)
 import qualified Formatting.Buildable as Buildable
 import qualified Prelude
 
 import           Pos.Binary.Class (Bi (..))
 import           Pos.Core.Slotting.Timestamp
+import           Pos.Util.Log (ToObject (..))
 
 -- | Difference between two timestamps
 newtype TimeDiff = TimeDiff
@@ -36,6 +39,9 @@ instance Bi TimeDiff where
 instance NFData TimeDiff where
     rnf TimeDiff{..} = rnf (toInteger getTimeDiff)
 
+instance ToObject TimeDiff where
+    toObject (TimeDiff usec) = singleton "TimeDiff" $ String $ show $ toMicroseconds usec
+
 addTimeDiffToTimestamp :: TimeDiff -> Timestamp -> Timestamp
 addTimeDiffToTimestamp = addMicrosecondsToTimestamp . getTimeDiff
 

infra/src/Pos/Infra/Slotting/Util.hs

@@ -39,22 +39,23 @@ import           Pos.Core (LocalSlotIndex, SlotCount, SlotId (..),
 import           Pos.Core.Conc (delay, timeout)
 import           Pos.Core.Slotting (ActionTerminationPolicy (..),
                      EpochSlottingData (..), MonadSlotsData,
-                     OnNewSlotParams (..), SlottingData, computeSlotStart,
-                     defaultOnNewSlotParams, getCurrentNextEpochSlottingDataM,
-                     getCurrentSlotFlat, getEpochSlottingDataM,
-                     getSystemStartM, lookupEpochSlottingData)
+                     OnNewSlotParams (..), SlottingData, TimeDiff (..),
+                     computeSlotStart, defaultOnNewSlotParams,
+                     getCurrentNextEpochSlottingDataM, getCurrentSlotFlat,
+                     getEpochSlottingDataM, getSystemStartM,
+                     lookupEpochSlottingData)
 import           Pos.Infra.Recovery.Info (MonadRecoveryInfo, recoveryInProgress)
 import           Pos.Infra.Reporting (MonadReporting, reportOrLogE)
 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 (logInfoSX)
 import           Pos.Util.Util (maybeThrow)
 import           Pos.Util.Wlog (WithLogger, logDebug, logInfo, logNotice,
                      logWarning, modifyLoggerName)
 
 
-
 -- | Get timestamp when given slot starts.
 getSlotStart :: MonadSlotsData ctx m => SlotId -> m (Maybe Timestamp)
 getSlotStart (SlotId {..}) = do
@@ -189,8 +190,9 @@ onNewSlotDo epochSlots withLogging expectedSlotId onsp action = do
     shortDelay = 42
     recoveryRefreshDelay :: Millisecond
     recoveryRefreshDelay = 150
-    logTTW timeToWait = modifyLoggerName (<> ".slotting") $ logDebug $
-                 sformat ("Waiting for "%shown%" before new slot") timeToWait
+    logTTW timeToWait = modifyLoggerName (<> ".slotting") $ do
+        logDebug $ sformat ("Waiting for "%shown%" before new slot") timeToWait
+        logInfoSX $ TimeDiff timeToWait
 
 logNewSlotWorker :: MonadOnNewSlot ctx m => SlotCount -> m ()
 logNewSlotWorker epochSlots =

log-configs/template-demo.yaml

@@ -5,6 +5,10 @@ rotation:
     keepFiles: 20
 loggerTree:
   severity: Debug+
-  files:
-    - {{file}}.pub
-    - {{file}}
+  file: {{file}}
+  handlers:
+    - { name: "json"
+      , filepath: "{{file}}.json"
+      , logsafety: PublicLogLevel
+      , severity: Debug
+      , backend: FileJsonBE }

util/cardano-sl-util.cabal

@@ -39,6 +39,7 @@ library
                        Pos.Util.Log.LoggerConfig
                        Pos.Util.Log.LoggerName
                        Pos.Util.Log.Severity
+                       Pos.Util.Log.Structured
                        Pos.Util.Wlog.Compatibility
                        Pos.Util.LoggerName
                        Pos.Util.LRU
@@ -53,12 +54,12 @@ library
                        Pos.Util.Trace.Named
                        Pos.Util.Util
                        Pos.Util.Wlog
+                       Pos.Util.Log.Rotator
 
   other-modules:
                        Paths_cardano_sl_util
                        Pos.Util.CompileInfoGit
                        Pos.Util.Log.Scribes
-                       Pos.Util.Log.Rotator
 
   build-depends:       aeson
                      , auto-update
@@ -159,6 +160,7 @@ test-suite test
                        Test.Pos.Util.TraceSpec
                        Test.Pos.Util.Tripping
                        Test.Pos.Util.WlogSpec
+                       Test.Pos.Util.LogStructuredSpec
 
   build-depends:       aeson
                      , base

util/src/Pos/Util/Log.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 -- | Logging implemented with library `katip`
 
 module Pos.Util.Log
@@ -31,13 +34,17 @@ module Pos.Util.Log
        , askLoggerName
        , addLoggerName
        -- * other functions
+       , closeLogScribes
        , logItem'
+       -- * class for structured logging
+       , ToObject (..)
        ) where
 
 import           Universum
 
 import           Control.Concurrent (myThreadId)
 import           Control.Lens (each)
+import           Data.Aeson (Object, ToJSON (..), Value (..))
 import qualified Data.Text as T
 import           Data.Text.Lazy.Builder
 import qualified Language.Haskell.TH as TH
@@ -52,7 +59,6 @@ import           Pos.Util.Log.Severity (Severity (..))
 import qualified Katip as K
 import qualified Katip.Core as KC
 
-
 -- | alias - pretend not to depend on katip
 type LogContext = K.KatipContext
 type LogContextT = K.KatipContextT
@@ -139,7 +145,7 @@ setupLogging cfoKey lc = do
                                       sevfilter
                                       fdesc
                                       (fromMaybe Debug $ lh ^. lhMinSeverity)
-                                      K.V0
+                                      K.V3
                         return (nm, scribe)
                     FileTextBE -> do
                         let bp = fromMaybe "./" basepath
@@ -232,6 +238,12 @@ loggerBracket lh name action = do
       finalizer le_ = void $ liftIO $ K.closeScribes le_
       body le_ = K.runKatipContextT le_ () (Internal.s2kname name) $ action
 
+closeLogScribes :: MonadIO m => LoggingHandler -> m ()
+closeLogScribes lh = do
+    mayle <- liftIO $ Internal.getLogEnv lh
+    case mayle of
+            Nothing -> error "logging not yet initialized. Abort."
+            Just le -> void $ liftIO $ K.closeScribes le
 
 {- |
    * interactive tests
@@ -258,7 +270,7 @@ loggerBracket lh name action = do
 
 -- | Equivalent to katip's logItem without the `Katip m` constraint
 logItem'
-    :: (KC.LogItem a, MonadIO m)
+    :: (ToObject a, MonadIO m)
     => a
     -> KC.Namespace
     -> K.LogEnv
@@ -282,3 +294,28 @@ logItem' a ns env loc sev msg = do
         <*> pure loc
       forM_ (elems (env ^. KC.logEnvScribes)) $
           \ (KC.ScribeHandle _ shChan) -> atomically (KC.tryWriteTBQueue shChan (KC.NewItem item))
+
+-- | Katip requires JSON objects to be logged as context. This
+-- typeclass provides a default instance which uses ToJSON and
+-- produces an empty object if 'toJSON' results in any type other than
+-- object. If you have a type you want to log that produces an Array
+-- or Number for example, you'll want to write an explicit instance
+-- here. You can trivially add a ToObject instance for something with
+-- a ToJSON instance like:
+--
+-- > instance ToObject Foo
+class ToObject a where
+    toObject :: a -> Object
+    default toObject :: ToJSON a => a -> Object
+    toObject v = case toJSON v of
+        Object o -> o
+        _        -> mempty
+
+instance ToObject () where
+    toObject _ = mempty
+
+instance {-# INCOHERENT #-} ToObject v => KC.ToObject v where
+    toObject = toObject
+
+instance {-# INCOHERENT #-} KC.ToObject a => KC.LogItem a where
+    payloadKeys _ _ = KC.AllKeys

util/src/Pos/Util/Log/LoggerConfig.hs

@@ -59,7 +59,6 @@ data BackendKind = FileTextBE
                  | StderrBE
                  | DevNullBE
                  deriving (Eq, Generic, Show)
-deriving instance ToJSON BackendKind
 deriving instance FromJSON BackendKind
 
 -- | @'RotationParameters'@ one of the two categories  used in the
@@ -70,7 +69,6 @@ data RotationParameters = RotationParameters
     , _rpKeepFilesNum  :: !Word    -- ^ number of files to keep
     } deriving (Generic, Show, Eq)
 
-instance ToJSON RotationParameters
 instance FromJSON RotationParameters where
     parseJSON = withObject "rotation params" $ \o -> do
         _rpLogLimitBytes  <- o .: "logLimit"
@@ -86,7 +84,6 @@ data LogSecurityLevel = SecretLogLevel
                       -- ^ the log only contains public messages (i.e. 'logInfo')
                       deriving (Eq, Show, Generic)
 
-deriving instance ToJSON LogSecurityLevel
 deriving instance FromJSON LogSecurityLevel
 
 -- | @'LogHandler'@ describes the output handler (file, stdout, ..)
@@ -104,7 +101,6 @@ data LogHandler = LogHandler
       -- ^ the minimum severity to be logged
     } deriving (Eq, Generic, Show)
 
-instance ToJSON LogHandler
 instance FromJSON LogHandler where
     parseJSON = withObject "log handler" $ \o -> do
         (_lhName :: T.Text) <- o .: "name"
@@ -139,7 +135,6 @@ data LoggerTree = LoggerTree
     , _ltNamedSeverity :: !NamedSeverity
     } deriving (Eq, Generic, Show)
 
-instance ToJSON LoggerTree
 instance FromJSON LoggerTree where
     parseJSON = withObject "logger tree" $ \o -> do
         (singleFile :: Maybe FilePath) <- fmap normalise <$> o .:? "file"
@@ -206,7 +201,6 @@ data LoggerConfig = LoggerConfig
     , _lcBasePath   :: !(Maybe FilePath)
     } deriving (Generic, Show, Eq)
 
-instance ToJSON LoggerConfig
 instance FromJSON LoggerConfig where
     parseJSON = withObject "config " $ \o -> do
         _lcRotation <- o .:? "rotation"
@@ -348,4 +342,3 @@ defaultTestConfiguration minSeverity =
 
 lcTree :: Functor f => (LoggerTree -> f LoggerTree) -> LoggerConfig -> f LoggerConfig
 lcTree = lcLoggerTree
-

util/src/Pos/Util/Log/Rotator.hs

@@ -11,6 +11,7 @@ module Pos.Util.Log.Rotator
        ( cleanupRotator
        , evalRotator
        , initializeRotator
+       , latestLogFile
        ) where
 
 import           Universum

util/src/Pos/Util/Log/Structured.hs

@@ -0,0 +1,88 @@
+module Pos.Util.Log.Structured
+       ( logMessageX
+       , logDebugX
+       , logInfoX
+       , 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, logXCond)
+
+-- | Shortcut for 'logMessageX' to use according severity.
+logDebugX, logInfoX, logNoticeX, logWarningX, logErrorX
+    :: (HasLoggerName m, MonadIO m, ToObject a)
+    => a -> m ()
+logDebugX   = logMessageX Debug
+logInfoX    = logMessageX Info
+logNoticeX  = logMessageX Notice
+logWarningX = logMessageX Warning
+logErrorX   = logMessageX Error
+
+-- | Log an item in JSON format (only for JSON scribes).
+logMessageX
+    :: (HasLoggerName m, MonadIO m, ToObject a)
+    => Severity
+    -> a
+    -> m ()
+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