Log ChainSync mini-protocol events if need be

IntersectMBO · Dec 19, 2024 · bee2c84 · bee2c84
1 parent 7b04c28
commit bee2c84
Show file tree

Hide file tree

Showing 2 changed files with 38 additions and 3 deletions.
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs
@@ -165,7 +165,7 @@ runChainSyncClient
         res <-
           try $
             runPipelinedPeerWithLimits
-              nullTracer
+              (Tracer $ traceWith tracer . TraceChainSyncSendRecvEvent peerId "Client")
               codecChainSyncId
               chainSyncNoSizeLimits
               (timeLimitsChainSync chainSyncTimeouts)
@@ -218,8 +218,8 @@ runChainSyncServer ::
   ChainSyncServer (Header blk) (Point blk) (Tip blk) m () ->
   Channel m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))) ->
   m ()
-runChainSyncServer _tracer peerId StateViewTracers {svtPeerSimulatorResultsTracer} server channel =
-  (try $ runPeer nullTracer codecChainSyncId channel (chainSyncServerPeer server)) >>= \case
+runChainSyncServer tracer peerId StateViewTracers {svtPeerSimulatorResultsTracer} server channel =
+  (try $ runPeer sendRecvTracer codecChainSyncId channel (chainSyncServerPeer server)) >>= \case
     Right ((), msgRes) -> traceWith svtPeerSimulatorResultsTracer $
       PeerSimulatorResult peerId $ SomeChainSyncServerResult $ Right msgRes
     Left exn -> do
@@ -228,3 +228,5 @@ runChainSyncServer _tracer peerId StateViewTracers {svtPeerSimulatorResultsTrace
       -- NOTE: here we are able to trace exceptions, as what is done in `runChainSyncClient`
       case fromException exn of
         (_ :: Maybe SomeException) -> pure ()
+  where
+    sendRecvTracer = Tracer $ traceWith tracer . TraceChainSyncSendRecvEvent peerId "Server"
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs
@@ -25,6 +25,7 @@ import           Data.Bifunctor (second)
 import           Data.List (intersperse)
 import qualified Data.List.NonEmpty as NE
 import           Data.Time.Clock (DiffTime, diffTimeToPicoseconds)
+import           Network.TypedProtocol.Codec (AnyMessage (..))
 import           Ouroboros.Consensus.Block (GenesisWindow (..), Header, Point,
                      WithOrigin (NotOrigin, Origin), succWithOrigin)
 import           Ouroboros.Consensus.Genesis.Governor (DensityBounds (..),
@@ -49,6 +50,9 @@ import           Ouroboros.Network.AnchoredFragment (AnchoredFragment,
                      headPoint)
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Ouroboros.Network.Block (SlotNo (SlotNo), Tip, castPoint)
+import           Ouroboros.Network.Driver.Simple (TraceSendRecv (..))
+import           Ouroboros.Network.Protocol.ChainSync.Type (ChainSync,
+                     Message (..))
 import           Test.Consensus.PointSchedule.NodeState (NodeState)
 import           Test.Consensus.PointSchedule.Peers (Peer (Peer), PeerId)
 import           Test.Util.TersePrinting (terseAnchor, terseBlock,
@@ -130,6 +134,7 @@ data TraceEvent blk
   | TraceChainSyncClientTerminationEvent PeerId TraceChainSyncClientTerminationEvent
   | TraceBlockFetchClientTerminationEvent PeerId TraceBlockFetchClientTerminationEvent
   | TraceGenesisDDEvent (TraceGDDEvent PeerId blk)
+  | TraceChainSyncSendRecvEvent PeerId String (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))
   | TraceOther String
 
 -- * 'TestBlock'-specific tracers for the peer simulator
@@ -182,6 +187,7 @@ traceEventTestBlockWith setTickTime tracer0 tracer = \case
     TraceChainSyncClientTerminationEvent peerId traceEvent -> traceChainSyncClientTerminationEventTestBlockWith peerId tracer traceEvent
     TraceBlockFetchClientTerminationEvent peerId traceEvent -> traceBlockFetchClientTerminationEventTestBlockWith peerId tracer traceEvent
     TraceGenesisDDEvent gddEvent -> traceWith tracer (terseGDDEvent gddEvent)
+    TraceChainSyncSendRecvEvent peerId peerType traceEvent -> traceChainSyncSendRecvEventTestBlockWith peerId peerType tracer traceEvent
     TraceOther msg -> traceWith tracer msg
 
 traceSchedulerEventTestBlockWith ::
@@ -464,6 +470,33 @@ traceBlockFetchClientTerminationEventTestBlockWith pid tracer = \case
   where
     trace = traceUnitWith tracer ("BlockFetchClient " ++ condense pid)
 
+-- | Trace all the SendRecv events of the ChainSync mini-protocol.
+traceChainSyncSendRecvEventTestBlockWith ::
+  Applicative m =>
+  PeerId ->
+  String ->
+  Tracer m String ->
+  TraceSendRecv (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)) ->
+  m ()
+traceChainSyncSendRecvEventTestBlockWith pid ptp tracer = \case
+    TraceSendMsg amsg -> traceMsg "send" amsg
+    TraceRecvMsg amsg -> traceMsg "recv" amsg
+  where
+    -- This can be very verbose and is only useful in rare situations, so it
+    -- does nothing by default.
+    -- trace = traceUnitWith tracer ("ChainSync " ++ condense pid) . ((ptp ++ " ") ++)
+    trace = (\_ _ _ -> const (pure ())) pid ptp tracer
+    traceMsg kd amsg = trace $ kd ++ " " ++ case amsg of
+      AnyMessage msg -> case msg of
+        MsgRequestNext -> "MsgRequestNext"
+        MsgAwaitReply -> "MsgAwaitReply"
+        MsgRollForward header tip -> "MsgRollForward " ++ terseHeader header ++ " " ++ terseTip tip
+        MsgRollBackward point tip -> "MsgRollBackward " ++ tersePoint point ++ " " ++ terseTip tip
+        MsgFindIntersect points -> "MsgFindIntersect [" ++ unwords (map tersePoint points) ++ "]"
+        MsgIntersectFound point tip -> "MsgIntersectFound " ++ tersePoint point ++ " " ++ terseTip tip
+        MsgIntersectNotFound tip -> "MsgIntersectNotFound " ++ terseTip tip
+        MsgDone -> "MsgDone"
+
 prettyDensityBounds :: [(PeerId, DensityBounds TestBlock)] -> [String]
 prettyDensityBounds bounds =
   showPeers (second showBounds <$> bounds)