CAD-1859 node: bulk leadership tracing

cardano-node/cardano-node.cabal

@@ -113,6 +113,7 @@ library
                      , safe-exceptions
                      , scientific
                      , shelley-spec-ledger
+                     , stm
                      , strict-concurrency
                      , text
                      , time

cardano-node/src/Cardano/Node/Run.hs

@@ -296,7 +296,7 @@ handleSimpleNode p trace nodeTracers nc onKernel = do
 
     startTime <- getCurrentTime
     traceNodeBasicInfo tr =<< nodeBasicInfo nc p startTime
-    traceCounter "nodeStartTime" (ceiling $ utcTimeToPOSIXSeconds startTime) tr
+    traceCounter "nodeStartTime" tr (ceiling $ utcTimeToPOSIXSeconds startTime)
 
     when ncValidateDB $ traceWith tracer "Performing DB validation"
 

cardano-node/src/Cardano/Tracing/Metrics.hs

@@ -1,11 +1,14 @@
 
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DisambiguateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -14,11 +17,21 @@ module Cardano.Tracing.Metrics
   , MaxKESEvolutions (..)
   , OperationalCertStartKESPeriod (..)
   , HasKESMetricsData (..)
+  , ForgingStats (..)
+  , ForgeThreadStats (..)
+  , mapForgingCurrentThreadStats
+  , mapForgingCurrentThreadStats_
+  , mapForgingStatsTxsProcessed
+  , mkForgingStats
+  , threadStatsProjection
   ) where
 
 import           Cardano.Prelude hiding (All, (:.:))
 
 import           Cardano.Crypto.KES.Class (Period)
+import           Control.Concurrent.STM
+import           Data.IORef (IORef, atomicModifyIORef', newIORef)
+import qualified Data.Map.Strict as Map
 import           Data.SOP.Strict (All, hcmap, K (..), hcollapse)
 import           Ouroboros.Consensus.Block (ForgeStateInfo)
 import           Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock)
@@ -90,3 +103,78 @@ instance All HasKESMetricsData xs => HasKESMetricsData (HardForkBlock xs) where
              => WrapForgeStateInfo blk
              -> K KESMetricsData blk
       getOne = K . getKESMetricsData (Proxy @blk) . unwrapForgeStateInfo
+
+-- | This structure stores counters of blockchain-related events,
+--   per individual forge thread.
+--   These counters are driven by traces.
+data ForgingStats
+  = ForgingStats
+  { fsTxsProcessedNum :: !(IORef Int)
+    -- ^ Transactions removed from mempool.
+  , fsState           :: !(TVar (Map ThreadId (TVar ForgeThreadStats)))
+  }
+
+-- | Per-forging-thread statistics.
+data ForgeThreadStats = ForgeThreadStats
+  { ftsNodeCannotForgeNum        :: !Int
+  , ftsNodeIsLeaderNum           :: !Int
+  , ftsBlocksForgedNum           :: !Int
+  , ftsSlotsMissedNum            :: !Int
+    -- ^ Potentially missed slots.  Note that this is not the same as the number
+    -- of missed blocks, since this includes all occurences of not reaching a
+    -- leadership check decision, whether or not leadership was possible or not.
+    --
+    -- Also note that when the aggregate total for this metric is reported in the
+    -- multi-pool case, it can be much larger than the actual number of slots
+    -- occuring since node start, for it is a sum total for all threads.
+  , ftsLastSlot                  :: !Int
+  }
+
+mkForgingStats :: IO ForgingStats
+mkForgingStats =
+  ForgingStats
+    <$> newIORef 0
+    <*> newTVarIO mempty
+
+mapForgingStatsTxsProcessed ::
+     ForgingStats
+  -> (Int -> Int)
+  -> IO Int
+mapForgingStatsTxsProcessed fs f =
+  atomicModifyIORef' (fsTxsProcessedNum fs) $
+    \txCount -> (f txCount, txCount)
+
+mapForgingCurrentThreadStats ::
+     ForgingStats
+  -> (ForgeThreadStats -> (ForgeThreadStats, a))
+  -> IO a
+mapForgingCurrentThreadStats ForgingStats { fsState } f = do
+  tid <- myThreadId
+  allStats <- readTVarIO fsState
+  varStats <- case Map.lookup tid allStats of
+    Nothing -> do
+      varStats <- newTVarIO $ ForgeThreadStats 0 0 0 0 0
+      atomically $ modifyTVar fsState $ Map.insert tid varStats
+      return varStats
+    Just varStats ->
+      return varStats
+  atomically $ do
+    stats <- readTVar varStats
+    let !(!stats', x) = f stats
+    writeTVar varStats stats'
+    return x
+
+mapForgingCurrentThreadStats_ ::
+     ForgingStats
+  -> (ForgeThreadStats -> ForgeThreadStats)
+  -> IO ()
+mapForgingCurrentThreadStats_ fs f =
+  void $ mapForgingCurrentThreadStats fs ((, ()) . f)
+
+threadStatsProjection ::
+     ForgingStats
+  -> (ForgeThreadStats -> a)
+  -> IO [a]
+threadStatsProjection fs f = atomically $ do
+  allStats <- readTVar (fsState fs)
+  mapM (fmap f . readTVar) $ Map.elems allStats

cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs

@@ -46,6 +46,7 @@ import           Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server
                      (TraceLocalTxSubmissionServerEvent (..))
 import           Ouroboros.Consensus.Node.Run (RunNode, estimateBlockSize)
 import           Ouroboros.Consensus.Node.Tracers (TraceForgeEvent (..))
+import qualified Ouroboros.Consensus.Node.Tracers as Consensus
 import           Ouroboros.Consensus.Protocol.Abstract
 import qualified Ouroboros.Consensus.Protocol.BFT as BFT
 import qualified Ouroboros.Consensus.Protocol.PBFT as PBFT
@@ -326,6 +327,19 @@ instance ( tx ~ GenTx blk
 instance Transformable Text IO (TraceLocalTxSubmissionServerEvent blk) where
   trTransformer = trStructured
 
+instance HasPrivacyAnnotation a => HasPrivacyAnnotation (Consensus.TraceLabelCreds a)
+instance HasSeverityAnnotation a => HasSeverityAnnotation (Consensus.TraceLabelCreds a) where
+  getSeverityAnnotation (Consensus.TraceLabelCreds _ a) = getSeverityAnnotation a
+
+instance ToObject a => ToObject (Consensus.TraceLabelCreds a) where
+  toObject verb (Consensus.TraceLabelCreds creds val) =
+    mkObject [ "credentials" .= toJSON creds
+             , "val"         .= toObject verb val
+             ]
+
+instance (HasPrivacyAnnotation a, HasSeverityAnnotation a, ToObject a)
+      => Transformable Text IO (Consensus.TraceLabelCreds a) where
+  trTransformer = trStructured
 
 instance ( ConvertRawHash blk
          , LedgerSupportsProtocol blk