From 8d1ed1241b3c052bded71f40dc5c7caa52c5939b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=BCrgen=20Nicklisch-Franken?= Date: Thu, 9 Jan 2025 17:24:11 +0100 Subject: [PATCH] cardano-node: Started LedgerQuery tracer replaces StartLeadershipPlus --- cardano-node/cardano-node.cabal | 2 +- .../src/Cardano/Node/Tracing/Consistency.hs | 8 +- .../src/Cardano/Node/Tracing/Documentation.hs | 14 +- .../src/Cardano/Node/Tracing/Tracers.hs | 21 +-- .../Cardano/Node/Tracing/Tracers/ChainDB.hs | 1 + .../Cardano/Node/Tracing/Tracers/Consensus.hs | 100 +------------ .../Tracing/Tracers/ForgingThreadStats.hs | 28 ++-- .../Node/Tracing/Tracers/LedgerQuery.hs | 85 +++++++++++ .../Tracing/Tracers/StartLeadershipCheck.hs | 136 ------------------ 9 files changed, 122 insertions(+), 273 deletions(-) create mode 100644 cardano-node/src/Cardano/Node/Tracing/Tracers/LedgerQuery.hs delete mode 100644 cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index de9617d7365..d5ade5d6b5d 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -111,6 +111,7 @@ library Cardano.Node.Tracing.Tracers.Diffusion Cardano.Node.Tracing.Tracers.ForgingThreadStats Cardano.Node.Tracing.Tracers.KESInfo + Cardano.Node.Tracing.Tracers.LedgerQuery Cardano.Node.Tracing.Tracers.NodeToClient Cardano.Node.Tracing.Tracers.NodeToNode Cardano.Node.Tracing.Tracers.NodeVersion @@ -119,7 +120,6 @@ library Cardano.Node.Tracing.Tracers.Peer Cardano.Node.Tracing.Tracers.Resources Cardano.Node.Tracing.Tracers.Shutdown - Cardano.Node.Tracing.Tracers.StartLeadershipCheck Cardano.Node.Tracing.Tracers.Startup Cardano.Node.Types Cardano.Tracing.Config diff --git a/cardano-node/src/Cardano/Node/Tracing/Consistency.hs b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs index a2e4aa6bb35..74cd1635475 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Consistency.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs @@ -22,13 +22,11 @@ import Cardano.Node.Tracing.Documentation (docTracersFirstPhase) import Cardano.Node.Tracing.Formatting () import qualified Cardano.Node.Tracing.StateRep as SR import Cardano.Node.Tracing.Tracers.BlockReplayProgress -import Cardano.Node.Tracing.Tracers.Consensus import Cardano.Node.Tracing.Tracers.Diffusion () import Cardano.Node.Tracing.Tracers.KESInfo () import Cardano.Node.Tracing.Tracers.NodeToClient () import Cardano.Node.Tracing.Tracers.NodeToNode () import Cardano.Node.Tracing.Tracers.NodeVersion (NodeVersionTrace) - import Cardano.Node.Tracing.Tracers.NonP2P () import Cardano.Node.Tracing.Tracers.P2P () import Cardano.Node.Tracing.Tracers.Peer @@ -179,8 +177,8 @@ getAllNamespaces = (TraceLocalTxSubmissionServerEvent blk)]) mempoolNS = map (nsGetTuple . nsReplacePrefix ["Mempool"]) (allNamespaces :: [Namespace (TraceEventMempool blk)]) - forgeNS = map (nsGetTuple . nsReplacePrefix ["Forge", "Loop"]) - (allNamespaces :: [Namespace (ForgeTracerType blk)]) + -- forgeNS = map (nsGetTuple . nsReplacePrefix ["Forge", "Loop"]) + -- (allNamespaces :: [Namespace (ForgeTracerType blk)]) TODO YUP blockchainTimeNS = map (nsGetTuple . nsReplacePrefix ["BlockchainTime"]) (allNamespaces :: [Namespace (TraceBlockchainTimeEvent RelativeTime)]) @@ -388,7 +386,7 @@ getAllNamespaces = <> txOutboundNS <> localTxSubmissionServerNS <> mempoolNS - <> forgeNS +-- <> forgeNS TODO YUP <> blockchainTimeNS -- NodeToClient <> keepAliveClientNS diff --git a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs index e217afba03d..b97210604ad 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs @@ -355,12 +355,12 @@ docTracersFirstPhase condConfigFileName = do mempoolTrDoc <- documentTracer (mempoolTr :: Trace IO (TraceEventMempool blk)) - forgeTr <- mkCardanoTracer - trBase trForward mbTrEKG - ["Forge", "Loop"] - configureTracers configReflection trConfig [forgeTr] - forgeTrDoc <- documentTracer (forgeTr :: - Trace IO (ForgeTracerType blk)) + -- forgeTr <- mkCardanoTracer + -- trBase trForward mbTrEKG + -- ["Forge", "Loop"] + -- configureTracers configReflection trConfig [forgeTr] + -- -- forgeTrDoc <- documentTracer (forgeTr :: + -- -- Trace IO (ForgeTracerType blk)) TODO YUP forgeTr' <- mkCardanoTracer @@ -718,7 +718,7 @@ docTracersFirstPhase condConfigFileName = do <> txOutboundTrDoc <> localTxSubmissionServerTrDoc <> mempoolTrDoc - <> forgeTrDoc +-- <> forgeTrDoc TODO YUP <> forgeThreadStatsTrDoc <> blockchainTimeTrDoc -- NodeToClient diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs index 4fab3056553..0c15e22df22 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -217,7 +217,7 @@ mkConsensusTracers :: forall blk. -> TraceConfig -> NodeKernelData blk -> IO (Consensus.Tracers IO (ConnectionId RemoteAddress) (ConnectionId LocalAddress) blk) -mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConfig nodeKernel = do +mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConfig _nodeKernel = do !chainSyncClientTr <- mkCardanoTracer trBase trForward mbTrEKG ["ChainSync", "Client"] @@ -303,11 +303,11 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf ["Mempool"] configureTracers configReflection trConfig [mempoolTr] - !forgeTr <- mkCardanoTracer' - trBase trForward mbTrEKG - ["Forge", "Loop"] - (forgeTracerTransform nodeKernel) - configureTracers configReflection trConfig [forgeTr] + -- !forgeTr <- mkCardanoTracer' + -- trBase trForward mbTrEKG + -- ["Forge", "Loop"] + -- (forgeTracerTransform nodeKernel) + -- configureTracers configReflection trConfig [forgeTr] TODO YUP !forgeThreadStatsTr <- mkCardanoTracer' trBase trForward mbTrEKG @@ -365,10 +365,11 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf traceWith localTxSubmissionServerTr , Consensus.mempoolTracer = Tracer $ traceWith mempoolTr - , Consensus.forgeTracer = - Tracer (\(Consensus.TraceLabelCreds _ x) -> traceWith (contramap Left forgeTr) x) - <> - Tracer (\(Consensus.TraceLabelCreds _ x) -> traceWith (contramap Left forgeThreadStatsTr) x) + , Consensus.forgeTracer = mempty + -- , Consensus.forgeTracer = + -- Tracer (\(Consensus.TraceLabelCreds _ x) -> traceWith forgeTr x) //TODO YUP + -- <> + -- Tracer (\(Consensus.TraceLabelCreds _ x) -> traceWith forgeThreadStatsTr x) , Consensus.blockchainTimeTracer = Tracer $ traceWith blockchainTimeTr , Consensus.keepAliveClientTracer = Tracer $ diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index 696c710fdcc..b748f4883f8 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -11,6 +11,7 @@ module Cardano.Node.Tracing.Tracers.ChainDB ( withAddedToCurrentChainEmptyLimited + , fragmentChainDensity ) where import Cardano.Logging diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs index 38d8b141c6d..35061de52d9 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -14,10 +14,7 @@ module Cardano.Node.Tracing.Tracers.Consensus ( - TraceStartLeadershipCheckPlus (..) - , ForgeTracerType - , forgeTracerTransform - , initialClientMetrics + initialClientMetrics , calculateBlockFetchClientMetrics , servedBlockLatest , ClientMetrics @@ -31,7 +28,6 @@ import Cardano.Node.Tracing.Era.Shelley () import Cardano.Node.Tracing.Formatting () import Cardano.Node.Tracing.Render import Cardano.Node.Tracing.Tracers.ConsensusStartupException () -import Cardano.Node.Tracing.Tracers.StartLeadershipCheck import Cardano.Protocol.TPraos.OCert (KESPeriod (..)) import Cardano.Slotting.Slot (WithOrigin (..)) import Ouroboros.Consensus.Block @@ -1359,100 +1355,6 @@ instance MetaTrace (TraceEventMempool blk) where , Namespace [] ["Synced"] ] --------------------------------------------------------------------------------- --- ForgeTracerType --------------------------------------------------------------------------------- - -instance ( tx ~ GenTx blk - , ConvertRawHash blk - , GetHeader blk - , HasHeader blk - , HasKESInfo blk - , LedgerSupportsProtocol blk - , LedgerSupportsMempool blk - , SerialiseNodeToNodeConstraints blk - , HasTxId (GenTx blk) - , Show (ForgeStateUpdateError blk) - , Show (CannotForge blk) - , LogFormatting (InvalidBlockReason blk) - , LogFormatting (CannotForge blk) - , LogFormatting (ForgeStateUpdateError blk)) - => LogFormatting (ForgeTracerType blk) where - forMachine dtal (Left i) = forMachine dtal i - forMachine dtal (Right i) = forMachine dtal i - forHuman (Left i) = forHumanOrMachine i - forHuman (Right i) = forHumanOrMachine i - asMetrics (Left i) = asMetrics i - asMetrics (Right i) = asMetrics i - -instance MetaTrace (ForgeTracerType blk) where - namespaceFor (Left ev) = - nsCast (namespaceFor ev) - namespaceFor (Right _ev) = - Namespace [] ["StartLeadershipCheckPlus"] - - severityFor (Namespace _ ["StartLeadershipCheckPlus"]) _ = Just - Info - severityFor ns (Just (Left ev')) = - severityFor (nsCast ns) (Just ev') - severityFor ns Nothing = - severityFor (nsCast ns :: Namespace (TraceForgeEvent blk)) Nothing - severityFor _ _ = Nothing - - detailsFor (Namespace _ ["StartLeadershipCheckPlus"]) _ = Just - DNormal - detailsFor ns (Just (Left ev')) = - detailsFor (nsCast ns) (Just ev') - detailsFor ns Nothing = - detailsFor (nsCast ns :: Namespace (TraceForgeEvent blk)) Nothing - detailsFor _ _ = Nothing - - privacyFor (Namespace _ ["StartLeadershipCheckPlus"]) _ = Just - Public - privacyFor ns (Just (Left ev')) = - privacyFor (nsCast ns) (Just ev') - privacyFor ns Nothing = - privacyFor (nsCast ns :: Namespace (TraceForgeEvent blk)) Nothing - privacyFor _ _ = Nothing - - metricsDocFor (Namespace _ ["StartLeadershipCheckPlus"]) = - [ ("Forge.UtxoSize", "UTxO set size") - , ("Forge.DelegMapSize", "Delegation map size") - ] - metricsDocFor ns = - metricsDocFor (nsCast ns :: Namespace (TraceForgeEvent blk)) - - documentFor (Namespace _ ["StartLeadershipCheckPlus"]) = Just $ mconcat - [ "We adopted the block we produced, we also trace the transactions" - , " that were adopted." - ] - documentFor ns = - documentFor (nsCast ns :: Namespace (TraceForgeEvent blk)) - - allNamespaces = - Namespace [] ["StartLeadershipCheckPlus"] - : map nsCast (allNamespaces :: [Namespace (TraceForgeEvent blk)]) - --------------------------------------------------------------------------------- --- TraceStartLeadershipCheck --------------------------------------------------------------------------------- - -instance LogFormatting TraceStartLeadershipCheckPlus where - forMachine _dtal TraceStartLeadershipCheckPlus {..} = - mconcat [ "kind" .= String "TraceStartLeadershipCheck" - , "slot" .= toJSON (unSlotNo tsSlotNo) - , "utxoSize" .= Number (fromIntegral tsUtxoSize) - , "delegMapSize" .= Number (fromIntegral tsDelegMapSize) - , "chainDensity" .= Number (fromRational (toRational tsChainDensity)) - ] - forHuman TraceStartLeadershipCheckPlus {..} = - "Checking for leadership in slot " <> showT (unSlotNo tsSlotNo) - <> " utxoSize " <> showT tsUtxoSize - <> " delegMapSize " <> showT tsDelegMapSize - <> " chainDensity " <> showT tsChainDensity - asMetrics TraceStartLeadershipCheckPlus {..} = - [IntM "utxoSize" (fromIntegral tsUtxoSize), - IntM "delegMapSize" (fromIntegral tsDelegMapSize)] -------------------------------------------------------------------------------- diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ForgingThreadStats.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ForgingThreadStats.hs index 21841012203..62fb0e5f2de 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ForgingThreadStats.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ForgingThreadStats.hs @@ -10,7 +10,6 @@ module Cardano.Node.Tracing.Tracers.ForgingThreadStats ) where import Cardano.Logging -import Cardano.Node.Tracing.Tracers.StartLeadershipCheck (ForgeTracerType) import Cardano.Slotting.Slot (SlotNo (..)) import Ouroboros.Consensus.Node.Tracers import qualified Ouroboros.Consensus.Node.Tracers as Consensus @@ -155,31 +154,30 @@ emptyForgingStats :: ForgingStats emptyForgingStats = ForgingStats mempty 0 0 0 0 forgeThreadStats :: Trace IO ForgingStats - -> IO (Trace IO (ForgeTracerType blk)) + -> IO (Trace IO (TraceForgeEvent blk)) forgeThreadStats tr = - let tr' = contramap unfold tr - in foldCondTraceM calculateThreadStats emptyForgingStats - (\case - Left Consensus.TraceStartLeadershipCheck{} -> True - Left _ -> False - Right _ -> True - ) - tr' + let tr' = contramap unfold tr + in foldCondTraceM calculateThreadStats emptyForgingStats + (\case + Consensus.TraceStartLeadershipCheck{} -> True + _ -> False + ) + tr' calculateThreadStats :: MonadIO m => ForgingStats -> LoggingContext - -> ForgeTracerType blk + -> TraceForgeEvent blk -> m ForgingStats calculateThreadStats stats _context - (Left TraceNodeCannotForge {}) = do + (TraceNodeCannotForge {}) = do mapThreadStats stats (\fts -> (fts { ftsNodeCannotForgeNum = ftsNodeCannotForgeNum fts + 1} , Nothing)) (\fs _ -> (fs { fsNodeCannotForgeNum = fsNodeCannotForgeNum fs + 1 })) calculateThreadStats stats _context - (Left (TraceNodeIsLeader (SlotNo slot'))) = do + (TraceNodeIsLeader (SlotNo slot')) = do let slot = fromIntegral slot' mapThreadStats stats @@ -187,14 +185,14 @@ calculateThreadStats stats _context , ftsLastSlot = slot}, Nothing)) (\fs _ -> (fs { fsNodeIsLeaderNum = fsNodeIsLeaderNum fs + 1 })) calculateThreadStats stats _context - (Left TraceForgedBlock {}) = do + (TraceForgedBlock {}) = do mapThreadStats stats (\fts -> (fts { ftsBlocksForgedNum = ftsBlocksForgedNum fts + 1} , Nothing)) (\fs _ -> (fs { fsBlocksForgedNum = fsBlocksForgedNum fs + 1 })) calculateThreadStats stats _context - (Left (TraceNodeNotLeader (SlotNo slot'))) = do + (TraceNodeNotLeader (SlotNo slot')) = do let slot = fromIntegral slot' mapThreadStats stats diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/LedgerQuery.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/LedgerQuery.hs new file mode 100644 index 00000000000..5e1488edb62 --- /dev/null +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/LedgerQuery.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} + +module Cardano.Node.Tracing.Tracers.LedgerQuery + ( TraceLedgerQuery (..) + , traceLedgerQuery + ) where + + +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) +import Cardano.Logging +import Cardano.Node.Queries (LedgerQueries (..), NodeKernelData (..), mapNodeKernelDataIO, + nkQueryChain, nkQueryLedger) +import Cardano.Node.Tracing.Tracers.ChainDB (fragmentChainDensity) +import Ouroboros.Consensus.HardFork.Combinator +import Ouroboros.Consensus.Ledger.Abstract (IsLedger) +import Ouroboros.Consensus.Ledger.Extended (ledgerState) +import qualified Ouroboros.Network.AnchoredFragment as AF + +import Data.Aeson (Value (Number, String), (.=)) + + +data TraceLedgerQuery = + TraceLedgerQuery { + -- tsSlotNo :: SlotNo + tsUtxoSize :: Int + , tsDelegMapSize :: Int + , tsChainDensity :: Double + } + +traceLedgerQuery :: + ( IsLedger (LedgerState blk) + , LedgerQueries blk +#if __GLASGOW_HASKELL__ >= 906 + , AF.HasHeader blk +#endif + , AF.HasHeader (Header blk)) + => NodeKernelData blk + -> Trace IO TraceLedgerQuery + -> IO () +traceLedgerQuery nodeKern tracer = do + query <- mapNodeKernelDataIO + (\nk -> + (,,) + <$> nkQueryLedger (ledgerUtxoSize . ledgerState) nk + <*> nkQueryLedger (ledgerDelegMapSize . ledgerState) nk + <*> nkQueryChain fragmentChainDensity nk) + nodeKern + case query of + SNothing -> pure () + SJust (utxoSize, delegMapSize, chainDensity) -> + let msg = TraceLedgerQuery + utxoSize + delegMapSize + (fromRational chainDensity) + in traceWith tracer msg + +-------------------------------------------------------------------------------- +-- TraceStartLeadershipCheck +-------------------------------------------------------------------------------- + +instance LogFormatting TraceLedgerQuery where + forMachine _dtal TraceLedgerQuery {..} = + mconcat [ "kind" .= String "TraceLedgerQuery" + -- , "slot" .= toJSON (unSlotNo tsSlotNo) + , "utxoSize" .= Number (fromIntegral tsUtxoSize) + , "delegMapSize" .= Number (fromIntegral tsDelegMapSize) + , "chainDensity" .= Number (fromRational (toRational tsChainDensity)) + ] + forHuman TraceLedgerQuery {..} = + "Querying ledger " -- <> showT (unSlotNo tsSlotNo) + <> " utxoSize " <> showT tsUtxoSize + <> " delegMapSize " <> showT tsDelegMapSize + <> " chainDensity " <> showT tsChainDensity + asMetrics TraceLedgerQuery {..} = + [IntM "utxoSize" (fromIntegral tsUtxoSize), + IntM "delegMapSize" (fromIntegral tsDelegMapSize)] + + + + + diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs deleted file mode 100644 index b3d5bb810a9..00000000000 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Cardano.Node.Tracing.Tracers.StartLeadershipCheck - ( TraceStartLeadershipCheckPlus (..) - , ForgeTracerType - , forgeTracerTransform - ) where - - -import Cardano.Logging - -import Control.Concurrent.STM (atomically) -import Data.IORef (readIORef) -import Data.Word (Word64) - -import qualified Ouroboros.Network.AnchoredFragment as AF -import Ouroboros.Network.Block (BlockNo (..), blockNo, unBlockNo) -import Ouroboros.Network.NodeToClient (LocalConnectionId) -import Ouroboros.Network.NodeToNode (RemoteAddress) - -import Ouroboros.Consensus.Block (SlotNo (..)) -import Ouroboros.Consensus.HardFork.Combinator -import Ouroboros.Consensus.Ledger.Abstract (IsLedger) -import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState, ledgerState) -import Ouroboros.Consensus.Node (NodeKernel (..)) -import Ouroboros.Consensus.Node.Tracers -import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB - -import Cardano.Node.Queries (LedgerQueries (..), NodeKernelData (..)) -import Cardano.Slotting.Slot (fromWithOrigin) - -import Cardano.Ledger.BaseTypes (StrictMaybe (..)) - - -type ForgeTracerType blk = Either (TraceForgeEvent blk) - TraceStartLeadershipCheckPlus - -data TraceStartLeadershipCheckPlus = - TraceStartLeadershipCheckPlus { - tsSlotNo :: SlotNo - , tsUtxoSize :: Int - , tsDelegMapSize :: Int - , tsChainDensity :: Double - } - -forgeTracerTransform :: - ( IsLedger (LedgerState blk) - , LedgerQueries blk -#if __GLASGOW_HASKELL__ >= 906 - , AF.HasHeader blk -#endif - , AF.HasHeader (Header blk)) - => NodeKernelData blk - -> Trace IO (ForgeTracerType blk) - -> IO (Trace IO (ForgeTracerType blk)) -forgeTracerTransform nodeKern (Trace tr) = - contramapM (Trace tr) - (\case - (lc, Right (Left slc@(TraceStartLeadershipCheck slotNo))) -> do - query <- mapNodeKernelDataIO - (\nk -> - (,,) - <$> nkQueryLedger (ledgerUtxoSize . ledgerState) nk - <*> nkQueryLedger (ledgerDelegMapSize . ledgerState) nk - <*> nkQueryChain fragmentChainDensity nk) - nodeKern - case query of - SNothing -> pure (lc, Right (Left slc)) - SJust (utxoSize, delegMapSize, chainDensity) -> - let msg = TraceStartLeadershipCheckPlus - slotNo - utxoSize - delegMapSize - (fromRational chainDensity) - in pure (lc, Right (Right msg)) - (lc, Right a) -> - pure (lc, Right a) - (lc, Left control) -> - pure (lc, Left control)) - -nkQueryLedger :: - IsLedger (LedgerState blk) - => (ExtLedgerState blk -> a) - -> NodeKernel IO RemoteAddress LocalConnectionId blk - -> IO a -nkQueryLedger f NodeKernel{getChainDB} = - f <$> atomically (ChainDB.getCurrentLedger getChainDB) - -fragmentChainDensity :: -#if __GLASGOW_HASKELL__ >= 906 - (AF.HasHeader blk, AF.HasHeader (Header blk)) -#else - AF.HasHeader (Header blk) -#endif - => AF.AnchoredFragment (Header blk) -> Rational -fragmentChainDensity frag = calcDensity blockD slotD - where - calcDensity :: Word64 -> Word64 -> Rational - calcDensity bl sl - | sl > 0 = toRational bl / toRational sl - | otherwise = 0 - slotN = unSlotNo $ fromWithOrigin 0 (AF.headSlot frag) - -- Slot of the tip - slot @k@ blocks back. Use 0 as the slot for genesis - -- includes EBBs - slotD = slotN - - unSlotNo (fromWithOrigin 0 (AF.lastSlot frag)) - -- Block numbers start at 1. We ignore the genesis EBB, which has block number 0. - blockD = blockN - firstBlock - blockN = unBlockNo $ fromWithOrigin (BlockNo 1) (AF.headBlockNo frag) - firstBlock = case unBlockNo . blockNo <$> AF.last frag of - -- Empty fragment, no blocks. We have that @blocks = 1 - 1 = 0@ - Left _ -> 1 - -- The oldest block is the genesis EBB with block number 0, - -- don't let it contribute to the number of blocks - Right 0 -> 1 - Right b -> b - -nkQueryChain :: - (AF.AnchoredFragment (Header blk) -> a) - -> NodeKernel IO RemoteAddress LocalConnectionId blk - -> IO a -nkQueryChain f NodeKernel{getChainDB} = - f <$> atomically (ChainDB.getCurrentChain getChainDB) - - -mapNodeKernelDataIO :: - (NodeKernel IO RemoteAddress LocalConnectionId blk -> IO a) - -> NodeKernelData blk - -> IO (StrictMaybe a) -mapNodeKernelDataIO f (NodeKernelData ref) = - readIORef ref >>= traverse f