From ded73047a188cbdb1c615348fa811673a15e722d Mon Sep 17 00:00:00 2001 From: Michael Karg Date: Thu, 30 May 2024 09:12:48 +0200 Subject: [PATCH] trace dreps: do not --- .../Cardano/Node/Tracing/Tracers/Consensus.hs | 9 +- .../Tracing/Tracers/StartLeadershipCheck.hs | 104 +++++++++++------- 2 files changed, 66 insertions(+), 47 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs index e4c932e040d..4bdde045890 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -1151,21 +1151,16 @@ instance LogFormatting TraceStartLeadershipCheckPlus where , "utxoSize" .= Number (fromIntegral tsUtxoSize) , "delegMapSize" .= Number (fromIntegral tsDelegMapSize) , "chainDensity" .= Number (fromRational (toRational tsChainDensity)) - , "dRepCount" .= Number (fromIntegral tsDRepCount) - , "dRepMapSize" .= Number (fromIntegral tsDRepMapSize) ] forHuman TraceStartLeadershipCheckPlus {..} = "Checking for leadership in slot " <> showT (unSlotNo tsSlotNo) <> " utxoSize " <> showT tsUtxoSize <> " delegMapSize " <> showT tsDelegMapSize <> " chainDensity " <> showT tsChainDensity - <> " dRepCount " <> showT tsDRepCount - <> " dRepMapSize " <> showT tsDRepMapSize asMetrics TraceStartLeadershipCheckPlus {..} = [IntM "Forge.UtxoSize" (fromIntegral tsUtxoSize), - IntM "Forge.DelegMapSize" (fromIntegral tsDelegMapSize), - IntM "Forge.DRepCount" (fromIntegral tsDRepCount), - IntM "Forge.DRepMapSize" (fromIntegral tsDRepMapSize)] + IntM "Forge.DelegMapSize" (fromIntegral tsDelegMapSize)] + -------------------------------------------------------------------------------- -- ForgeEvent Tracer diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs index eac9ca39c3c..b3d5bb810a9 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -13,23 +12,29 @@ module Cardano.Node.Tracing.Tracers.StartLeadershipCheck ) where -import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import Cardano.Logging -import Cardano.Node.Queries (LedgerQueries (..), NodeKernelData (..)) -import Cardano.Slotting.Slot (fromWithOrigin) + +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 (ledgerState) +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 qualified Ouroboros.Network.AnchoredFragment as AF -import Ouroboros.Network.Block (BlockNo (..), blockNo, unBlockNo) -import Control.Concurrent.STM (atomically) -import Data.IORef (readIORef) -import Data.Word (Word64) +import Cardano.Node.Queries (LedgerQueries (..), NodeKernelData (..)) +import Cardano.Slotting.Slot (fromWithOrigin) + +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) type ForgeTracerType blk = Either (TraceForgeEvent blk) @@ -40,8 +45,6 @@ data TraceStartLeadershipCheckPlus = tsSlotNo :: SlotNo , tsUtxoSize :: Int , tsDelegMapSize :: Int - , tsDRepCount :: Int - , tsDRepMapSize :: Int , tsChainDensity :: Double } @@ -55,32 +58,38 @@ forgeTracerTransform :: => NodeKernelData blk -> Trace IO (ForgeTracerType blk) -> IO (Trace IO (ForgeTracerType blk)) -forgeTracerTransform (NodeKernelData ref) (Trace tr) = - let secondM f (x, y) = do -- avoiding new dep on extra pkg - y' <- f y - pure (x, y') - in contramapM (Trace tr) $ secondM - \case - Right (Left slc@(TraceStartLeadershipCheck tsSlotNo)) -> do - query <- readIORef ref >>= traverse - \NodeKernel{getChainDB} -> do - ledger <- fmap ledgerState . atomically $ - ChainDB.getCurrentLedger getChainDB - chain <- atomically $ ChainDB.getCurrentChain getChainDB - pure TraceStartLeadershipCheckPlus { - tsSlotNo - , tsUtxoSize = ledgerUtxoSize ledger - , tsDelegMapSize = ledgerDelegMapSize ledger - , tsDRepCount = ledgerDRepCount ledger - , tsDRepMapSize = ledgerDRepMapSize ledger - , tsChainDensity = fragmentChainDensity chain } - pure . Right $ case query of - SNothing -> Left slc - SJust tslcp -> Right tslcp - Right a -> - pure $ Right a - Left control -> - pure $ Left control +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 @@ -88,8 +97,8 @@ fragmentChainDensity :: #else AF.HasHeader (Header blk) #endif - => AF.AnchoredFragment (Header blk) -> Double -fragmentChainDensity frag = fromRational $ calcDensity blockD slotD + => AF.AnchoredFragment (Header blk) -> Rational +fragmentChainDensity frag = calcDensity blockD slotD where calcDensity :: Word64 -> Word64 -> Rational calcDensity bl sl @@ -110,3 +119,18 @@ fragmentChainDensity frag = fromRational $ calcDensity blockD slotD -- 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