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 index c2e3ee847b..d0b63d10b8 100644 --- 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 index 6dbc1550dd..b412696e55 100644 --- 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)