diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs index b703eee0a0..d1383c2559 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs @@ -32,6 +32,7 @@ import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server (TraceBlockFetchServerEvent) import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (TraceChainSyncClientEvent) +import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as CSJumping import Ouroboros.Consensus.MiniProtocol.ChainSync.Server (TraceChainSyncServerEvent) import Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server @@ -71,6 +72,7 @@ data Tracers' remotePeer localPeer blk f = Tracers , consensusErrorTracer :: f SomeException , gsmTracer :: f (TraceGsmEvent (Tip blk)) , gddTracer :: f (TraceGDDEvent remotePeer blk) + , csjTracer :: f (CSJumping.TraceEvent remotePeer) } instance (forall a. Semigroup (f a)) @@ -94,6 +96,7 @@ instance (forall a. Semigroup (f a)) , consensusErrorTracer = f consensusErrorTracer , gsmTracer = f gsmTracer , gddTracer = f gddTracer + , csjTracer = f csjTracer } where f :: forall a. Semigroup a @@ -125,6 +128,7 @@ nullTracers = Tracers , consensusErrorTracer = nullTracer , gsmTracer = nullTracer , gddTracer = nullTracer + , csjTracer = nullTracer } showTracers :: ( Show blk @@ -159,6 +163,7 @@ showTracers tr = Tracers , consensusErrorTracer = showTracing tr , gsmTracer = showTracing tr , gddTracer = showTracing tr + , csjTracer = showTracing tr } {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index b13fd1ba3e..1a2816b77a 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -402,6 +402,7 @@ initInternalState NodeKernelArgs { tracers, chainDB, registry, cfg (GSM.gsmStateToLedgerJudgement <$> readTVar varGsmState) blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (Header blk) blk m blockFetchInterface = BlockFetchClientInterface.mkBlockFetchConsensusInterface + (csjTracer tracers) (configBlock cfg) (BlockFetchClientInterface.defaultChainDbView chainDB) varChainSyncHandles diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs index 4d3c8fffa3..e1f6ced950 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs @@ -83,6 +83,7 @@ startBlockFetchLogic registry tracer chainDb fetchClientRegistry csHandlesCol = blockFetchConsensusInterface = BlockFetchClientInterface.mkBlockFetchConsensusInterface + nullTracer -- FIXME (TestBlockConfig $ NumCoreNodes 0) -- Only needed when minting blocks (BlockFetchClientInterface.defaultChainDbView chainDb) csHandlesCol diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs index 59c4e18dd3..73402ba489 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs @@ -14,6 +14,7 @@ module Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface ( ) where import Control.Monad +import Control.Tracer (Tracer) import Data.Map.Strict (Map) import Data.Time.Clock (UTCTime) import GHC.Stack (HasCallStack) @@ -29,7 +30,7 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient -import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as Jumping +import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as CSJumping import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment @@ -179,7 +180,8 @@ mkBlockFetchConsensusInterface :: , Ord peer , LedgerSupportsProtocol blk ) - => BlockConfig blk + => Tracer m (CSJumping.TraceEvent peer) + -> BlockConfig blk -> ChainDbView m blk -> CSClient.ChainSyncClientHandleCollection peer m blk -> (Header blk -> SizeInBytes) @@ -190,7 +192,7 @@ mkBlockFetchConsensusInterface :: -> DiffusionPipeliningSupport -> BlockFetchConsensusInterface peer (Header blk) blk m mkBlockFetchConsensusInterface - bcfg chainDB csHandlesCol blockFetchSize slotForgeTime readFetchMode pipelining = + csjTracer bcfg chainDB csHandlesCol blockFetchSize slotForgeTime readFetchMode pipelining = BlockFetchConsensusInterface {..} where getCandidates :: STM m (Map peer (AnchoredFragment (Header blk))) @@ -343,5 +345,5 @@ mkBlockFetchConsensusInterface readChainSelStarvation = getChainSelStarvation chainDB - demoteCSJDynamo :: peer -> m () - demoteCSJDynamo = void . atomically . Jumping.rotateDynamo csHandlesCol + demoteChainSyncJumpingDynamo :: peer -> m () + demoteChainSyncJumpingDynamo = CSJumping.rotateDynamo csjTracer csHandlesCol diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs index 207046323f..c22c13d3ba 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs @@ -165,6 +165,7 @@ module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping ( , JumpInstruction (..) , JumpResult (..) , Jumping (..) + , TraceEvent (..) , getDynamo , makeContext , mkJumping @@ -176,7 +177,8 @@ module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping ( import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) import Control.Monad (forM, forM_, void, when) -import Data.Foldable (toList) +import Control.Tracer (Tracer, traceWith) +import Data.Foldable (toList, traverse_) import Data.List (sortOn) import qualified Data.Map as Map import Data.Maybe (catMaybes, fromMaybe) @@ -766,45 +768,46 @@ unregisterClient context = do -- -- It does nothing if there is no other engaged peer to elect or if the given -- peer is not the dynamo. --- --- Yields the new dynamo, if there is one. rotateDynamo :: ( Ord peer, LedgerSupportsProtocol blk, MonadSTM m ) => + Tracer m (TraceEvent peer) -> ChainSyncClientHandleCollection peer m blk -> peer -> - STM m (Maybe (peer, ChainSyncClientHandle m blk)) -rotateDynamo handlesCol peer = do - handles <- cschcMap handlesCol - case handles Map.!? peer of - Nothing -> - -- Do not re-elect a dynamo if the peer has been disconnected. - getDynamo handlesCol - Just oldDynHandle -> - readTVar (cschJumping oldDynHandle) >>= \case - Dynamo{} -> do - cschcRotateHandle handlesCol peer - peerStates <- cschcSeq handlesCol - mEngaged <- findNonDisengaged peerStates - case mEngaged of - Nothing -> - -- There are no engaged peers. This case cannot happen, as the - -- dynamo is always engaged. - error "rotateDynamo: no engaged peer found" - Just (newDynamoId, newDynHandle) - | newDynamoId == peer -> - -- The old dynamo is the only engaged peer left. - pure $ Just (newDynamoId, newDynHandle) - | otherwise -> do - newJumper Nothing (Happy FreshJumper Nothing) - >>= writeTVar (cschJumping oldDynHandle) - promoteToDynamo peerStates newDynamoId newDynHandle - pure $ Just (newDynamoId, newDynHandle) - _ -> - -- Do not re-elect a dynamo if the peer is not the dynamo. - getDynamo handlesCol + m () +rotateDynamo tracer handlesCol peer = do + traceEvent <- atomically $ do + handles <- cschcMap handlesCol + case handles Map.!? peer of + Nothing -> + -- Do not re-elect a dynamo if the peer has been disconnected. + pure Nothing + Just oldDynHandle -> + readTVar (cschJumping oldDynHandle) >>= \case + Dynamo{} -> do + cschcRotateHandle handlesCol peer + peerStates <- cschcSeq handlesCol + mEngaged <- findNonDisengaged peerStates + case mEngaged of + Nothing -> + -- There are no engaged peers. This case cannot happen, as the + -- dynamo is always engaged. + error "rotateDynamo: no engaged peer found" + Just (newDynamoId, newDynHandle) + | newDynamoId == peer -> + -- The old dynamo is the only engaged peer left. + pure Nothing + | otherwise -> do + newJumper Nothing (Happy FreshJumper Nothing) + >>= writeTVar (cschJumping oldDynHandle) + promoteToDynamo peerStates newDynamoId newDynHandle + pure $ Just $ RotatedDynamo peer newDynamoId + _ -> + -- Do not re-elect a dynamo if the peer is not the dynamo. + pure Nothing + traverse_ (traceWith tracer) traceEvent -- | Choose an unspecified new non-idling dynamo and demote all other peers to -- jumpers. @@ -905,3 +908,7 @@ electNewObjector context = do pure $ Just (badPoint, (initState, goodJumpInfo, handle)) _ -> pure Nothing + +data TraceEvent peer + = RotatedDynamo peer peer + deriving (Show) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index cd8a363d34..c03477f814 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -64,6 +64,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Types ( ) where import Cardano.Prelude (whenM) +import Control.Monad (when) import Control.ResourceRegistry import Control.Tracer import Data.Foldable (traverse_) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs index 1abea67134..e5d241e00a 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs @@ -279,6 +279,7 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do -> BlockFetchConsensusInterface PeerId (Header TestBlock) TestBlock m mkTestBlockFetchConsensusInterface getCandidates chainDbView = (BlockFetchClientInterface.mkBlockFetchConsensusInterface @m @PeerId + nullTracer (TestBlockConfig numCoreNodes) chainDbView (error "ChainSyncClientHandleCollection not provided to mkBlockFetchConsensusInterface")