Skip to content

Commit

Permalink
trace dreps: do not
Browse files Browse the repository at this point in the history
  • Loading branch information
mgmeier committed Jun 1, 2024
1 parent 549d015 commit ded7304
Show file tree
Hide file tree
Showing 2 changed files with 66 additions and 47 deletions.
9 changes: 2 additions & 7 deletions cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
104 changes: 64 additions & 40 deletions cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,3 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
Expand All @@ -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)
Expand All @@ -40,8 +45,6 @@ data TraceStartLeadershipCheckPlus =
tsSlotNo :: SlotNo
, tsUtxoSize :: Int
, tsDelegMapSize :: Int
, tsDRepCount :: Int
, tsDRepMapSize :: Int
, tsChainDensity :: Double
}

Expand All @@ -55,41 +58,47 @@ 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
(AF.HasHeader blk, AF.HasHeader (Header blk))
#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
Expand All @@ -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

0 comments on commit ded7304

Please sign in to comment.