From 3f8da3b608548e973ead6f2067e55551189b1b7e 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 10:07:55 +0100 Subject: [PATCH 1/7] Improve and clarify CSJ documentation --- .../MiniProtocol/ChainSync/Client/Jumping.hs | 38 ++++++++++++------- 1 file changed, 24 insertions(+), 14 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs index 81c4288ccd..f38656498d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs @@ -115,7 +115,7 @@ -- -- > j ╔════════╗ -- > ╭────────── ║ Dynamo ║ ◀─────────╮ --- > │ ╭──╚════════╝ │f +-- > │ ╭─ ╚════════╝ │f -- > ▼ │ ▲ │ -- > ┌────────────┐ │ │ k ┌──────────┐ -- > │ Disengaged │ ◀─│─────────│────────── │ Objector │ @@ -124,18 +124,23 @@ -- > l│ g│ │e b │ │ │ -- > │ │ │ ╭─────╯ i│ │c -- > ╭╌╌╌▼╌╌╌▼╌╌╌╌╌╌╌╌╌╌╌╌╌│╌╌╌╌╌╌╌╌╌╌│╌▼╌╌╌╮ --- > ┆ ╔═══════╗ a ┌──────┐ d ┌─────┐ | --- > ┆ ║ Happy ║ ───▶ │ LFI* │ ───▶ │ FI* │ | --- > ┆ ╚═══════╝ ◀─╮ └──────┘ └─────┘ | --- > ┆ Jumper ╰─────┴────────────╯h | +-- > ┆ ╔═══════╗ a ┌──────┐ d ┌─────┐ ┆ +-- > ┆ ║ Happy ║ ───▶ │ LFI* │ ───▶ │ FI* │ ┆ +-- > ┆ ╚═══════╝ ◀─╮ └──────┘ └─────┘ ┆ +-- > ┆ Jumper ╰─────┴────────────╯h ┆ -- > ╰╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╯ -- -- *: LookingForIntersection and FoundIntersection, abbreviated for this -- drawing only; this abbreviation will not be used elsewhere. -- +-- In the following walk-through, we will point to transitions in the drawing +-- between parentheses, like so: (a) (b+c) (e|f). We will use `+` to express +-- that both transitions happen simultaneously (for different peers) and `|` to +-- express a choice. +-- -- A new peer starts as the dynamo if there is no other peer or as a Happy -- jumper otherwise. The dynamo periodically requests jumps from happy --- jumpers who, in the ideal case, accept them. +-- jumpers who, in the ideal case, accept them and remain happy jumpers. -- -- In the event that a jumper rejects a jump, it goes from Happy to LFI* (a). -- From there starts a back-and-forth of intersection search messages until @@ -143,29 +148,34 @@ -- -- Once the exact point of disagreement is found, and if there is no objector -- yet, the jumper becomes the objector (b). If there is an objector, then we --- compare the intersections of the objector and the jumper. If the jumper's --- intersection is strictly older, then the jumper replaces the objector (b+c). +-- compare the intersection of the objector with the dynamo and the intersection +-- of the jumper with the dynamo. If the jumper's intersection is strictly +-- older, then the jumper replaces the objector, who is marked as FI* (b+c). -- Otherwise, the jumper is marked as FI* (d). -- -- If the dynamo disconnects or is disengaged, one peer is elected as the new --- dynamo (e|f) and all other peers revert to being happy jumpers (g+h). +-- dynamo (e|f) and all the other peers revert to being happy jumpers (g+h). -- -- If the objector disconnects or is disengaged, and there are FI* jumpers, then -- the one with the oldest intersection with the dynamo gets elected (i). +-- Otherwise, we are left with no dynamo. -- -- If the dynamo rolls back to a point older than the last jump it requested, it --- is disengaged (j) and a new dynamo is elected (e|f). +-- is disengaged (j), a new dynamo is elected (e|f), and all the other peers +-- revert to being happy jumpers (g+h). -- -- If the objector agrees with the dynamo, it is disengaged (k). If there are -- FI* jumpers, then one of them gets elected as the new objector (i). +-- Otherwise, we are left with no dynamo. -- --- If dynamo or objector claim to have no more headers, they are disengaged --- (j|k). +-- If the dynamo or the objector claim to have no more headers, they are +-- disengaged (j|k), triggering the same chain of effect as described in the two +-- previous points. -- -- The BlockFetch logic can ask to change the dynamo if it is not serving blocks -- fast enough. If there are other non-disengaged peers, the dynamo (and the --- objector if there is one) is demoted to a jumper (l+g) and a new dynamo is --- elected. +-- objector if there is one, and all the other peers) is demoted to a happy +-- jumper (l+g+h) and a new dynamo is elected (e). -- module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping ( Context From ef092ca7590efc534a322d0b29e09f2bcacbdaf4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 19 Dec 2024 11:00:59 +0100 Subject: [PATCH 2/7] Add a `TraceDrainingThePipe` event --- .../Test/Consensus/PeerSimulator/Trace.hs | 2 ++ .../Consensus/MiniProtocol/ChainSync/Client.hs | 12 +++++------- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs index 2d439c0de7..f5ee5891ad 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs @@ -419,6 +419,8 @@ traceChainSyncClientEventTestBlockWith pid tracer = \case trace "Waiting for next instruction from the jumping governor" TraceJumpingInstructionIs instr -> trace $ "Received instruction: " ++ showInstr instr + TraceDrainingThePipe n -> + trace $ "Draining the pipe, remaining messages: " ++ show n where trace = traceUnitWith tracer ("ChainSyncClient " ++ condense pid) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs index 64ee449168..d9a70817d9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs @@ -917,7 +917,9 @@ chainSyncClient cfgEnv dynEnv = Nat n' -> s -> m (Consensus (ClientPipelinedStIdle n') blk m) - go n s = case n of + go n s = do + traceWith tracer $ TraceDrainingThePipe n + case n of Zero -> continueWithState s m Succ n' -> return $ CollectResponse Nothing $ ClientStNext { recvMsgRollForward = \_hdr _tip -> go n' s @@ -2334,12 +2336,8 @@ data TraceChainSyncClientEvent blk = | TraceJumpingInstructionIs (Jumping.Instruction blk) -- ^ ChainSync Jumping -- the ChainSync client got its next instruction. - -deriving instance - ( BlockSupportsProtocol blk - , Eq (Header blk) - ) - => Eq (TraceChainSyncClientEvent blk) + | + forall n. TraceDrainingThePipe (Nat n) deriving instance ( BlockSupportsProtocol blk From 7b04c2822b1abdcb11c45b6324d970603397fffa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 19 Dec 2024 11:01:44 +0100 Subject: [PATCH 3/7] Make the `DynamoStarting` trace more explicit --- .../test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs index f5ee5891ad..6dbc1550dd 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs @@ -238,7 +238,7 @@ traceSchedulerEventTestBlockWith setTickTime tracer0 tracer = \case traceJumpingState = \case Dynamo initState lastJump -> let showInitState = case initState of - DynamoStarting ji -> terseJumpInfo ji + DynamoStarting ji -> "(DynamoStarting " ++ terseJumpInfo ji ++ ")" DynamoStarted -> "DynamoStarted" in unwords ["Dynamo", showInitState, terseWithOrigin show lastJump] Objector initState goodJumpInfo badPoint -> unwords From bee2c84451f88b806e40d196538bbe6b6f548503 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 19 Dec 2024 11:47:03 +0100 Subject: [PATCH 4/7] Log ChainSync mini-protocol events if need be --- .../Test/Consensus/PeerSimulator/ChainSync.hs | 8 +++-- .../Test/Consensus/PeerSimulator/Trace.hs | 33 +++++++++++++++++++ 2 files changed, 38 insertions(+), 3 deletions(-) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs index c2e3ee847b..d0b63d10b8 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs @@ -165,7 +165,7 @@ runChainSyncClient res <- try $ runPipelinedPeerWithLimits - nullTracer + (Tracer $ traceWith tracer . TraceChainSyncSendRecvEvent peerId "Client") codecChainSyncId chainSyncNoSizeLimits (timeLimitsChainSync chainSyncTimeouts) @@ -218,8 +218,8 @@ runChainSyncServer :: ChainSyncServer (Header blk) (Point blk) (Tip blk) m () -> Channel m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))) -> m () -runChainSyncServer _tracer peerId StateViewTracers {svtPeerSimulatorResultsTracer} server channel = - (try $ runPeer nullTracer codecChainSyncId channel (chainSyncServerPeer server)) >>= \case +runChainSyncServer tracer peerId StateViewTracers {svtPeerSimulatorResultsTracer} server channel = + (try $ runPeer sendRecvTracer codecChainSyncId channel (chainSyncServerPeer server)) >>= \case Right ((), msgRes) -> traceWith svtPeerSimulatorResultsTracer $ PeerSimulatorResult peerId $ SomeChainSyncServerResult $ Right msgRes Left exn -> do @@ -228,3 +228,5 @@ runChainSyncServer _tracer peerId StateViewTracers {svtPeerSimulatorResultsTrace -- NOTE: here we are able to trace exceptions, as what is done in `runChainSyncClient` case fromException exn of (_ :: Maybe SomeException) -> pure () + where + sendRecvTracer = Tracer $ traceWith tracer . TraceChainSyncSendRecvEvent peerId "Server" diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs index 6dbc1550dd..b412696e55 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs @@ -25,6 +25,7 @@ import Data.Bifunctor (second) import Data.List (intersperse) import qualified Data.List.NonEmpty as NE import Data.Time.Clock (DiffTime, diffTimeToPicoseconds) +import Network.TypedProtocol.Codec (AnyMessage (..)) import Ouroboros.Consensus.Block (GenesisWindow (..), Header, Point, WithOrigin (NotOrigin, Origin), succWithOrigin) import Ouroboros.Consensus.Genesis.Governor (DensityBounds (..), @@ -49,6 +50,9 @@ import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headPoint) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (SlotNo (SlotNo), Tip, castPoint) +import Ouroboros.Network.Driver.Simple (TraceSendRecv (..)) +import Ouroboros.Network.Protocol.ChainSync.Type (ChainSync, + Message (..)) import Test.Consensus.PointSchedule.NodeState (NodeState) import Test.Consensus.PointSchedule.Peers (Peer (Peer), PeerId) import Test.Util.TersePrinting (terseAnchor, terseBlock, @@ -130,6 +134,7 @@ data TraceEvent blk | TraceChainSyncClientTerminationEvent PeerId TraceChainSyncClientTerminationEvent | TraceBlockFetchClientTerminationEvent PeerId TraceBlockFetchClientTerminationEvent | TraceGenesisDDEvent (TraceGDDEvent PeerId blk) + | TraceChainSyncSendRecvEvent PeerId String (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))) | TraceOther String -- * 'TestBlock'-specific tracers for the peer simulator @@ -182,6 +187,7 @@ traceEventTestBlockWith setTickTime tracer0 tracer = \case TraceChainSyncClientTerminationEvent peerId traceEvent -> traceChainSyncClientTerminationEventTestBlockWith peerId tracer traceEvent TraceBlockFetchClientTerminationEvent peerId traceEvent -> traceBlockFetchClientTerminationEventTestBlockWith peerId tracer traceEvent TraceGenesisDDEvent gddEvent -> traceWith tracer (terseGDDEvent gddEvent) + TraceChainSyncSendRecvEvent peerId peerType traceEvent -> traceChainSyncSendRecvEventTestBlockWith peerId peerType tracer traceEvent TraceOther msg -> traceWith tracer msg traceSchedulerEventTestBlockWith :: @@ -464,6 +470,33 @@ traceBlockFetchClientTerminationEventTestBlockWith pid tracer = \case where trace = traceUnitWith tracer ("BlockFetchClient " ++ condense pid) +-- | Trace all the SendRecv events of the ChainSync mini-protocol. +traceChainSyncSendRecvEventTestBlockWith :: + Applicative m => + PeerId -> + String -> + Tracer m String -> + TraceSendRecv (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)) -> + m () +traceChainSyncSendRecvEventTestBlockWith pid ptp tracer = \case + TraceSendMsg amsg -> traceMsg "send" amsg + TraceRecvMsg amsg -> traceMsg "recv" amsg + where + -- This can be very verbose and is only useful in rare situations, so it + -- does nothing by default. + -- trace = traceUnitWith tracer ("ChainSync " ++ condense pid) . ((ptp ++ " ") ++) + trace = (\_ _ _ -> const (pure ())) pid ptp tracer + traceMsg kd amsg = trace $ kd ++ " " ++ case amsg of + AnyMessage msg -> case msg of + MsgRequestNext -> "MsgRequestNext" + MsgAwaitReply -> "MsgAwaitReply" + MsgRollForward header tip -> "MsgRollForward " ++ terseHeader header ++ " " ++ terseTip tip + MsgRollBackward point tip -> "MsgRollBackward " ++ tersePoint point ++ " " ++ terseTip tip + MsgFindIntersect points -> "MsgFindIntersect [" ++ unwords (map tersePoint points) ++ "]" + MsgIntersectFound point tip -> "MsgIntersectFound " ++ tersePoint point ++ " " ++ terseTip tip + MsgIntersectNotFound tip -> "MsgIntersectNotFound " ++ terseTip tip + MsgDone -> "MsgDone" + prettyDensityBounds :: [(PeerId, DensityBounds TestBlock)] -> [String] prettyDensityBounds bounds = showPeers (second showBounds <$> bounds) 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 5/7] 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 - } - } From 513f34756c4e7bd68d854b16f6cf9a7cd8c04514 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 19 Dec 2024 13:24:44 +0100 Subject: [PATCH 6/7] Fix tests that relied on default timeouts --- .../PeerSimulator/Tests/LinkedThreads.hs | 28 ++++++++++++------- .../Consensus/PeerSimulator/Tests/Timeouts.hs | 25 ++++++++++------- 2 files changed, 33 insertions(+), 20 deletions(-) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs index c7e6a69e3e..c5c2cad189 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs +++ b/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 } } diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs index e4147a2ecd..5d45137f09 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs +++ b/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 } } From a36fd875dd1c7068cff4e4a39bcbdc11d9fdd1be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 19 Dec 2024 18:16:36 +0100 Subject: [PATCH 7/7] Enrich comment about disabled `mustReplyTimeout` Co-authored-by: Nicolas Frisby --- .../Test/Consensus/Genesis/Setup/GenChains.hs | 6 ++++++ 1 file changed, 6 insertions(+) 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 8a3eda8da4..e6ec79b721 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 @@ -188,6 +188,12 @@ chainSyncTimeouts = -- 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. + -- + -- Note that this allows the adversaries to stall us forever in that same + -- situation. However, that peer is only allowed to send 'MsgAwaitReply' + -- when they have served their tip, which leaves them fully vulnerable to + -- the Genesis Density Disconnection (GDD) logic. A bug related to this + -- disabled timeout is in fact either a bug in the GDD or in the tests. mustReplyTimeout :: Maybe DiffTime mustReplyTimeout = Nothing