chainSyncServerHeaderTracer

IntersectMBO · May 30, 2023 · d347b45 · d347b45
1 parent b80ffa9
commit d347b45
Show file tree

Hide file tree

Showing 4 changed files with 38 additions and 32 deletions.
diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs
@@ -90,6 +90,7 @@ ppMaxSlotNo Net.NoMaxSlotNo   = "???"
 ppMaxSlotNo (Net.MaxSlotNo x) = show (unSlotNo x)
 
 ppStatus :: PeerFetchStatus header -> String
+ppStatus PeerFetchStatusStarting = "starting"
 ppStatus PeerFetchStatusShutdown = "shutdown"
 ppStatus PeerFetchStatusAberrant = "aberrant"
 ppStatus PeerFetchStatusBusy     = "fetching"

diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs
@@ -300,12 +300,12 @@ instance (LedgerSupportsProtocol blk)
   formatText _ = pack . show . toList
 
 
-instance ConvertRawHash blk
-      => Transformable Text IO (TraceBlockFetchServerEvent blk) where
+instance (ToObject peer, ConvertRawHash blk)
+      => Transformable Text IO (TraceLabelPeer peer (TraceBlockFetchServerEvent blk)) where
   trTransformer = trStructuredText
 
 
-instance HasTextFormatter (TraceBlockFetchServerEvent blk) where
+instance HasTextFormatter (TraceLabelPeer peer (TraceBlockFetchServerEvent blk)) where
   formatText _ = pack . show . toList
 
 
@@ -318,6 +318,13 @@ instance ConvertRawHash blk
       => Transformable Text IO (TraceChainSyncServerEvent blk) where
   trTransformer = trStructured
 
+instance (ToObject peer, ToObject (TraceChainSyncServerEvent blk))
+    => Transformable Text IO (TraceLabelPeer peer (TraceChainSyncServerEvent blk)) where
+  trTransformer = trStructured
+instance (StandardHash blk, Show peer)
+    => HasTextFormatter (TraceLabelPeer peer (TraceChainSyncServerEvent blk)) where
+  formatText a _ = pack $ show a
+
 
 instance ( ToObject (ApplyTxErr blk), ToObject (GenTx blk),
            ToJSON (GenTxId blk), LedgerSupportsMempool blk)

diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs
@@ -697,10 +697,9 @@ mkConsensusTracers mbEKGDirect trSel verb tr nodeKern fStats = do
   pure Consensus.Tracers
     { Consensus.chainSyncClientTracer = tracerOnOff (traceChainSyncClient trSel) verb "ChainSyncClient" tr
     , Consensus.chainSyncServerHeaderTracer =
-      Tracer $ \ev -> do
-        traceWith (annotateSeverity . toLogObject' verb $ appendName "ChainSyncHeaderServer"
-                    (tracerOnOff' (traceChainSyncHeaderServer trSel) tr)) ev
-        traceServedCount mbEKGDirect ev
+           tracerOnOff' (traceChainSyncHeaderServer trSel)
+                        (annotateSeverity . toLogObject' verb $ appendName "ChainSyncHeaderServer" tr)
+        <> (\(TraceLabelPeer _ ev) -> ev) `contramap` Tracer (traceServedCount mbEKGDirect)
     , Consensus.chainSyncServerBlockTracer = tracerOnOff (traceChainSyncBlockServer trSel) verb "ChainSyncBlockServer" tr
     , Consensus.blockFetchDecisionTracer = tracerOnOff' (traceBlockFetchDecisions trSel) $
         annotateSeverity $ teeTraceBlockFetchDecision verb elidedFetchDecision tr
@@ -713,22 +712,22 @@ mkConsensusTracers mbEKGDirect trSel verb tr nodeKern fStats = do
     , Consensus.forgeStateInfoTracer = tracerOnOff' (traceForgeStateInfo trSel) $
         forgeStateInfoTracer (Proxy @blk) trSel tr
     , Consensus.txInboundTracer = tracerOnOff' (traceTxInbound trSel) $
-        Tracer $ \ev -> do
-          traceWith (annotateSeverity . toLogObject' verb $ appendName "TxInbound" tr) ev
-          case ev of
-            TraceLabelPeer _ (TraceTxSubmissionCollected collected) ->
-              traceI trmet meta "submissions.submitted.count" =<<
-                STM.modifyReadTVarIO tSubmissionsCollected (+ collected)
-
-            TraceLabelPeer _ (TraceTxSubmissionProcessed processed) -> do
-              traceI trmet meta "submissions.accepted.count" =<<
-                STM.modifyReadTVarIO tSubmissionsAccepted (+ ptxcAccepted processed)
-              traceI trmet meta "submissions.rejected.count" =<<
-                STM.modifyReadTVarIO tSubmissionsRejected (+ ptxcRejected processed)
-
-            TraceLabelPeer _ TraceTxInboundTerminated -> return ()
-            TraceLabelPeer _ (TraceTxInboundCanRequestMoreTxs _) -> return ()
-            TraceLabelPeer _ (TraceTxInboundCannotRequestMoreTxs _) -> return ()
+          Tracer $ \ev -> do
+            traceWith (annotateSeverity . toLogObject' verb $ appendName "TxInbound" tr) ev
+            case ev of
+              TraceLabelPeer _ (TraceTxSubmissionCollected collected) ->
+                traceI trmet meta "submissions.submitted.count" =<<
+                  STM.modifyReadTVarIO tSubmissionsCollected (+ collected)
+
+              TraceLabelPeer _ (TraceTxSubmissionProcessed processed) -> do
+                traceI trmet meta "submissions.accepted.count" =<<
+                  STM.modifyReadTVarIO tSubmissionsAccepted (+ ptxcAccepted processed)
+                traceI trmet meta "submissions.rejected.count" =<<
+                  STM.modifyReadTVarIO tSubmissionsRejected (+ ptxcRejected processed)
+
+              TraceLabelPeer _ TraceTxInboundTerminated -> return ()
+              TraceLabelPeer _ (TraceTxInboundCanRequestMoreTxs _) -> return ()
+              TraceLabelPeer _ (TraceTxInboundCannotRequestMoreTxs _) -> return ()
 
     , Consensus.txOutboundTracer = tracerOnOff (traceTxOutbound trSel) verb "TxOutbound" tr
     , Consensus.localTxSubmissionServerTracer = tracerOnOff (traceLocalTxSubmissionServer trSel) verb "LocalTxSubmissionServer" tr
@@ -774,19 +773,19 @@ mkConsensusTracers mbEKGDirect trSel verb tr nodeKern fStats = do
 
 
 traceBlockFetchServerMetrics
-  :: forall blk. ()
+  :: forall blk peer. ()
   => Tracer IO (LoggerName, LogObject Text)
   -> LOMeta
   -> STM.TVar Int64
   -> STM.TVar Int64
   -> STM.TVar SlotNo
-  -> Tracer IO (TraceBlockFetchServerEvent blk)
-  -> Tracer IO (TraceBlockFetchServerEvent blk)
+  -> Tracer IO (TraceLabelPeer peer (TraceBlockFetchServerEvent blk))
+  -> Tracer IO (TraceLabelPeer peer (TraceBlockFetchServerEvent blk))
 traceBlockFetchServerMetrics trMeta meta tBlocksServed tLocalUp tMaxSlotNo tracer = Tracer bsTracer
 
   where
-    bsTracer :: TraceBlockFetchServerEvent blk -> IO ()
-    bsTracer e@(TraceBlockFetchServerSendBlock p) = do
+    bsTracer :: TraceLabelPeer peer (TraceBlockFetchServerEvent blk) -> IO ()
+    bsTracer e@(TraceLabelPeer _p (TraceBlockFetchServerSendBlock p)) = do
       traceWith tracer e
 
       (served, mbLocalUpstreamyness) <- atomically $ do

diff --git a/cardano-tracer/src/Cardano/Tracer/Acceptors/Client.hs b/cardano-tracer/src/Cardano/Tracer/Acceptors/Client.hs
@@ -21,11 +21,10 @@ import           Ouroboros.Network.Mux (MiniProtocol (..), MiniProtocolLimits (.
 import           Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec,
                    codecHandshake, noTimeLimitsHandshake)
 import           Ouroboros.Network.Protocol.Handshake.Type (Handshake)
-import           Ouroboros.Network.Protocol.Handshake.Version (acceptableVersion,
-                   queryVersion, simpleSingletonVersions)
+import           Ouroboros.Network.Protocol.Handshake.Version (acceptableVersion, queryVersion,
                    simpleSingletonVersions)
-import           Ouroboros.Network.Snocket (LocalAddress, LocalSocket, Snocket, makeLocalBearer,
-                   localAddressFromPath, localSnocket)
+import           Ouroboros.Network.Snocket (LocalAddress, LocalSocket, Snocket,
+                   localAddressFromPath, localSnocket, makeLocalBearer)
 import           Ouroboros.Network.Socket (ConnectionId (..), HandshakeCallbacks (..),
                    connectToNode, nullNetworkConnectTracers)
 import qualified System.Metrics.Configuration as EKGF