Add explicit tracing events for CSJ

IntersectMBO · Aug 6, 2024 · f27e7c6 · f27e7c6
1 parent 8a70896
commit f27e7c6
Show file tree

Hide file tree

Showing 7 changed files with 56 additions and 35 deletions.
diff --git a/...consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs b/...consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs
@@ -31,6 +31,7 @@ import           Ouroboros.Consensus.MiniProtocol.BlockFetch.Server
                      (TraceBlockFetchServerEvent)
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                      (InvalidBlockReason, TraceChainSyncClientEvent)
+import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as CSJumping
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Server
                      (TraceChainSyncServerEvent)
 import           Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server
@@ -69,6 +70,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))
@@ -91,6 +93,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
@@ -121,6 +124,7 @@ nullTracers = Tracers
     , consensusErrorTracer          = nullTracer
     , gsmTracer                     = nullTracer
     , gddTracer                     = nullTracer
+    , csjTracer                     = nullTracer
     }
 
 showTracers :: ( Show blk
@@ -154,6 +158,7 @@ showTracers tr = Tracers
     , consensusErrorTracer          = showTracing tr
     , gsmTracer                     = showTracing tr
     , gddTracer                     = showTracing tr
+    , csjTracer                     = showTracing tr
     }
 
 {-------------------------------------------------------------------------------

diff --git a/...s-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/...s-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
@@ -391,6 +391,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
@@ -85,6 +85,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/...us/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs b/...us/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)
@@ -189,7 +191,7 @@ mkBlockFetchConsensusInterface ::
      -- ^ See 'readFetchMode'.
   -> BlockFetchConsensusInterface peer (Header blk) blk m
 mkBlockFetchConsensusInterface
-  bcfg chainDB csHandlesCol blockFetchSize slotForgeTime readFetchMode =
+  csjTracer bcfg chainDB csHandlesCol blockFetchSize slotForgeTime readFetchMode =
     BlockFetchConsensusInterface {..}
   where
     getCandidates :: STM m (Map peer (AnchoredFragment (Header blk)))
@@ -355,4 +357,4 @@ mkBlockFetchConsensusInterface
     readChainSelStarvation = getChainSelStarvation chainDB
 
     demoteCSJDynamo :: peer -> m ()
-    demoteCSJDynamo = void . atomically . Jumping.rotateDynamo csHandlesCol
+    demoteCSJDynamo = CSJumping.rotateDynamo csjTracer csHandlesCol
diff --git a/...nsus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs b/...nsus/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)
@@ -773,38 +775,42 @@ rotateDynamo ::
     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 ()
+  -- STM m (Maybe (peer, ChainSyncClientHandle m blk))
+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 +911,7 @@ electNewObjector context = do
             pure $ Just (badPoint, (initState, goodJumpInfo, handle))
           _ ->
             pure Nothing
+
+data TraceEvent peer
+  = RotatedDynamo peer peer
+  deriving (Show)
diff --git a/...boros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/...boros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
@@ -65,6 +65,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Types (
   ) where
 
 import           Cardano.Prelude (whenM)
+import           Control.Monad (when)
 import           Control.Tracer
 import           Data.Foldable (traverse_)
 import           Data.Map.Strict (Map)

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
@@ -281,6 +281,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")