Disable blockfetch timeouts in uniform tests

Author: facundominguez

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs

@@ -285,7 +285,7 @@ prop_leashingAttackTimeLimited =
       pure $ PointSchedule
         { psSchedule = Peers honests advs
         , psStartOrder = []
-        , psMinEndTime = timeLimit
+        , psMinEndTime = addGracePeriodDelay (length advs) timeLimit
         }
 
     takePointsUntil limit = takeWhile ((<= limit) . fst)
@@ -361,7 +361,8 @@ prop_loeStalling =
 
     defaultSchedulerConfig {
       scEnableLoE = True,
-      scEnableCSJ = True
+      scEnableCSJ = True,
+      scEnableBlockFetchTimeouts = False
     }
 
     shrinkPeerSchedules
@@ -402,6 +403,7 @@ prop_downtime = forAllGenesisTest
       , scEnableLoP = True
       , scDowntime = Just 11
       , scEnableCSJ = True
+      , scEnableBlockFetchTimeouts = False
       }
 
     shrinkPeerSchedules
@@ -433,7 +435,8 @@ prop_blockFetchLeashingAttack =
     defaultSchedulerConfig
       { scEnableLoE = True,
         scEnableLoP = True,
-        scEnableCSJ = True
+        scEnableCSJ = True,
+        scEnableBlockFetchTimeouts = False
       }
     shrinkPeerSchedules
     theProperty
@@ -455,7 +458,7 @@ prop_blockFetchLeashingAttack =
       -- Important to shuffle the order in which the peers start, otherwise the
       -- honest peer starts first and systematically becomes dynamo.
       psStartOrder <- shuffle $ getPeerIds psSchedule'
-      let maxTime = maximum $
+      let maxTime = addGracePeriodDelay (length adversaries') $ maximum $
             Time 0 : [ pt | s <- honest : adversaries', (pt, _) <- take 1 (reverse s) ]
       pure $ PointSchedule {
           psSchedule = psSchedule',
@@ -470,6 +473,12 @@ prop_blockFetchLeashingAttack =
     isBlockPoint (ScheduleBlockPoint _) = True
     isBlockPoint _                      = False
 
+-- | Add a delay at the end of tests to account for retention of blocks
+-- by adversarial peers in blockfetch. This delay is 10 seconds per
+-- adversarial peer.
+addGracePeriodDelay :: Int -> Time -> Time
+addGracePeriodDelay adversaryCount = addTime (fromIntegral adversaryCount * 10)
+
 disableBoringTimeouts :: GenesisTest blk schedule -> GenesisTest blk schedule
 disableBoringTimeouts gt =
     gt

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

@@ -55,6 +55,7 @@ import           Control.Monad.ST (ST)
 import           Data.Bifunctor (first)
 import           Data.Functor (($>))
 import           Data.List (mapAccumL, partition, scanl')
+import qualified Data.Map.Strict as Map
 import           Data.Maybe (catMaybes, fromMaybe, mapMaybe)
 import           Data.Time (DiffTime)
 import           Data.Word (Word64)
@@ -599,10 +600,12 @@ ensureScheduleDuration gt PointSchedule{psSchedule, psStartOrder, psMinEndTime}
     endingDelay =
      let cst = gtChainSyncTimeouts gt
          bft = gtBlockFetchTimeouts gt
-      in 1 + fromIntegral peerCount * maximum (0 : catMaybes
+         bfGracePeriodDelay = fromIntegral adversaryCount * 10
+      in 1 + bfGracePeriodDelay + fromIntegral peerCount * maximum (0 : catMaybes
            [ canAwaitTimeout cst
            , intersectTimeout cst
            , busyTimeout bft
            , streamingTimeout bft
            ])
     peerCount = length (peersList psSchedule)
+    adversaryCount = Map.size (adversarialPeers psSchedule)