Added KeepAlive tracer

I also left TODO notes to add PeerSharing tracer.

Author: coot

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

@@ -375,6 +375,7 @@ data Tracers' peer blk e f = Tracers {
     , 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))
     }
 
 instance (forall a. Semigroup (f a)) => Semigroup (Tracers' peer blk e f) where
@@ -384,6 +385,7 @@ instance (forall a. Semigroup (f a)) => Semigroup (Tracers' peer blk e f) where
       , tBlockFetchTracer           = f tBlockFetchTracer
       , tBlockFetchSerialisedTracer = f tBlockFetchSerialisedTracer
       , tTxSubmission2Tracer        = f tTxSubmission2Tracer
+      , tKeepAliveTracer            = f tKeepAliveTracer
       }
     where
       f :: forall a. Semigroup a
@@ -399,6 +401,7 @@ nullTracers = Tracers {
     , tBlockFetchTracer           = nullTracer
     , tBlockFetchSerialisedTracer = nullTracer
     , tTxSubmission2Tracer        = nullTracer
+    , tKeepAliveTracer            = nullTracer
     }
 
 showTracers :: ( Show blk
@@ -416,6 +419,7 @@ showTracers tr = Tracers {
     , tBlockFetchTracer           = showTracing tr
     , tBlockFetchSerialisedTracer = showTracing tr
     , tTxSubmission2Tracer        = showTracing tr
+    , tKeepAliveTracer            = showTracing tr
     }
 
 {-------------------------------------------------------------------------------
@@ -716,7 +720,7 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout lopBucke
       labelThisThread "KeepAliveClient"
       let kacApp = \dqCtx ->
                        runPeerWithLimits
-                         nullTracer
+                         (TraceLabelPeer them `contramap` tKeepAliveTracer)
                          (cKeepAliveCodec (mkCodecs version))
                          blKeepAlive
                          timeLimitsKeepAlive
@@ -733,10 +737,10 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout lopBucke
       -> ResponderContext addrNTN
       -> Channel m bKA
       -> m ((), Maybe bKA)
-    aKeepAliveServer version _responderCtx channel = do
+    aKeepAliveServer version ResponderContext { rcConnectionId = them } channel = do
       labelThisThread "KeepAliveServer"
       runPeerWithLimits
-        nullTracer
+        (TraceLabelPeer them `contramap` tKeepAliveTracer)
         (cKeepAliveCodec (mkCodecs version))
         (byteLimitsKeepAlive (const 0)) -- TODO: Real Bytelimits, see #1727
         timeLimitsKeepAlive
@@ -760,6 +764,7 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout lopBucke
         $ \controller -> do
           psClient <- hPeerSharingClient version controlMessageSTM them controller
           ((), trailing) <- runPeerWithLimits
+            -- TODO: add tracer
             nullTracer
             (cPeerSharingCodec (mkCodecs version))
             (byteLimitsPeerSharing (const 0))
@@ -776,6 +781,7 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout lopBucke
     aPeerSharingServer version ResponderContext { rcConnectionId = them } channel = do
       labelThisThread "PeerSharingServer"
       runPeerWithLimits
+        -- TODO: add tracer
         nullTracer
         (cPeerSharingCodec (mkCodecs version))
         (byteLimitsPeerSharing (const 0))