diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 413291c5f57..d047d401bd0 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -113,6 +113,7 @@ library , safe-exceptions , scientific , shelley-spec-ledger + , stm , strict-concurrency , text , time diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index db8d2bc3ee3..fd4198eedb7 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/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" diff --git a/cardano-node/src/Cardano/Tracing/Metrics.hs b/cardano-node/src/Cardano/Tracing/Metrics.hs index c67f90e1f32..49f80e3ef94 100644 --- a/cardano-node/src/Cardano/Tracing/Metrics.hs +++ b/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 diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs index 146d1c903b3..ed30b1b0469 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs +++ b/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 diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs index 8e4b87066a5..2b2052d85e7 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -15,8 +15,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Tracing.Tracers - ( BlockchainCounters - , Tracers (..) + ( Tracers (..) , TraceOptions , mkTracers , nullTracers @@ -31,7 +30,6 @@ import GHC.Clock (getMonotonicTimeNSec) import Codec.CBOR.Read (DeserialiseFailure) import Data.Aeson (ToJSON (..), Value (..)) import qualified Data.HashMap.Strict as Map -import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) import qualified Data.Text as Text import Network.Mux (MuxTrace, WithMuxBearer) import qualified Network.Socket as Socket (SockAddr) @@ -68,7 +66,7 @@ import Ouroboros.Consensus.Protocol.Abstract (ValidationErr) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (BlockNo (..), HasHeader (..), Point, StandardHash, - blockNo, pointSlot, unBlockNo, unSlotNo) + blockNo, pointSlot, unBlockNo) import Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..)) import Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecline (..)) import qualified Ouroboros.Network.NodeToClient as NtC @@ -83,8 +81,7 @@ import Cardano.Tracing.Config import Cardano.Tracing.Constraints (TraceConstraints) import Cardano.Tracing.ConvertTxId (ConvertTxId) import Cardano.Tracing.Kernel -import Cardano.Tracing.Metrics (HasKESMetricsData (..), KESMetricsData (..), - MaxKESEvolutions (..), OperationalCertStartKESPeriod (..)) +import Cardano.Tracing.Metrics import Cardano.Tracing.MicroBenchmarking import Cardano.Tracing.Queries @@ -254,19 +251,6 @@ instance (StandardHash header, Eq peer) => ElidingTracer traceWith (toLogObject' tverb tr) ev return (Just ev, count + 1) --- | This structure stores counters of blockchain-related events. --- These values will be traced periodically. -data BlockchainCounters = BlockchainCounters - { bcTxsProcessedNum :: !Word64 - , bcBlocksForgedNum :: !Word64 - , bcNodeCannotForgeNum :: !Word64 - , bcNodeIsLeaderNum :: !Word64 - , bcSlotsMissedNum :: !Word64 - } - -initialBlockchainCounters :: BlockchainCounters -initialBlockchainCounters = BlockchainCounters 0 0 0 0 0 - -- | Tracers for all system components. -- mkTracers @@ -282,8 +266,8 @@ mkTracers -> NodeKernelData blk -> IO (Tracers peer localPeer blk) mkTracers tOpts@(TracingOn trSel) tr nodeKern = do - bcCounters :: IORef BlockchainCounters <- newIORef initialBlockchainCounters - consensusTracers <- mkConsensusTracers trSel verb tr nodeKern bcCounters + fStats <- mkForgingStats + consensusTracers <- mkConsensusTracers trSel verb tr nodeKern fStats elidedChainDB <- newstate -- for eliding messages in ChainDB tracer pure Tracers @@ -438,9 +422,9 @@ mkConsensusTracers -> TracingVerbosity -> Trace IO Text -> NodeKernelData blk - -> IORef BlockchainCounters + -> ForgingStats -> IO (Consensus.Tracers' peer localPeer blk (Tracer IO)) -mkConsensusTracers trSel verb tr nodeKern bcCounters = do +mkConsensusTracers trSel verb tr nodeKern fStats = do blockForgeOutcomeExtractor <- mkOutcomeExtractor elidedFetchDecision <- newstate -- for eliding messages in FetchDecision tr forgeTracers <- mkForgeTracers @@ -454,12 +438,11 @@ mkConsensusTracers trSel verb tr nodeKern bcCounters = do , Consensus.blockFetchClientTracer = tracerOnOff (traceBlockFetchClient trSel) verb "BlockFetchClient" tr , Consensus.blockFetchServerTracer = tracerOnOff (traceBlockFetchServer trSel) verb "BlockFetchServer" tr , Consensus.forgeStateInfoTracer = tracerOnOff' (traceForgeStateInfo trSel) $ - contramap (\(Consensus.TraceLabelCreds _ ev) -> ev) $ forgeStateInfoTracer (Proxy @ blk) trSel tr , Consensus.txInboundTracer = tracerOnOff (traceTxInbound trSel) verb "TxInbound" tr , Consensus.txOutboundTracer = tracerOnOff (traceTxOutbound trSel) verb "TxOutbound" tr , Consensus.localTxSubmissionServerTracer = tracerOnOff (traceLocalTxSubmissionServer trSel) verb "LocalTxSubmissionServer" tr - , Consensus.mempoolTracer = tracerOnOff' (traceMempool trSel) $ mempoolTracer trSel tr bcCounters + , Consensus.mempoolTracer = tracerOnOff' (traceMempool trSel) $ mempoolTracer trSel tr fStats , Consensus.forgeTracer = tracerOnOff' (traceForge trSel) $ Tracer $ \tlcev@(Consensus.TraceLabelCreds _ ev) -> do traceWith (annotateSeverity @@ -611,7 +594,6 @@ teeForge' tr = forgeTracer :: ( Consensus.RunNode blk - , LedgerQueries blk , ToObject (CannotForge blk) , ToObject (LedgerErr (LedgerState blk)) , ToObject (OtherHeaderEnvelopeError blk) @@ -621,66 +603,53 @@ forgeTracer => TracingVerbosity -> Trace IO Text -> ForgeTracers - -> NodeKernelData blk - -> IORef BlockchainCounters - -> Tracer IO (Consensus.TraceForgeEvent blk) -forgeTracer verb tr forgeTracers nodeKern bcCounters = - Tracer $ \ev -> do + -> ForgingStats + -> Tracer IO (Consensus.TraceLabelCreds (Consensus.TraceForgeEvent blk)) +forgeTracer verb tr forgeTracers fStats = + Tracer $ \tlcev@(Consensus.TraceLabelCreds _ ev) -> do + -- Ignoring the credentials label for measurement and counters: traceWith (measureTxsEnd tr) ev - traceWith (notifyBlockForging bcCounters tr) ev - traceWith (notifySlotsMissedIfNeeded bcCounters tr) ev - -- Consensus tracer + traceWith (notifyBlockForging fStats tr) ev + -- Consensus tracer -- here we track the label: traceWith (annotateSeverity - $ teeForge forgeTracers nodeKern verb - $ appendName "Forge" tr) ev + $ teeForge forgeTracers verb + $ appendName "Forge" tr) tlcev notifyBlockForging - :: IORef BlockchainCounters + :: ForgingStats -> Trace IO Text -> Tracer IO (Consensus.TraceForgeEvent blk) -notifyBlockForging bcCounters tr = Tracer $ \case - Consensus.TraceForgedBlock {} -> do - updatedBlocksForged <- atomicModifyIORef' bcCounters (\cnts -> let nc = bcBlocksForgedNum cnts + 1 - in (cnts { bcBlocksForgedNum = nc }, nc) - ) - traceCounter "blocksForgedNum" updatedBlocksForged tr - Consensus.TraceNodeCannotForge {} -> do - -- It means that node have tried to forge new block, but because of misconfiguration - -- (for example, invalid key) it's impossible. - updatedNodeCannotForge <- atomicModifyIORef' bcCounters $ \cnts -> - let nc = bcNodeCannotForgeNum cnts + 1 - in (cnts { bcNodeCannotForgeNum = nc }, nc) - traceCounter "nodeCannotForge" updatedNodeCannotForge tr - -- The rest of the constructors. - _ -> pure () - -notifySlotsMissedIfNeeded - :: IORef BlockchainCounters - -> Trace IO Text - -> Tracer IO (Consensus.TraceForgeEvent blk) -notifySlotsMissedIfNeeded bcCounters tr = Tracer $ \case - Consensus.TraceNodeIsLeader {} -> do - updatedNodeIsLeaderNum <- atomicModifyIORef' bcCounters (\cnts -> let nc = bcNodeIsLeaderNum cnts + 1 - in (cnts { bcNodeIsLeaderNum = nc }, nc) - ) - traceCounter "nodeIsLeaderNum" updatedNodeIsLeaderNum tr - Consensus.TraceNodeNotLeader {} -> do +notifyBlockForging fStats tr = Tracer $ \case + Consensus.TraceNodeCannotForge {} -> + traceCounter "nodeCannotForge" tr + =<< mapForgingCurrentThreadStats fStats + (\fts -> (fts { ftsNodeCannotForgeNum = ftsNodeCannotForgeNum fts + 1 }, + ftsNodeCannotForgeNum fts + 1)) + Consensus.TraceNodeIsLeader{} -> + traceCounter "nodeIsLeaderNum" tr + =<< mapForgingCurrentThreadStats fStats + (\fts -> (fts { ftsNodeIsLeaderNum = ftsNodeIsLeaderNum fts + 1 }, + ftsNodeIsLeaderNum fts + 1)) + Consensus.TraceForgedBlock {} -> + traceCounter "blocksForgedNum" tr + =<< mapForgingCurrentThreadStats fStats + (\fts -> (fts { ftsBlocksForgedNum = ftsBlocksForgedNum fts + 1 }, + ftsBlocksForgedNum fts + 1)) + Consensus.TraceNodeNotLeader (SlotNo slot') -> do -- Not is not a leader again, so now the number of blocks forged by this node -- should be equal to the number of slots when this node was a leader. - counters <- readIORef bcCounters - let howManyBlocksWereForged = bcBlocksForgedNum counters - timesNodeWasALeader = bcNodeIsLeaderNum counters - numberOfMissedSlots = timesNodeWasALeader - howManyBlocksWereForged - if numberOfMissedSlots > 0 - then do - -- Node was a leader more times than the number of forged blocks, - -- it means that some slots were missed. - updatesSlotsMissed <- atomicModifyIORef' bcCounters (\cnts -> let nc = bcSlotsMissedNum cnts + numberOfMissedSlots - in (cnts { bcSlotsMissedNum = nc }, nc) - ) - traceCounter "slotsMissedNum" updatesSlotsMissed tr - else return () - -- The rest of the constructors. + let slot = fromIntegral slot' + hasMissed <- + mapForgingCurrentThreadStats fStats + (\fts -> + if ftsLastSlot fts == 0 || succ (ftsLastSlot fts) == slot then + (fts { ftsLastSlot = slot }, False) + else + let missed = ftsSlotsMissedNum fts + (slot - ftsLastSlot fts) + in (fts { ftsLastSlot = slot, ftsSlotsMissedNum = missed }, True)) + when hasMissed $ do + x <- sum <$> threadStatsProjection fStats ftsSlotsMissedNum + traceCounter "slotsMissedNum" tr x _ -> pure () @@ -688,17 +657,15 @@ notifySlotsMissedIfNeeded bcCounters tr = Tracer $ \case -- Mempool Tracers -------------------------------------------------------------------------------- -notifyTxsProcessed :: IORef BlockchainCounters -> Trace IO Text -> Tracer IO (TraceEventMempool blk) -notifyTxsProcessed bcCounters tr = Tracer $ \case +notifyTxsProcessed :: ForgingStats -> Trace IO Text -> Tracer IO (TraceEventMempool blk) +notifyTxsProcessed fStats tr = Tracer $ \case TraceMempoolRemoveTxs [] _ -> return () TraceMempoolRemoveTxs txs _ -> do -- TraceMempoolRemoveTxs are previously valid transactions that are no longer valid because of -- changes in the ledger state. These transactions are already removed from the mempool, -- so we can treat them as completely processed. - updatedTxProcessed <- atomicModifyIORef' bcCounters (\cnts -> let nc = bcTxsProcessedNum cnts + fromIntegral (length txs) - in (cnts { bcTxsProcessedNum = nc }, nc) - ) - traceCounter "txsProcessedNum" updatedTxProcessed tr + updatedTxProcessed <- mapForgingStatsTxsProcessed fStats (+ (length txs)) + traceCounter "txsProcessedNum" tr (fromIntegral updatedTxProcessed) -- The rest of the constructors. _ -> return () @@ -727,11 +694,11 @@ mempoolTracer ) => TraceSelection -> Trace IO Text - -> IORef BlockchainCounters + -> ForgingStats -> Tracer IO (TraceEventMempool blk) -mempoolTracer tc tracer bChainCounters = Tracer $ \ev -> do +mempoolTracer tc tracer fStats = Tracer $ \ev -> do traceWith (mempoolMetricsTraceTransformer tracer) ev - traceWith (notifyTxsProcessed bChainCounters tracer) ev + traceWith (notifyTxsProcessed fStats tracer) ev traceWith (measureTxsStart tracer) ev let tr = appendName "Mempool" tracer traceWith (mpTracer tc tr) ev @@ -926,12 +893,17 @@ chainInformation -> AF.AnchoredFragment (Header blk) -> ChainInformation chainInformation newTipInfo frag = ChainInformation - { slots = slotN - , blocks = blockN - , density = calcDensity blockD slotD + { slots = unSlotNo $ fromWithOrigin 0 (AF.headSlot frag) + , blocks = unBlockNo $ fromWithOrigin (BlockNo 1) (AF.headBlockNo frag) + , density = fragmentChainDensity frag , epoch = ChainDB.newTipEpoch newTipInfo , slotInEpoch = ChainDB.newTipSlotInEpoch newTipInfo } + +fragmentChainDensity :: + HasHeader (Header blk) + => AF.AnchoredFragment (Header blk) -> Rational +fragmentChainDensity frag = calcDensity blockD slotD where calcDensity :: Word64 -> Word64 -> Rational calcDensity bl sl @@ -968,10 +940,10 @@ readableTraceBlockchainTimeEvent ev = case ev of traceCounter :: Text - -> Word64 -> Trace IO Text + -> Int -> IO () -traceCounter logValueName aCounter tracer = do +traceCounter logValueName tracer aCounter = do meta <- mkLOMeta Notice Public traceNamedObject (appendName "metrics" tracer) (meta, LogValue logValueName (PureI $ fromIntegral aCounter))