From 4e561806d5fd71ef2d786995a54cd5c314e3140a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Wed, 18 Dec 2024 18:18:06 +0100 Subject: [PATCH] Rework default ChainSyncTimeouts in peer simulator - Always disable `mustReplyTimeout`; explain why - Always disable `idleTimeout`; explain why - Keep the others by default in all the tests This should fix the bug discussed in https://github.com/IntersectMBO/ouroboros-consensus/pull/1179 --- .../Test/Consensus/Genesis/Setup/GenChains.hs | 43 +++++++------------ .../Test/Consensus/Genesis/Tests/Uniform.hs | 29 ++----------- 2 files changed, 20 insertions(+), 52 deletions(-) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs index 9a7c4d7064..8a3eda8da4 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs @@ -10,13 +10,12 @@ module Test.Consensus.Genesis.Setup.GenChains ( , genChainsWithExtraHonestPeers ) where -import Cardano.Slotting.Time (SlotLength, getSlotLength, - slotLengthFromSec) +import Cardano.Slotting.Time (slotLengthFromSec) import Control.Monad (replicateM) import qualified Control.Monad.Except as Exn import Data.List as List (foldl') import Data.Proxy (Proxy (..)) -import Data.Time.Clock (DiffTime, secondsToDiffTime) +import Data.Time.Clock (DiffTime) import qualified Data.Vector.Unboxed as Vector import Data.Word (Word8) import Ouroboros.Consensus.Block.Abstract hiding (Header) @@ -110,7 +109,7 @@ genChains = genChainsWithExtraHonestPeers (pure 0) -- However, in the future it could also be used to generate "short forks" near the tip of the trunk. genChainsWithExtraHonestPeers :: QC.Gen Word -> QC.Gen Word -> QC.Gen (GenesisTest TestBlock ()) genChainsWithExtraHonestPeers genNumExtraHonest genNumForks = do - (asc, honestRecipe, someHonestChainSchema) <- genHonestChainSchema + (_, honestRecipe, someHonestChainSchema) <- genHonestChainSchema H.SomeHonestChainSchema _ _ honestChainSchema <- pure someHonestChainSchema let ChainSchema _ vH = honestChainSchema @@ -128,8 +127,8 @@ genChainsWithExtraHonestPeers genNumExtraHonest genNumForks = do gtGenesisWindow = GenesisWindow (fromIntegral scg), gtForecastRange = ForecastRange (fromIntegral scg), -- REVIEW: Do we want to generate those randomly? gtDelay = delta, - gtSlotLength, - gtChainSyncTimeouts = chainSyncTimeouts gtSlotLength asc, + gtSlotLength = slotLengthFromSec 20, + gtChainSyncTimeouts = chainSyncTimeouts, gtBlockFetchTimeouts = blockFetchTimeouts, gtLoPBucketParams = LoPBucketParams { lbpCapacity = 50, lbpRate = 10 }, -- These values give little enough leeway (5s) so that some adversaries get disconnected @@ -143,8 +142,6 @@ genChainsWithExtraHonestPeers genNumExtraHonest genNumForks = do } where - gtSlotLength = slotLengthFromSec 20 - genAdversarialFragment :: [TestBlock] -> Int -> (Int, [S]) -> AnchoredFragment TestBlock genAdversarialFragment goodBlocks forkNo (prefixCount, slotsA) = mkTestFragment (mkTestBlocks prefix slotsA forkNo) @@ -169,11 +166,8 @@ genChainsWithExtraHonestPeers genNumExtraHonest genNumForks = do incSlot :: SlotNo -> TestBlock -> TestBlock incSlot n b = b { tbSlot = tbSlot b + n } -chainSyncTimeouts :: - SlotLength -> - Asc -> - ChainSyncTimeout -chainSyncTimeouts t f = +chainSyncTimeouts :: ChainSyncTimeout +chainSyncTimeouts = ChainSyncTimeout { canAwaitTimeout, intersectTimeout, @@ -186,21 +180,16 @@ chainSyncTimeouts t f = intersectTimeout :: Maybe DiffTime intersectTimeout = shortWait idleTimeout :: Maybe DiffTime - idleTimeout = Just 3673 -- taken from Ouroboros.Consensus.Node.stdChainSyncTimeout - -- | The following timeout is derived from the average length of a streak of - -- empty slots. If the probability of the election of a leader is @f@ and - -- @Y@ is a probability, then a streak of empty slots will be shorter than - -- @log (1 - Y) / log (1 - f)@ with probability @Y@. Main net nodes pick a - -- random value for @Y@ between 99.9% and 99.999%. For our use case, we - -- choose the tightest bound of 99.9%. + -- | The default from 'Ouroboros.Consensus.Node.stdChainSyncTimeout' is + -- 3673s, which is virtually infinite, so let us make it actually infinite + -- for our test environment. + idleTimeout = Nothing + -- | The 'mustReplyTimeout' must be disabled in our context, because the + -- chains are finite, and therefore an honest peer can only serve it all, + -- then send 'MsgAwaitReply' (therefore entering 'StMustReply'), and then + -- stall forever, and it must not be killed for it. mustReplyTimeout :: Maybe DiffTime - mustReplyTimeout = - Just $ - secondsToDiffTime $ - round $ - realToFrac (getSlotLength t) - * log (1 - 0.999) - / log (1 - ascVal f) + mustReplyTimeout = Nothing blockFetchTimeouts :: BlockFetchTimeout blockFetchTimeouts = diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs index 7d9022a32e..8370ba9c44 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs @@ -211,7 +211,7 @@ prop_leashingAttackStalling :: Property prop_leashingAttackStalling = forAllGenesisTest - (disableBoringTimeouts <$> genChains (QC.choose (1, 4)) `enrichedWith` genLeashingSchedule) + (genChains (QC.choose (1, 4)) `enrichedWith` genLeashingSchedule) defaultSchedulerConfig { scTrace = False @@ -260,9 +260,7 @@ prop_leashingAttackTimeLimited :: Property prop_leashingAttackTimeLimited = forAllGenesisTest - (disableCanAwaitTimeout . disableBoringTimeouts <$> - genChains (QC.choose (1, 4)) `enrichedWith` genTimeLimitedSchedule - ) + (genChains (QC.choose (1, 4)) `enrichedWith` genTimeLimitedSchedule) defaultSchedulerConfig { scTrace = False @@ -336,15 +334,6 @@ prop_leashingAttackTimeLimited = fromTipPoint (t, ScheduleTipPoint bp) = Just (t, bp) fromTipPoint _ = Nothing - disableCanAwaitTimeout :: GenesisTest blk schedule -> GenesisTest blk schedule - disableCanAwaitTimeout gt = - gt - { gtChainSyncTimeouts = - (gtChainSyncTimeouts gt) - { canAwaitTimeout = Nothing - } - } - headCallStack :: HasCallStack => [a] -> a headCallStack = \case x:_ -> x @@ -398,7 +387,7 @@ prop_loeStalling = prop_downtime :: Property prop_downtime = forAllGenesisTest - (disableBoringTimeouts <$> genChains (QC.choose (1, 4)) `enrichedWith` \ gt -> + (genChains (QC.choose (1, 4)) `enrichedWith` \ gt -> ensureScheduleDuration gt <$> stToGen (uniformPoints (pointsGeneratorParams gt) (gtBlockTree gt))) defaultSchedulerConfig @@ -434,7 +423,7 @@ prop_downtime = forAllGenesisTest prop_blockFetchLeashingAttack :: Property prop_blockFetchLeashingAttack = forAllGenesisTest - (disableBoringTimeouts <$> genChains (pure 0) `enrichedWith` genBlockFetchLeashingSchedule) + (genChains (pure 0) `enrichedWith` genBlockFetchLeashingSchedule) defaultSchedulerConfig { scEnableLoE = True, scEnableLoP = True, @@ -481,13 +470,3 @@ prop_blockFetchLeashingAttack = -- adversarial peer. addGracePeriodDelay :: Int -> Time -> Time addGracePeriodDelay adversaryCount = addTime (fromIntegral adversaryCount * 10) - -disableBoringTimeouts :: GenesisTest blk schedule -> GenesisTest blk schedule -disableBoringTimeouts gt = - gt - { gtChainSyncTimeouts = - (gtChainSyncTimeouts gt) - { mustReplyTimeout = Nothing - , idleTimeout = Nothing - } - }