Merge pull request #2055 from input-output-hk/gromak/csl1822-refine-logging

[CSL-1822] Refine logging

Author: gromakovsky

Diff for: auxx/Main.hs

@@ -11,7 +11,7 @@ import           Formatting (sformat, shown, (%))
 import           Mockable (Production, currentTime, runProduction)
 import qualified Network.Transport.TCP as TCP (TCPAddr (..))
 import qualified System.IO.Temp as Temp
-import           System.Wlog (logInfo)
+import           System.Wlog (LoggerName, logInfo)
 
 import qualified Pos.Client.CLI as CLI
 import           Pos.Communication (OutSpecs, WorkerSpec)
@@ -31,7 +31,10 @@ import           Pos.WorkMode (EmptyMempoolExt, RealMode)
 import           AuxxOptions (AuxxAction (..), AuxxOptions (..), AuxxStartMode (..), getAuxxOptions)
 import           Mode (AuxxContext (..), AuxxMode, CmdCtx (..), realModeToAuxx)
 import           Plugin (auxxPlugin, rawExec)
-import           Repl (WithCommandAction(..), withAuxxRepl)
+import           Repl (WithCommandAction (..), withAuxxRepl)
+
+loggerName :: LoggerName
+loggerName = "auxx"
 
 -- 'NodeParams' obtained using 'CLI.getNodeParams' are not perfect for
 -- Auxx, so we need to adapt them slightly.
@@ -88,7 +91,7 @@ action opts@AuxxOptions {..} command = do
                   $ withConfigurations conf configToDict
             mode <$ case mode of
                 Nothing -> printAction "Mode: light"
-                _ -> printAction "Mode: with-config"
+                _       -> printAction "Mode: with-config"
         Light -> return Nothing
         _ -> withConfigurations conf configToDict
 
@@ -99,7 +102,7 @@ action opts@AuxxOptions {..} command = do
           t <- currentTime
           logInfo $ sformat ("Current time is "%shown) (Timestamp t)
           (nodeParams, tempDbUsed) <-
-              correctNodeParams opts =<< CLI.getNodeParams cArgs nArgs
+              correctNodeParams opts =<< CLI.getNodeParams loggerName cArgs nArgs
           let
               toRealMode :: AuxxMode a -> RealMode EmptyMempoolExt a
               toRealMode auxxAction = do
@@ -136,7 +139,7 @@ main = withCompileInfo $(retrieveCompileTimeInfo) $ do
                   \lp -> lp { lpConsoleLog = Just False }
             | otherwise = identity
         loggingParams = disableConsoleLog $
-            CLI.loggingParams "auxx" (aoCommonNodeArgs opts)
+            CLI.loggingParams loggerName (aoCommonNodeArgs opts)
     loggerBracket loggingParams $ do
         let runAction a = runProduction $ action opts a
         case aoAction opts of

Diff for: block/src/Pos/Block/Network/Announce.hs

@@ -43,7 +43,8 @@ announceBlock
     :: BlockWorkMode ctx m
     => EnqueueMsg m -> MainBlockHeader -> m (Map NodeId (m ()))
 announceBlock enqueue header = do
-    logDebug $ sformat ("Announcing header to others:\n"%build) header
+    logDebug $ sformat ("Announcing header to others: "%shortHashF)
+               (headerHash header)
     enqueue (MsgAnnounceBlockHeader OriginSender) (\addr _ -> announceBlockDo addr)
   where
     announceBlockDo

Diff for: block/src/Pos/Block/Network/Logic.hs

@@ -184,9 +184,8 @@ handleUnsolicitedHeader
     -> m ()
 handleUnsolicitedHeader header nodeId = do
     logDebug $ sformat
-        ("handleUnsolicitedHeader: single header "%shortHashF%
-         " was propagated, processing")
-        hHash
+        ("handleUnsolicitedHeader: single header was propagated, processing:\n"
+         %build) header
     classificationRes <- classifyNewHeader header
     -- TODO: should we set 'To' hash to hash of header or leave it unlimited?
     case classificationRes of
@@ -399,7 +398,8 @@ addHeaderToBlockRequestQueue
     -> Bool -- ^ Was classified as chain continuation
     -> m ()
 addHeaderToBlockRequestQueue nodeId header continues = do
-    logDebug $ sformat ("addToBlockRequestQueue, : "%build) header
+    let hHash = headerHash header
+    logDebug $ sformat ("addToBlockRequestQueue, : "%shortHashF) hHash
     queue <- view (lensOf @BlockRetrievalQueueTag)
     lastKnownH <- view (lensOf @LastKnownHeaderTag)
     added <- atomically $ do
@@ -409,7 +409,7 @@ addHeaderToBlockRequestQueue nodeId header continues = do
     if added
     then logDebug $ sformat ("Added headers to block request queue: nodeId="%build%
                              ", header="%build)
-                            nodeId (headerHash header)
+                            nodeId hHash
     else logWarning $ sformat ("Failed to add headers from "%build%
                                " to block retrieval queue: queue is full")
                               nodeId
@@ -581,7 +581,8 @@ relayBlock enqueue (Right mainBlk) = do
     recoveryInProgress >>= \case
         True -> logDebug "Not relaying block in recovery mode"
         False -> do
-            logDebug $ sformat ("Calling announceBlock for "%build%".") (mainBlk ^. gbHeader)
+            logDebug $ sformat ("Calling announceBlock for "%shortHashF%".")
+                       (mainBlk ^. gbHeader . headerHashG)
             void $ announceBlock enqueue $ mainBlk ^. gbHeader
 
 ----------------------------------------------------------------------------

Diff for: block/src/Pos/Block/Network/Retrieval.hs

@@ -126,10 +126,11 @@ retrievalWorkerImpl keepAliveTimer SendActions {..} =
 
     -- When we have continuation, we just try to get and apply it.
     handleContinues nodeId header = do
-        logDebug $ "handleContinues: " <> pretty header
+        let hHash = headerHash header
+        logDebug $ "handleContinues: " <> pretty hHash
         classifyNewHeader header >>= \case
             CHContinues ->
-                void $ getProcessBlocks enqueueMsg nodeId header (headerHash header)
+                void $ getProcessBlocks enqueueMsg nodeId header hHash
             res -> logDebug $
                 "processContHeader: expected header to " <>
                 "be continuation, but it's " <> show res
@@ -138,7 +139,7 @@ retrievalWorkerImpl keepAliveTimer SendActions {..} =
     -- really recovery mode (server side should send us headers as a
     -- proof) and then enter recovery mode.
     handleAlternative nodeId header = do
-        logDebug $ "handleAlternative: " <> pretty header
+        logDebug $ "handleAlternative: " <> pretty (headerHash header)
         classifyNewHeader header >>= \case
             CHInvalid _ ->
                 logError "handleAlternative: invalid header got into retrievalWorker queue"

Diff for: block/src/Pos/Block/Worker.hs

@@ -14,7 +14,7 @@ import qualified Data.List.NonEmpty as NE
 import           Data.Time.Units (Microsecond)
 import           Formatting (Format, bprint, build, fixed, int, now, sformat, shown, (%))
 import           Mockable (delay, fork)
-import           Serokell.Util (listJson, pairF, sec)
+import           Serokell.Util (enumerate, listJson, pairF, sec)
 import qualified System.Metrics.Label as Label
 import           System.Wlog (logDebug, logInfo, logWarning)
 
@@ -71,18 +71,20 @@ blkWorkers
     => Timer -> ([WorkerSpec m], OutSpecs)
 blkWorkers keepAliveTimer =
     merge $ [ blkCreatorWorker
-            , blkMetricCheckerWorker
+            , informerWorker
             , retrievalWorker keepAliveTimer
             , recoveryTriggerWorker
             ]
   where
     merge = mconcatPair . map (first pure)
 
-blkMetricCheckerWorker :: BlockWorkMode ctx m => (WorkerSpec m, OutSpecs)
-blkMetricCheckerWorker =
+informerWorker :: BlockWorkMode ctx m => (WorkerSpec m, OutSpecs)
+informerWorker =
     onNewSlotWorker True announceBlockOuts $ \slotId _ ->
-        recoveryCommGuard "onNewSlot worker, blkMetricCheckerWorker" $
-             metricWorker slotId
+        recoveryCommGuard "onNewSlot worker, informerWorker" $ do
+            tipHeader <- DB.getTipHeader
+            logDebug $ sformat ("Our tip header: "%build) tipHeader
+            metricWorker slotId
 
 ----------------------------------------------------------------------------
 -- Block creation worker
@@ -139,11 +141,9 @@ blockCreator (slotId@SlotId {..}) sendActions = do
             -- of them.
             dropAround :: Int -> Int -> [a] -> [a]
             dropAround p s = take (2*s + 1) . drop (max 0 (p - s))
-            strLeaders = map (bprint pairF) (zip [0 :: Int ..] $ toList leaders)
-        if siSlot == minBound
-            then logInfo $ sformat ("Full slot leaders: "%listJson) strLeaders
-            else logDebug $ sformat ("Trimmed leaders: "%listJson) $
-                            dropAround (fromIntegral $ fromEnum $ siSlot) 10 strLeaders
+            strLeaders = map (bprint pairF) (enumerate @Int (toList leaders))
+        logDebug $ sformat ("Trimmed leaders: "%listJson)
+                 $ dropAround (fromEnum siSlot) 10 strLeaders
 
         ourHeavyPsk <- getPskByIssuer (Left ourPk)
         let heavyWeAreIssuer = isJust ourHeavyPsk

Diff for: block/src/Pos/Lrc/Worker.hs

@@ -22,14 +22,14 @@ import qualified Data.HashSet as HS
 import           Ether.Internal (HasLens (..))
 import           Formatting (build, ords, sformat, (%))
 import           Mockable (forConcurrently)
-import           Serokell.Util.Exceptions ()
 import           System.Wlog (logDebug, logInfo, logWarning)
 
 import           Pos.Block.Logic.Internal (BypassSecurityCheck (..), MonadBlockApply,
                                            applyBlocksUnsafe, rollbackBlocksUnsafe)
 import           Pos.Block.Slog.Logic (ShouldCallBListener (..))
-import           Pos.Core (Coin, EpochIndex, EpochOrSlot (..), SharedSeed, StakeholderId,
-                           blkSecurityParam, crucialSlot, epochIndexL, getEpochOrSlot)
+import           Pos.Core (Coin, EpochIndex, EpochOrSlot (..), SharedSeed, SlotLeaders,
+                           StakeholderId, blkSecurityParam, crucialSlot, epochIndexL,
+                           getEpochOrSlot, slotLeadersF)
 import qualified Pos.DB.Block.Load as DB
 import qualified Pos.DB.GState.Stakes as GS (getRealStake, getRealTotalStake)
 import qualified Pos.GState.SanityCheck as DB (sanityCheckDB)
@@ -206,12 +206,23 @@ issuersComputationDo epochId = do
            hm <$ (logWarning $ sformat ("Stake for issuer "%build% " not found") id)
         Just stake -> pure $ HM.insert id stake hm
 
-leadersComputationDo :: LrcMode ctx m => EpochIndex -> SharedSeed -> m ()
+leadersComputationDo ::
+       forall ctx m. LrcMode ctx m
+    => EpochIndex
+    -> SharedSeed
+    -> m ()
 leadersComputationDo epochId seed =
     unlessM (LrcDB.hasLeaders epochId) $ do
         totalStake <- GS.getRealTotalStake
-        leaders <- runConduitRes $ GS.stakeSource .| followTheSatoshiM seed totalStake
+        leaders <-
+            runConduitRes $ GS.stakeSource .| followTheSatoshiM seed totalStake
         LrcDB.putLeadersForEpoch epochId leaders
+        logLeaders leaders
+  where
+    logLeaders :: SlotLeaders -> m ()
+    logLeaders leaders = logInfo $
+        sformat ("Slot leaders for "%build%" are: "%slotLeadersF)
+        epochId (toList leaders)
 
 richmenComputationDo
     :: forall ctx m.

Diff for: core/Pos/Core/Common/Types.hs

@@ -27,6 +27,7 @@ module Pos.Core.Common.Types
 
        , SharedSeed (..)
        , SlotLeaders
+       , slotLeadersF
 
        -- * Coin
        , Coin
@@ -61,8 +62,9 @@ import           Data.Data (Data)
 import           Data.Hashable (Hashable (..))
 import qualified Data.Semigroup (Semigroup (..))
 import qualified Data.Text.Buildable as Buildable
-import           Formatting (Format, bprint, build, formatToString, int, (%))
+import           Formatting (Format, bprint, build, formatToString, int, later, (%))
 import qualified PlutusCore.Program as PLCore
+import           Serokell.Util (enumerate, listChunkedJson, pairBuilder)
 import           Serokell.Util.Base16 (formatBase16)
 import           System.Random (Random (..))
 
@@ -230,6 +232,21 @@ instance Monoid SharedSeed where
 -- | 'NonEmpty' list of slot leaders.
 type SlotLeaders = NonEmpty StakeholderId
 
+-- | Pretty-printer for slot leaders. Note: it takes list (not
+-- 'NonEmpty' as an argument, because one can always convert @NonEmpty
+-- a@ to @[a]@, but it also may be convenient to use it with a simple
+-- list of slot leaders).
+--
+-- Example:
+-- [
+--    (0, 44283ce5), (1, 5f53e01e), (2, 44283ce5), (3, 1a1ff703), (4, 44283ce5), (5, 44283ce5), (6, 281e5ae9), (7, 1a1ff703)
+--    (8, 1a1ff703), (9, 5f53e01e), (10, 1a1ff703), (11, 44283ce5), (12, 44283ce5), (13, 5f53e01e), (14, 5f53e01e), (15, 5f53e01e)
+--    (16, 44283ce5), (17, 281e5ae9), (18, 281e5ae9), (19, 44283ce5)
+-- ]
+slotLeadersF :: Format r ([StakeholderId] -> r)
+slotLeadersF =
+    later $ bprint (listChunkedJson 8) . map pairBuilder . enumerate @Int
+
 ----------------------------------------------------------------------------
 -- Coin
 ----------------------------------------------------------------------------

Diff for: explorer/src/explorer/Main.hs

@@ -14,7 +14,7 @@ import           Universum
 import           Data.Maybe (fromJust)
 import           Formatting (sformat, shown, (%))
 import           Mockable (Production, currentTime, runProduction)
-import           System.Wlog (logInfo)
+import           System.Wlog (LoggerName, logInfo)
 
 import           NodeOptions (ExplorerArgs (..), ExplorerNodeArgs (..), getExplorerNodeOptions)
 import           Pos.Binary ()
@@ -36,14 +36,17 @@ import           Pos.Util (mconcatPair)
 import           Pos.Util.CompileInfo (HasCompileInfo, retrieveCompileTimeInfo, withCompileInfo)
 import           Pos.Util.UserSecret (usVss)
 
+loggerName :: LoggerName
+loggerName = "node"
+
 ----------------------------------------------------------------------------
 -- Main action
 ----------------------------------------------------------------------------
 
 main :: IO ()
 main = do
     args <- getExplorerNodeOptions
-    let loggingParams = CLI.loggingParams "node" (enaCommonNodeArgs args)
+    let loggingParams = CLI.loggingParams loggerName (enaCommonNodeArgs args)
     loggerBracket loggingParams . runProduction $ do
         CLI.printFlags
         logInfo $ "[Attention] Software is built with explorer part"
@@ -57,7 +60,7 @@ action (ExplorerNodeArgs (cArgs@CommonNodeArgs{..}) ExplorerArgs{..}) =
         logInfo $ sformat ("System start time is " % shown) systemStart
         t <- currentTime
         logInfo $ sformat ("Current time is " % shown) (Timestamp t)
-        currentParams <- getNodeParams cArgs nodeArgs
+        currentParams <- getNodeParams loggerName cArgs nodeArgs
         logInfo $ "Explorer is enabled!"
         logInfo $ sformat ("Using configs and genesis:\n"%shown) conf
 

Diff for: lib/src/Pos/Client/CLI/Params.hs

@@ -29,17 +29,17 @@ import           Pos.Update.Params (UpdateParams (..))
 import           Pos.Util.UserSecret (peekUserSecret)
 
 loggingParams :: LoggerName -> CommonNodeArgs -> LoggingParams
-loggingParams tag CommonNodeArgs{..} =
+loggingParams defaultName CommonNodeArgs{..} =
     LoggingParams
     { lpHandlerPrefix = logPrefix commonArgs
     , lpConfigPath    = logConfig commonArgs
-    , lpRunnerTag     = tag
+    , lpDefaultName   = defaultName
     , lpConsoleLog    = Nothing -- no override by default
     }
 
 getBaseParams :: LoggerName -> CommonNodeArgs -> BaseParams
-getBaseParams loggingTag args@CommonNodeArgs {..} =
-    BaseParams { bpLoggingParams = loggingParams loggingTag args }
+getBaseParams defaultLoggerName args@CommonNodeArgs {..} =
+    BaseParams { bpLoggingParams = loggingParams defaultLoggerName args }
 
 gtSscParams :: CommonNodeArgs -> VssKeyPair -> BehaviorConfig -> SscParams
 gtSscParams CommonNodeArgs {..} vssSK BehaviorConfig{..} =
@@ -65,10 +65,11 @@ getNodeParams ::
        , HasConfiguration
        , HasSscConfiguration
        )
-    => CommonNodeArgs
+    => LoggerName
+    -> CommonNodeArgs
     -> NodeArgs
     -> m NodeParams
-getNodeParams cArgs@CommonNodeArgs{..} NodeArgs{..} = do
+getNodeParams defaultLoggerName cArgs@CommonNodeArgs{..} NodeArgs{..} = do
     (primarySK, userSecret) <-
         prepareUserSecret cArgs =<< peekUserSecret (getKeyfilePath cArgs)
     npNetworkConfig <- intNetworkConfigOpts networkConfigOpts
@@ -80,7 +81,7 @@ getNodeParams cArgs@CommonNodeArgs{..} NodeArgs{..} = do
         , npRebuildDb = rebuildDB
         , npSecretKey = primarySK
         , npUserSecret = userSecret
-        , npBaseParams = getBaseParams "node" cArgs
+        , npBaseParams = getBaseParams defaultLoggerName cArgs
         , npJLFile = jlPath
         , npReportServers = reportServers commonArgs
         , npUpdateParams = UpdateParams

Diff for: lib/src/Pos/Client/CLI/Util.hs

@@ -12,11 +12,10 @@ module Pos.Client.CLI.Util
 
 import           Universum
 
-import           Control.Lens (zoom, (?=))
 import qualified Data.ByteString.Lazy as BSL
 import           Formatting (sformat, shown, (%))
-import           System.Wlog (LoggerConfig (..), Severity (Info, Warning), WithLogger, fromScratch,
-                              lcTree, logInfo, ltSeverity, parseLoggerConfig, zoomLogger)
+import           System.Wlog (LoggerConfig (..), WithLogger, logInfo, parseLoggerConfig,
+                              productionB)
 import           Text.Parsec (try)
 import qualified Text.Parsec.Char as P
 import qualified Text.Parsec.Text as P
@@ -51,19 +50,11 @@ attackTargetParser =
     (NetworkAddressTarget <$> addrParser)
 
 -- | Default logger config. Will be used if `--log-config` argument is
--- not passed. Corresponds to next logger config:
---
--- > node:
--- >   severity: Info
--- >   comm:
--- >     severity: Warning
---
+-- not passed.
 defaultLoggerConfig :: LoggerConfig
-defaultLoggerConfig = fromScratch $ zoom lcTree $ zoomLogger "node" $ do
-    ltSeverity ?= Info
-    zoomLogger "comm" $ ltSeverity ?= Warning
+defaultLoggerConfig = productionB
 
--- | Reads logger config from given path. By default return
+-- | Reads logger config from given path. By default returns
 -- 'defaultLoggerConfig'.
 readLoggerConfig :: MonadIO m => Maybe FilePath -> m LoggerConfig
 readLoggerConfig = maybe (return defaultLoggerConfig) parseLoggerConfig

Diff for: lib/src/Pos/Launcher/Param.hs

@@ -31,10 +31,14 @@ import           Pos.Util.UserSecret (UserSecret)
 
 -- | Contains all parameters required for hierarchical logger initialization.
 data LoggingParams = LoggingParams
-    { lpRunnerTag     :: !LoggerName        -- ^ Prefix for logger, like "time-slave"
-    , lpHandlerPrefix :: !(Maybe FilePath)  -- ^ Prefix of path for all logs
-    , lpConfigPath    :: !(Maybe FilePath)  -- ^ Path to logger configuration
-    , lpConsoleLog    :: !(Maybe Bool)      -- ^ Enable console logging (override)
+    { lpDefaultName   :: !LoggerName
+    -- ^ Logger name which will be used by default
+    , lpHandlerPrefix :: !(Maybe FilePath)
+    -- ^ Prefix of path for all logs
+    , lpConfigPath    :: !(Maybe FilePath)
+    -- ^ Path to logger configuration
+    , lpConsoleLog    :: !(Maybe Bool)
+    -- ^ Enable console logging (override)
     } deriving (Show)
 
 -- | Contains basic & networking parameters for running node.