A proper datatype for blockfetch decision tracing

IntersectMBO · Jul 15, 2024 · 2d2d07a · 2d2d07a
1 parent 4c84463
commit 2d2d07a
Show file tree

Hide file tree

Showing 6 changed files with 22 additions and 11 deletions.
diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal
@@ -35,6 +35,7 @@ library
                        Ouroboros.Network.BlockFetch.Decision
                        Ouroboros.Network.BlockFetch.Decision.BulkSync
                        Ouroboros.Network.BlockFetch.Decision.Deadline
+                       Ouroboros.Network.BlockFetch.Decision.Trace
                        Ouroboros.Network.BlockFetch.DeltaQ
                        Ouroboros.Network.BlockFetch.State
                        Ouroboros.Network.DeltaQ

diff --git a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs
@@ -56,6 +56,7 @@ import Ouroboros.Network.Protocol.BlockFetch.Type
 import Ouroboros.Network.Util.ShowProxy
 
 import Ouroboros.Network.Mock.ConcreteBlock
+import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent)
 
 
 -- | Run a single block fetch protocol until the chain is downloaded.
@@ -64,8 +65,7 @@ blockFetchExample0 :: forall m.
                       (MonadSTM m, MonadST m, MonadAsync m, MonadDelay m,
                        MonadFork m, MonadTime m, MonadTimer m, MonadMask m,
                        MonadThrow (STM m))
-                   => Tracer m [TraceLabelPeer Int
-                                 (FetchDecision [Point BlockHeader])]
+                   => Tracer m (TraceDecisionEvent Int BlockHeader)
                    -> Tracer m (TraceLabelPeer Int
                                  (TraceFetchClientState BlockHeader))
                    -> Tracer m (TraceLabelPeer Int
@@ -173,8 +173,7 @@ blockFetchExample1 :: forall m.
                       (MonadSTM m, MonadST m, MonadAsync m, MonadDelay m,
                        MonadFork m, MonadTime m, MonadTimer m, MonadMask m,
                        MonadThrow (STM m))
-                   => Tracer m [TraceLabelPeer Int
-                                 (FetchDecision [Point BlockHeader])]
+                   => Tracer m (TraceDecisionEvent Int BlockHeader)
                    -> Tracer m (TraceLabelPeer Int
                                  (TraceFetchClientState BlockHeader))
                    -> Tracer m (TraceLabelPeer Int

diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs
@@ -52,6 +52,7 @@ import Ouroboros.Network.NodeToNode.Version (isPipeliningEnabled)
 import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch)
 
 import Ouroboros.Network.Testing.Utils
+import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent)
 
 
 --
@@ -206,8 +207,7 @@ chainPoints = map (castPoint . blockPoint)
             . AnchoredFragment.toOldestFirst
 
 data Example1TraceEvent =
-     TraceFetchDecision       [TraceLabelPeer Int
-                                (FetchDecision [Point BlockHeader])]
+     TraceFetchDecision       (TraceDecisionEvent Int BlockHeader)
    | TraceFetchClientState    (TraceLabelPeer Int
                                 (TraceFetchClientState BlockHeader))
    | TraceFetchClientSendRecv (TraceLabelPeer Int

diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs
@@ -121,6 +121,7 @@ import Ouroboros.Network.BlockFetch.ConsensusInterface
            (BlockFetchConsensusInterface (..), FromConsensus (..),
            WhetherReceivingTentativeBlocks (..))
 import Ouroboros.Network.BlockFetch.State
+import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent)
 
 
 
@@ -162,7 +163,7 @@ blockFetchLogic :: forall addr header block m.
                    , Ord addr
                    , Hashable addr
                    )
-                => Tracer m [TraceLabelPeer addr (FetchDecision [Point header])]
+                => Tracer m (TraceDecisionEvent addr header)
                 -> Tracer m (TraceLabelPeer addr (TraceFetchClientState header))
                 -> BlockFetchConsensusInterface addr header block m
                 -> FetchClientRegistry addr header block m

diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Trace.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Trace.hs
@@ -0,0 +1,10 @@
+
+module Ouroboros.Network.BlockFetch.Decision.Trace where
+
+import Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer)
+import Ouroboros.Network.Block (Point)
+import Ouroboros.Network.BlockFetch.Decision.Deadline (FetchDecision)
+
+data TraceDecisionEvent peer header
+  = PeersFetch [TraceLabelPeer peer (FetchDecision [Point header])]
+  deriving (Show)
diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs
@@ -46,7 +46,7 @@ import Ouroboros.Network.BlockFetch.Decision (FetchDecision,
            PeerInfo, fetchDecisions)
 import Ouroboros.Network.BlockFetch.DeltaQ (PeerGSV (..))
 import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation)
-
+import Ouroboros.Network.BlockFetch.Decision.Trace
 
 fetchLogicIterations
   :: ( HasHeader header
@@ -57,7 +57,7 @@ fetchLogicIterations
      , Ord peer
      , Hashable peer
      )
-  => Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
+  => Tracer m (TraceDecisionEvent peer header)
   -> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
   -> FetchDecisionPolicy header
   -> FetchTriggerVariables peer header m
@@ -113,7 +113,7 @@ fetchLogicIteration
       HasHeader header, HasHeader block,
       HeaderHash header ~ HeaderHash block,
       MonadMonotonicTime m)
-  => Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
+  => Tracer m (TraceDecisionEvent peer header)
   -> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
   -> FetchDecisionPolicy header
   -> FetchTriggerVariables peer header m
@@ -155,7 +155,7 @@ fetchLogicIteration decisionTracer clientStateTracer
     -- _ <- evaluate (force decisions)
 
     -- Trace the batch of fetch decisions
-    traceWith decisionTracer
+    traceWith decisionTracer $ PeersFetch
       [ TraceLabelPeer peer (fmap fetchRequestPoints decision)
       | (decision, (_, _, _, peer, _)) <- decisions ]