Make it possible to inspect all traces in stateView

ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal

@@ -258,6 +258,7 @@ test-suite consensus-test
     Test.Consensus.PeerSimulator.Tests.Timeouts
     Test.Consensus.PeerSimulator.Trace
     Test.Consensus.PointSchedule
+    Test.Consensus.PointSchedule.NodeState
     Test.Consensus.PointSchedule.Peers
     Test.Consensus.PointSchedule.Shrinking
     Test.Consensus.PointSchedule.Shrinking.Tests

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Handlers.hs

@@ -46,7 +46,7 @@ import           Test.Consensus.PeerSimulator.ScheduledChainSyncServer
 import           Test.Consensus.PeerSimulator.Trace
                      (TraceScheduledBlockFetchServerEvent (..),
                      TraceScheduledChainSyncServerEvent (..))
-import           Test.Consensus.PointSchedule
+import           Test.Consensus.PointSchedule.NodeState
 import           Test.Util.Orphans.IOLike ()
 import           Test.Util.TestBlock (TestBlock, TestHash (TestHash))
 

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Resources.hs

@@ -42,7 +42,7 @@ import           Test.Consensus.PeerSimulator.ScheduledBlockFetchServer
                      runScheduledBlockFetchServer)
 import           Test.Consensus.PeerSimulator.ScheduledChainSyncServer
 import           Test.Consensus.PeerSimulator.Trace (TraceEvent)
-import           Test.Consensus.PointSchedule
+import           Test.Consensus.PointSchedule.NodeState
 import           Test.Consensus.PointSchedule.Peers (PeerId)
 import           Test.Util.Orphans.IOLike ()
 import           Test.Util.TestBlock (TestBlock)

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs

@@ -58,8 +58,8 @@ import           Test.Consensus.PeerSimulator.Trace
 import qualified Test.Consensus.PointSchedule as PointSchedule
 import           Test.Consensus.PointSchedule (BlockFetchTimeout,
                      CSJParams (..), GenesisTest (GenesisTest), GenesisTestFull,
-                     LoPBucketParams (..), NodeState, PeersSchedule,
-                     peersStatesRelative)
+                     LoPBucketParams (..), PeersSchedule, peersStatesRelative)
+import           Test.Consensus.PointSchedule.NodeState (NodeState)
 import           Test.Consensus.PointSchedule.Peers (Peer (..), PeerId,
                      getPeerIds)
 import           Test.Util.ChainDB
@@ -339,7 +339,7 @@ startNode schedulerConfig genesisTest interval = do
         (csClient, csServer) <-
           startChainSyncConnectionThread
           peerRegistry
-          lrTracer
+          tracer
           lrConfig
           chainDbView
           fetchClientRegistry
@@ -354,7 +354,7 @@ startNode schedulerConfig genesisTest interval = do
         (bfClient, bfServer) <-
           startBlockFetchConnectionThread
           peerRegistry
-          lrTracer
+          tracer
           lnStateViewTracers
           fetchClientRegistry
           (pure Continue)
@@ -395,6 +395,13 @@ startNode schedulerConfig genesisTest interval = do
       , gtCSJParams = CSJParams { csjpJumpSize }
       } = genesisTest
 
+    StateViewTracers{svtTraceTracer} = lnStateViewTracers
+
+    -- FIXME: This type of configuration should move to `Trace.mkTracer`.
+    tracer = if scTrace schedulerConfig
+      then Tracer (\evt -> traceWith lrTracer evt >> traceWith svtTraceTracer evt)
+      else svtTraceTracer
+
     chainSyncTimeouts_ =
       if scEnableChainSyncTimeouts schedulerConfig
         then gtChainSyncTimeouts

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledBlockFetchServer.hs

@@ -18,7 +18,7 @@ import           Ouroboros.Network.Protocol.BlockFetch.Server
 import           Test.Consensus.PeerSimulator.ScheduledServer
                      (ScheduledServer (..), awaitOnlineState, runHandler)
 import           Test.Consensus.PeerSimulator.Trace
-import           Test.Consensus.PointSchedule (NodeState)
+import           Test.Consensus.PointSchedule.NodeState (NodeState)
 import           Test.Consensus.PointSchedule.Peers (PeerId)
 
 -- | Return values for the 'handlerSendBlocks'.

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledChainSyncServer.hs

@@ -27,7 +27,7 @@ import           Test.Consensus.PeerSimulator.ScheduledServer
 import           Test.Consensus.PeerSimulator.Trace
                      (TraceEvent (TraceScheduledChainSyncServerEvent),
                      TraceScheduledChainSyncServerEvent (..))
-import           Test.Consensus.PointSchedule (NodeState)
+import           Test.Consensus.PointSchedule.NodeState (NodeState)
 import           Test.Consensus.PointSchedule.Peers (PeerId)
 
 -- | Pure representation of the messages produced by the handler for the @StNext@

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateDiagram.hs

@@ -54,8 +54,8 @@ import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Ouroboros.Network.Block (HeaderHash)
 import           Test.Consensus.BlockTree (BlockTree (btBranches, btTrunk),
                      BlockTreeBranch (btbSuffix), prettyBlockTree)
-import qualified Test.Consensus.PointSchedule as PS
-import           Test.Consensus.PointSchedule (NodeState, genesisNodeState)
+import           Test.Consensus.PointSchedule.NodeState (NodeState (..),
+                     genesisNodeState)
 import           Test.Consensus.PointSchedule.Peers (PeerId (..))
 import           Test.Util.TestBlock (TestBlock, TestHash (TestHash))
 
@@ -478,7 +478,7 @@ addPoints :: Map PeerId (NodeState TestBlock) -> TreeSlots -> TreeSlots
 addPoints peerPoints treeSlots =
   foldl' step treeSlots (Map.toList peerPoints)
   where
-    step z (pid, ap) = addTipPoint pid (PS.nsTip ap) z
+    step z (pid, ap) = addTipPoint pid (nsTip ap) z
 
 ----------------------------------------------------------------------------------------------------
 -- Cells

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateView.hs

@@ -36,6 +36,7 @@ import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
 import           Ouroboros.Network.Block (StandardHash, Tip)
 import           Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch)
 import           Ouroboros.Network.Protocol.ChainSync.Type (ChainSync)
+import           Test.Consensus.PeerSimulator.Trace (TraceEvent)
 import           Test.Consensus.PointSchedule.Peers (PeerId)
 import           Test.Util.TersePrinting (terseBlock, terseHFragment,
                      terseMaybe)
@@ -143,7 +144,9 @@ data StateView blk = StateView {
     svPeerSimulatorResults :: [PeerSimulatorResult blk],
     -- | This field holds the most recent point in the selection (incl. anchor)
     -- for which we have a full block (not just a header).
-    svTipBlock             :: Maybe blk
+    svTipBlock             :: Maybe blk,
+    -- | List of all TraceEvent that have been sent during the simulation.
+    svTrace                :: [TraceEvent blk]
   }
 
 instance Condense (StateView TestBlock) where
@@ -164,6 +167,8 @@ collectDisconnectedPeers stateView = nubOrd $
 data StateViewTracers blk m = StateViewTracers {
     svtPeerSimulatorResultsTracer :: Tracer m (PeerSimulatorResult blk)
   , svtGetPeerSimulatorResults    :: m [PeerSimulatorResult blk]
+  , svtTraceTracer                :: Tracer m (TraceEvent blk)
+  , svtGetTracerTrace             :: m [TraceEvent blk]
   }
 
 -- | Helper to get exceptions from a StateView.
@@ -196,7 +201,13 @@ defaultStateViewTracers ::
   m (StateViewTracers blk m)
 defaultStateViewTracers = do
   (svtPeerSimulatorResultsTracer, svtGetPeerSimulatorResults) <- recordingTracerTVar
-  pure StateViewTracers {svtPeerSimulatorResultsTracer, svtGetPeerSimulatorResults}
+  (svtTraceTracer, svtGetTracerTrace) <- recordingTracerTVar
+  pure StateViewTracers
+    { svtPeerSimulatorResultsTracer
+    , svtGetPeerSimulatorResults
+    , svtTraceTracer
+    , svtGetTracerTrace
+    }
 
 -- | Call 'defaultStateViewTracers' and add the provided results.
 stateViewTracersWithInitial ::
@@ -216,8 +227,9 @@ snapshotStateView ::
   StateViewTracers blk m ->
   ChainDB m blk ->
   m (StateView blk)
-snapshotStateView StateViewTracers{svtGetPeerSimulatorResults} chainDb = do
+snapshotStateView StateViewTracers{svtGetPeerSimulatorResults, svtGetTracerTrace} chainDb = do
   svPeerSimulatorResults <- svtGetPeerSimulatorResults
+  svTrace <- svtGetTracerTrace
   svSelectedChain <- atomically $ ChainDB.getCurrentChain chainDb
   svTipBlock <- ChainDB.getTipBlock chainDb
-  pure StateView {svSelectedChain, svPeerSimulatorResults, svTipBlock}
+  pure StateView {svSelectedChain, svPeerSimulatorResults, svTipBlock, svTrace}

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs

@@ -46,7 +46,7 @@ import           Ouroboros.Network.AnchoredFragment (AnchoredFragment,
                      headPoint)
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Ouroboros.Network.Block (SlotNo (SlotNo), Tip, castPoint)
-import           Test.Consensus.PointSchedule (NodeState)
+import           Test.Consensus.PointSchedule.NodeState (NodeState)
 import           Test.Consensus.PointSchedule.Peers (Peer (Peer), PeerId)
 import           Test.Util.TersePrinting (terseAnchor, terseBlock,
                      terseFragment, terseHFragment, terseHeader, tersePoint,

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs

@@ -28,15 +28,13 @@ module Test.Consensus.PointSchedule (
   , GenesisTestFull
   , GenesisWindow (..)
   , LoPBucketParams (..)
-  , NodeState (..)
   , PeerSchedule
   , PeersSchedule
   , RunGenesisTestResult (..)
   , enrichedWith
   , ensureScheduleDuration
   , genesisNodeState
   , longRangeAttack
-  , nsTipTip
   , peerSchedulesBlocks
   , peerStates
   , peersStates
@@ -65,18 +63,18 @@ import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Network.NodeToNode (ChainSyncTimeout (..))
 import           Ouroboros.Consensus.Protocol.Abstract
                      (SecurityParam (SecurityParam), maxRollbacks)
-import           Ouroboros.Consensus.Util.Condense (Condense (..),
-                     CondenseList (..), PaddingDirection (..),
-                     condenseListWithPadding, padListWith)
+import           Ouroboros.Consensus.Util.Condense (CondenseList (..),
+                     PaddingDirection (..), condenseListWithPadding)
 import qualified Ouroboros.Network.AnchoredFragment as AF
-import           Ouroboros.Network.Block (SlotNo (..), Tip (..), blockSlot,
-                     tipFromHeader)
+import           Ouroboros.Network.Block (SlotNo (..), blockSlot)
 import           Ouroboros.Network.Point (withOrigin)
 import qualified System.Random.Stateful as Random
 import           System.Random.Stateful (STGenM, StatefulGen, runSTGen_)
 import           Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..),
                      allFragments, prettyBlockTree)
 import           Test.Consensus.PeerSimulator.StateView (StateView)
+import           Test.Consensus.PointSchedule.NodeState (NodeState (..),
+                     genesisNodeState)
 import           Test.Consensus.PointSchedule.Peers (Peer (..), Peers (..),
                      mkPeers, peersList)
 import           Test.Consensus.PointSchedule.SinglePeer
@@ -88,53 +86,10 @@ import           Test.Consensus.PointSchedule.SinglePeer.Indices
 import           Test.Ouroboros.Consensus.ChainGenerator.Params (Delta (Delta))
 import           Test.QuickCheck (Gen, arbitrary)
 import           Test.QuickCheck.Random (QCGen)
-import           Test.Util.TersePrinting (terseBlock, terseFragment,
-                     terseWithOrigin)
+import           Test.Util.TersePrinting (terseFragment)
 import           Test.Util.TestBlock (TestBlock)
 import           Text.Printf (printf)
 
-----------------------------------------------------------------------------------------------------
--- Data types
-----------------------------------------------------------------------------------------------------
-
--- | The state of a peer at a given point in time.
-data NodeState blk =
-  NodeState {
-    nsTip    :: WithOrigin blk,
-    nsHeader :: WithOrigin blk,
-    nsBlock  :: WithOrigin blk
-  }
-  deriving (Eq, Show)
-
-nsTipTip :: AF.HasHeader blk => NodeState blk -> Tip blk
-nsTipTip = withOrigin TipGenesis tipFromHeader . nsTip
-
-instance Condense (NodeState TestBlock) where
-  condense NodeState {nsTip, nsHeader, nsBlock} =
-    "TP " ++ terseWithOrigin terseBlock nsTip ++
-    " | HP " ++ terseWithOrigin terseBlock nsHeader ++
-    " | BP " ++ terseWithOrigin terseBlock nsBlock
-
-instance CondenseList (NodeState TestBlock) where
-  condenseList points =
-    zipWith3
-      (\tip header block ->
-        "TP " ++ tip ++
-          " | HP " ++ header ++
-          " | BP " ++ block
-      )
-      (padListWith PadRight $ map (terseWithOrigin terseBlock . nsTip) points)
-      (padListWith PadRight $ map (terseWithOrigin terseBlock . nsHeader) points)
-      (padListWith PadRight $ map (terseWithOrigin terseBlock . nsBlock) points)
-
-genesisNodeState :: NodeState blk
-genesisNodeState =
-  NodeState {
-    nsTip = Origin,
-    nsHeader = Origin,
-    nsBlock = Origin
-  }
-
 prettyPeersSchedule ::
   forall blk.
   (CondenseList (NodeState blk)) =>

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule/NodeState.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NamedFieldPuns    #-}
+
+module Test.Consensus.PointSchedule.NodeState (
+    NodeState (..)
+  , genesisNodeState
+  , nsTipTip
+  ) where
+
+import           Ouroboros.Consensus.Block.Abstract (WithOrigin (..))
+import           Ouroboros.Consensus.Util.Condense (Condense (..),
+                     CondenseList (..), PaddingDirection (..), padListWith)
+import qualified Ouroboros.Network.AnchoredFragment as AF
+import           Ouroboros.Network.Block (Tip (..), tipFromHeader)
+import           Ouroboros.Network.Point (withOrigin)
+import           Test.Util.TersePrinting (terseBlock, terseWithOrigin)
+import           Test.Util.TestBlock (TestBlock)
+
+-- | The state of a peer at a given point in time.
+data NodeState blk =
+  NodeState {
+    nsTip    :: WithOrigin blk,
+    nsHeader :: WithOrigin blk,
+    nsBlock  :: WithOrigin blk
+  }
+  deriving (Eq, Show)
+
+nsTipTip :: AF.HasHeader blk => NodeState blk -> Tip blk
+nsTipTip = withOrigin TipGenesis tipFromHeader . nsTip
+
+instance Condense (NodeState TestBlock) where
+  condense NodeState {nsTip, nsHeader, nsBlock} =
+    "TP " ++ terseWithOrigin terseBlock nsTip ++
+    " | HP " ++ terseWithOrigin terseBlock nsHeader ++
+    " | BP " ++ terseWithOrigin terseBlock nsBlock
+
+instance CondenseList (NodeState TestBlock) where
+  condenseList points =
+    zipWith3
+      (\tip header block ->
+        "TP " ++ tip ++
+          " | HP " ++ header ++
+          " | BP " ++ block
+      )
+      (padListWith PadRight $ map (terseWithOrigin terseBlock . nsTip) points)
+      (padListWith PadRight $ map (terseWithOrigin terseBlock . nsHeader) points)
+      (padListWith PadRight $ map (terseWithOrigin terseBlock . nsBlock) points)
+
+genesisNodeState :: NodeState blk
+genesisNodeState =
+  NodeState {
+    nsTip = Origin,
+    nsHeader = Origin,
+    nsBlock = Origin
+  }
+
+