Add explicit tracing events for CSJ

Author: Niols

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
     }
 
 {-------------------------------------------------------------------------------

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

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

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

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)

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_)

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")