Add peer sharing tracer (#1378)

# Description

Added peer sharing tracer

Author: jasagredo

ouroboros-consensus-diffusion/changelog.d/20250203_145928_crocodile-dentist_add_peer_sharing_tracer.md

@@ -0,0 +1,22 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+
+### Breaking
+
+- Added peer sharing tracer to NTN tracers

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs

@@ -369,60 +369,64 @@ identityCodecs = Codecs {
 -------------------------------------------------------------------------------}
 
 -- | A record of 'Tracer's for the different protocols.
-type Tracers m peer blk e =
-     Tracers'  peer blk e (Tracer m)
+type Tracers m ntnAddr blk e =
+     Tracers'  (ConnectionId ntnAddr) ntnAddr blk e (Tracer m)
 
-data Tracers' peer blk e f = Tracers {
+data Tracers' peer ntnAddr blk e f = Tracers {
       tChainSyncTracer            :: f (TraceLabelPeer peer (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
     , tChainSyncSerialisedTracer  :: f (TraceLabelPeer peer (TraceSendRecv (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
     , tBlockFetchTracer           :: f (TraceLabelPeer peer (TraceSendRecv (BlockFetch blk (Point blk))))
     , tBlockFetchSerialisedTracer :: f (TraceLabelPeer peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
     , tTxSubmission2Tracer        :: f (TraceLabelPeer peer (TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk))))
     , tKeepAliveTracer            :: f (TraceLabelPeer peer (TraceSendRecv KeepAlive))
+    , tPeerSharingTracer          :: f (TraceLabelPeer peer (TraceSendRecv (PeerSharing ntnAddr)))
     }
 
-instance (forall a. Semigroup (f a)) => Semigroup (Tracers' peer blk e f) where
+instance (forall a. Semigroup (f a)) => Semigroup (Tracers' peer ntnAddr blk e f) where
   l <> r = Tracers {
         tChainSyncTracer            = f tChainSyncTracer
       , tChainSyncSerialisedTracer  = f tChainSyncSerialisedTracer
       , tBlockFetchTracer           = f tBlockFetchTracer
       , tBlockFetchSerialisedTracer = f tBlockFetchSerialisedTracer
       , tTxSubmission2Tracer        = f tTxSubmission2Tracer
       , tKeepAliveTracer            = f tKeepAliveTracer
+      , tPeerSharingTracer          = f tPeerSharingTracer
       }
     where
       f :: forall a. Semigroup a
-        => (Tracers' peer blk e f -> a)
+        => (Tracers' peer ntnAddr blk e f -> a)
         -> a
       f prj = prj l <> prj r
 
 -- | Use a 'nullTracer' for each protocol.
-nullTracers :: Monad m => Tracers m peer blk e
+nullTracers :: Monad m => Tracers m ntnAddr blk e
 nullTracers = Tracers {
       tChainSyncTracer            = nullTracer
     , tChainSyncSerialisedTracer  = nullTracer
     , tBlockFetchTracer           = nullTracer
     , tBlockFetchSerialisedTracer = nullTracer
     , tTxSubmission2Tracer        = nullTracer
     , tKeepAliveTracer            = nullTracer
+    , tPeerSharingTracer          = nullTracer
     }
 
 showTracers :: ( Show blk
-               , Show peer
+               , Show ntnAddr
                , Show (Header blk)
                , Show (GenTx blk)
                , Show (GenTxId blk)
                , HasHeader blk
                , HasNestedContent Header blk
                )
-            => Tracer m String -> Tracers m peer blk e
+            => Tracer m String -> Tracers m ntnAddr blk e
 showTracers tr = Tracers {
       tChainSyncTracer            = showTracing tr
     , tChainSyncSerialisedTracer  = showTracing tr
     , tBlockFetchTracer           = showTracing tr
     , tBlockFetchSerialisedTracer = showTracing tr
     , tTxSubmission2Tracer        = showTracing tr
     , tKeepAliveTracer            = showTracing tr
+    , tPeerSharingTracer          = showTracing tr
     }
 
 {-------------------------------------------------------------------------------
@@ -543,7 +547,7 @@ mkApps ::
      , ShowProxy (GenTx blk)
      )
   => NodeKernel m addrNTN addrNTC blk -- ^ Needed for bracketing only
-  -> Tracers m (ConnectionId addrNTN) blk e
+  -> Tracers m addrNTN blk e
   -> (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bKA bPS)
   -> ByteLimits bCS bBF bTX bKA
   -> m ChainSyncTimeout
@@ -770,8 +774,7 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout lopBucke
         $ \controller -> do
           psClient <- hPeerSharingClient version controlMessageSTM them controller
           ((), trailing) <- runPeerWithLimits
-            -- TODO: add tracer
-            nullTracer
+            (TraceLabelPeer them `contramap` tPeerSharingTracer)
             (cPeerSharingCodec (mkCodecs version))
             (byteLimitsPeerSharing (const 0))
             timeLimitsPeerSharing
@@ -787,8 +790,7 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout lopBucke
     aPeerSharingServer version ResponderContext { rcConnectionId = them } channel = do
       labelThisThread "PeerSharingServer"
       runPeerWithLimits
-        -- TODO: add tracer
-        nullTracer
+        (TraceLabelPeer them `contramap` tPeerSharingTracer)
         (cPeerSharingCodec (mkCodecs version))
         (byteLimitsPeerSharing (const 0))
         timeLimitsPeerSharing

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs

@@ -177,7 +177,7 @@ data RunNodeArgs m addrNTN addrNTC blk (p2p :: Diffusion.P2P) = RunNodeArgs {
       rnTraceConsensus :: Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
 
       -- | Protocol tracers for node-to-node communication
-    , rnTraceNTN :: NTN.Tracers m (ConnectionId addrNTN) blk DeserialiseFailure
+    , rnTraceNTN :: NTN.Tracers m addrNTN blk DeserialiseFailure
 
       -- | Protocol tracers for node-to-client communication
     , rnTraceNTC :: NTC.Tracers m (ConnectionId addrNTC) blk DeserialiseFailure