Fix tests that relied on default timeouts

Author: Niols

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs

@@ -9,15 +9,16 @@ module Test.Consensus.PeerSimulator.Tests.LinkedThreads (tests) where
 import           Control.Monad.Class.MonadAsync (AsyncCancelled (..))
 import           Control.Monad.Class.MonadTime.SI (Time (Time))
 import           Data.Functor (($>))
-import           Data.Maybe (fromJust)
-import           Ouroboros.Consensus.Util.IOLike (DiffTime, fromException)
+import           Ouroboros.Consensus.Util.IOLike (fromException)
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Ouroboros.Network.Driver.Limits
                      (ProtocolLimitFailure (ExceededTimeLimit))
 import           Ouroboros.Network.Protocol.ChainSync.Codec (mustReplyTimeout)
 import           Test.Consensus.BlockTree (BlockTree (..))
 import           Test.Consensus.Genesis.Setup
-import           Test.Consensus.PeerSimulator.Run (defaultSchedulerConfig)
+import           Test.Consensus.PeerSimulator.Run
+                     (SchedulerConfig (scEnableChainSyncTimeouts),
+                     defaultSchedulerConfig)
 import           Test.Consensus.PeerSimulator.StateView
 import           Test.Consensus.PointSchedule
 import           Test.Consensus.PointSchedule.Peers (peersOnlyHonest)
@@ -39,13 +40,15 @@ tests = testProperty "ChainSync kills BlockFetch" prop_chainSyncKillsBlockFetch
 prop_chainSyncKillsBlockFetch :: Property
 prop_chainSyncKillsBlockFetch = do
   forAllGenesisTest
-    (do gt@GenesisTest{gtChainSyncTimeouts} <- genChains (pure 0)
-        let schedule = dullSchedule gt (fromJust $ mustReplyTimeout gtChainSyncTimeouts)
-        pure $ gt $> schedule
+    (do gt@GenesisTest{gtBlockTree} <- genChains (pure 0)
+        pure $ enableMustReplyTimeout $ gt $> dullSchedule (btTrunk gtBlockTree)
     )
-    defaultSchedulerConfig
+
+    defaultSchedulerConfig {scEnableChainSyncTimeouts = True}
+
     -- No shrinking because the schedule is tiny and hand-crafted
     (\_ _ -> [])
+
     ( \_ stateView@StateView {svTipBlock} ->
         svTipBlock == Nothing
           && case exceptionsByComponent ChainSyncClient stateView of
@@ -62,9 +65,11 @@ prop_chainSyncKillsBlockFetch = do
             _                                      -> False
     )
   where
-    dullSchedule :: GenesisTest blk () -> DiffTime -> PointSchedule blk
-    dullSchedule GenesisTest {gtBlockTree} timeout =
-      let (firstBlock, secondBlock) = case AF.toOldestFirst $ btTrunk gtBlockTree of
+    timeout = 10
+
+    dullSchedule :: AF.AnchoredFragment blk -> PointSchedule blk
+    dullSchedule trunk =
+      let (firstBlock, secondBlock) = case AF.toOldestFirst trunk of
             b1 : b2 : _ -> (b1, b2)
             _           -> error "block tree must have two blocks"
           psSchedule = peersOnlyHonest $
@@ -73,3 +78,6 @@ prop_chainSyncKillsBlockFetch = do
             ]
           psMinEndTime = Time $ timeout + 1
        in PointSchedule {psSchedule, psStartOrder = [], psMinEndTime}
+
+    enableMustReplyTimeout :: GenesisTest blk schedule -> GenesisTest blk schedule
+    enableMustReplyTimeout gt = gt { gtChainSyncTimeouts = (gtChainSyncTimeouts gt) { mustReplyTimeout = Just timeout } }

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs

@@ -5,7 +5,6 @@
 module Test.Consensus.PeerSimulator.Tests.Timeouts (tests) where
 
 import           Data.Functor (($>))
-import           Data.Maybe (fromJust)
 import           Ouroboros.Consensus.Util.Condense
 import           Ouroboros.Consensus.Util.IOLike (DiffTime, Time (Time),
                      fromException)
@@ -15,7 +14,9 @@ import           Ouroboros.Network.Driver.Limits
 import           Ouroboros.Network.Protocol.ChainSync.Codec (mustReplyTimeout)
 import           Test.Consensus.BlockTree (btTrunk)
 import           Test.Consensus.Genesis.Setup
-import           Test.Consensus.PeerSimulator.Run (defaultSchedulerConfig)
+import           Test.Consensus.PeerSimulator.Run
+                     (SchedulerConfig (scEnableChainSyncTimeouts),
+                     defaultSchedulerConfig)
 import           Test.Consensus.PeerSimulator.StateView
 import           Test.Consensus.PointSchedule
 import           Test.Consensus.PointSchedule.Peers (peersOnlyAdversary,
@@ -38,12 +39,11 @@ prop_timeouts :: Bool -> Property
 prop_timeouts mustTimeout = do
   forAllGenesisTest
 
-    (do gt@GenesisTest{gtChainSyncTimeouts, gtBlockTree} <- genChains (pure 0)
-        let schedule = dullSchedule (fromJust $ mustReplyTimeout gtChainSyncTimeouts) (btTrunk gtBlockTree)
-        pure $ gt $> schedule
+    (do gt@GenesisTest{gtBlockTree} <- genChains (pure 0)
+        pure $ enableMustReplyTimeout $ gt $> dullSchedule (btTrunk gtBlockTree)
     )
-    -- Timeouts are enabled by default
-    defaultSchedulerConfig
+
+    defaultSchedulerConfig {scEnableChainSyncTimeouts = True}
 
     -- Here we can't shrink because we exploit the properties of the point schedule to wait
     -- at the end of the test for the adversaries to get disconnected, by adding an extra point.
@@ -60,9 +60,11 @@ prop_timeouts mustTimeout = do
     )
 
   where
-    dullSchedule :: AF.HasHeader blk => DiffTime -> AF.AnchoredFragment blk -> PointSchedule blk
-    dullSchedule _ (AF.Empty _) = error "requires a non-empty block tree"
-    dullSchedule timeout (_ AF.:> tipBlock) =
+    timeout = 10
+
+    dullSchedule :: AF.HasHeader blk => AF.AnchoredFragment blk -> PointSchedule blk
+    dullSchedule (AF.Empty _) = error "requires a non-empty block tree"
+    dullSchedule (_ AF.:> tipBlock) =
       let offset :: DiffTime = if mustTimeout then 1 else -1
           psSchedule = (if mustTimeout then peersOnlyAdversary else peersOnlyHonest) $ [
               (Time 0, scheduleTipPoint tipBlock),
@@ -72,3 +74,6 @@ prop_timeouts mustTimeout = do
           -- This keeps the test running long enough to pass the timeout by 'offset'.
           psMinEndTime = Time $ timeout + offset
        in PointSchedule {psSchedule, psStartOrder = [], psMinEndTime}
+
+    enableMustReplyTimeout :: GenesisTest blk schedule -> GenesisTest blk schedule
+    enableMustReplyTimeout gt = gt { gtChainSyncTimeouts = (gtChainSyncTimeouts gt) { mustReplyTimeout = Just timeout } }