{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | ChainSync Jumping tests.
module Test.Consensus.Genesis.Tests.CSJ
  ( TestKey
  , testSuite
  ) where

import Data.List (nub)
import qualified Data.Map.Strict as Map
import Data.Maybe (mapMaybe)
import Ouroboros.Consensus.Block
  ( HasHeader
  , Header
  , blockSlot
  , succWithOrigin
  , unSlotNo
  )
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client
  ( TraceChainSyncClientEvent (..)
  )
import Ouroboros.Consensus.Util.Condense
  ( Condense
  , PaddingDirection (..)
  , condenseListWithPadding
  )
import qualified Ouroboros.Network.AnchoredFragment as AF
import Test.Consensus.BlockTree (BlockTree (..))
import Test.Consensus.Genesis.Setup
import Test.Consensus.Genesis.TestSuite
import Test.Consensus.Genesis.Tests.Uniform (genUniformSchedulePoints)
import Test.Consensus.PeerSimulator.Run
  ( SchedulerConfig (..)
  , defaultSchedulerConfig
  )
import Test.Consensus.PeerSimulator.StateView (StateView (..))
import Test.Consensus.PeerSimulator.Trace (TraceEvent (..))
import Test.Consensus.PointSchedule
import Test.Consensus.PointSchedule.Peers (Peers (..), peers')
import qualified Test.Consensus.PointSchedule.Peers as Peers
import Test.Consensus.PointSchedule.Shrinking (shrinkPeerSchedules)
import Test.Tasty.QuickCheck
import Test.Util.Orphans.IOLike ()
import Test.Util.PartialAccessors

-- | Default adjustment of the required number of test runs.
-- Can be set individually on each test definition.
adjustTestCount :: AdjustTestCount
adjustTestCount :: AdjustTestCount
adjustTestCount = (Int -> Int) -> AdjustTestCount
AdjustTestCount (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10)

-- | Default adjustment of max test case size.
-- Can be set individually on each test definition.
adjustMaxSize :: AdjustMaxSize
adjustMaxSize :: AdjustMaxSize
adjustMaxSize = (Int -> Int) -> AdjustMaxSize
AdjustMaxSize (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5)

-- | Each value of this type uniquely corresponds to a test defined in this module.
data TestKey
  = WithNoAdversariesAndOneScheduleForAllPeers
  | WithNoAdversariesAndOneSchedulePerHonestPeer
  | WithAdversariesAndOneScheduleForAllPeers
  | WithAdversariesAndOneSchedulePerHonestPeer
  deriving stock (TestKey -> TestKey -> Bool
(TestKey -> TestKey -> Bool)
-> (TestKey -> TestKey -> Bool) -> Eq TestKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestKey -> TestKey -> Bool
== :: TestKey -> TestKey -> Bool
$c/= :: TestKey -> TestKey -> Bool
/= :: TestKey -> TestKey -> Bool
Eq, Eq TestKey
Eq TestKey =>
(TestKey -> TestKey -> Ordering)
-> (TestKey -> TestKey -> Bool)
-> (TestKey -> TestKey -> Bool)
-> (TestKey -> TestKey -> Bool)
-> (TestKey -> TestKey -> Bool)
-> (TestKey -> TestKey -> TestKey)
-> (TestKey -> TestKey -> TestKey)
-> Ord TestKey
TestKey -> TestKey -> Bool
TestKey -> TestKey -> Ordering
TestKey -> TestKey -> TestKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TestKey -> TestKey -> Ordering
compare :: TestKey -> TestKey -> Ordering
$c< :: TestKey -> TestKey -> Bool
< :: TestKey -> TestKey -> Bool
$c<= :: TestKey -> TestKey -> Bool
<= :: TestKey -> TestKey -> Bool
$c> :: TestKey -> TestKey -> Bool
> :: TestKey -> TestKey -> Bool
$c>= :: TestKey -> TestKey -> Bool
>= :: TestKey -> TestKey -> Bool
$cmax :: TestKey -> TestKey -> TestKey
max :: TestKey -> TestKey -> TestKey
$cmin :: TestKey -> TestKey -> TestKey
min :: TestKey -> TestKey -> TestKey
Ord, (forall x. TestKey -> Rep TestKey x)
-> (forall x. Rep TestKey x -> TestKey) -> Generic TestKey
forall x. Rep TestKey x -> TestKey
forall x. TestKey -> Rep TestKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestKey -> Rep TestKey x
from :: forall x. TestKey -> Rep TestKey x
$cto :: forall x. Rep TestKey x -> TestKey
to :: forall x. Rep TestKey x -> TestKey
Generic)
  deriving [TestKey]
[TestKey] -> SmallKey TestKey
forall a. [a] -> SmallKey a
$callKeys :: [TestKey]
allKeys :: [TestKey]
SmallKey via Generically TestKey

testSuite ::
  ( HasHeader blk
  , HasHeader (Header blk)
  , IssueTestBlock blk
  , Ord blk
  , Condense (Header blk)
  , Eq (Header blk)
  ) =>
  TestSuite blk TestKey
testSuite :: forall blk.
(HasHeader blk, HasHeader (Header blk), IssueTestBlock blk,
 Ord blk, Condense (Header blk), Eq (Header blk)) =>
TestSuite blk TestKey
testSuite =
  let keyToFlags :: TestKey -> (WithAdversariesFlag, NumHonestSchedulesFlag)
      keyToFlags :: TestKey -> (WithAdversariesFlag, NumHonestSchedulesFlag)
keyToFlags = \case
        TestKey
WithNoAdversariesAndOneScheduleForAllPeers -> (WithAdversariesFlag
NoAdversaries, NumHonestSchedulesFlag
OneScheduleForAllPeers)
        TestKey
WithNoAdversariesAndOneSchedulePerHonestPeer -> (WithAdversariesFlag
NoAdversaries, NumHonestSchedulesFlag
OneSchedulePerHonestPeer)
        TestKey
WithAdversariesAndOneScheduleForAllPeers -> (WithAdversariesFlag
WithAdversaries, NumHonestSchedulesFlag
OneScheduleForAllPeers)
        TestKey
WithAdversariesAndOneSchedulePerHonestPeer -> (WithAdversariesFlag
WithAdversaries, NumHonestSchedulesFlag
OneSchedulePerHonestPeer)
      groupName :: TestKey -> String
groupName TestKey
key = case (WithAdversariesFlag, NumHonestSchedulesFlag)
-> WithAdversariesFlag
forall a b. (a, b) -> a
fst (TestKey -> (WithAdversariesFlag, NumHonestSchedulesFlag)
keyToFlags TestKey
key) of
        WithAdversariesFlag
NoAdversaries -> String
"Happy path"
        WithAdversariesFlag
WithAdversaries -> String
"With some adversaries"
      testDescription :: TestKey -> String
testDescription TestKey
key = case (WithAdversariesFlag, NumHonestSchedulesFlag)
-> NumHonestSchedulesFlag
forall a b. (a, b) -> b
snd (TestKey -> (WithAdversariesFlag, NumHonestSchedulesFlag)
keyToFlags TestKey
key) of
        NumHonestSchedulesFlag
OneScheduleForAllPeers -> String
"honest peers are synchronised"
        NumHonestSchedulesFlag
OneSchedulePerHonestPeer -> String
"honest peers do their own thing"
   in String -> TestSuite blk TestKey -> TestSuite blk TestKey
forall blk key. String -> TestSuite blk key -> TestSuite blk key
group String
"CSJ" (TestSuite blk TestKey -> TestSuite blk TestKey)
-> TestSuite blk TestKey -> TestSuite blk TestKey
forall a b. (a -> b) -> a -> b
$
        (TestKey -> String)
-> TestSuite blk TestKey -> TestSuite blk TestKey
forall key blk.
(key -> String) -> TestSuite blk key -> TestSuite blk key
grouping TestKey -> String
groupName (TestSuite blk TestKey -> TestSuite blk TestKey)
-> TestSuite blk TestKey -> TestSuite blk TestKey
forall a b. (a -> b) -> a -> b
$
          (TestKey -> ConformanceTest blk) -> TestSuite blk TestKey
forall key blk.
(Ord key, SmallKey key) =>
(key -> ConformanceTest blk) -> TestSuite blk key
newTestSuite ((TestKey -> ConformanceTest blk) -> TestSuite blk TestKey)
-> (TestKey -> ConformanceTest blk) -> TestSuite blk TestKey
forall a b. (a -> b) -> a -> b
$
            \TestKey
key -> (WithAdversariesFlag
 -> NumHonestSchedulesFlag -> ConformanceTest blk)
-> (WithAdversariesFlag, NumHonestSchedulesFlag)
-> ConformanceTest blk
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String
-> WithAdversariesFlag
-> NumHonestSchedulesFlag
-> ConformanceTest blk
forall blk.
(HasHeader blk, HasHeader (Header blk), IssueTestBlock blk,
 Ord blk, Condense (Header blk), Eq (Header blk)) =>
String
-> WithAdversariesFlag
-> NumHonestSchedulesFlag
-> ConformanceTest blk
testCsj (String
 -> WithAdversariesFlag
 -> NumHonestSchedulesFlag
 -> ConformanceTest blk)
-> String
-> WithAdversariesFlag
-> NumHonestSchedulesFlag
-> ConformanceTest blk
forall a b. (a -> b) -> a -> b
$ TestKey -> String
testDescription TestKey
key) (TestKey -> (WithAdversariesFlag, NumHonestSchedulesFlag)
keyToFlags TestKey
key)

-- | A flag to indicate if properties are tested with adversarial peers
data WithAdversariesFlag = NoAdversaries | WithAdversaries
  deriving stock WithAdversariesFlag -> WithAdversariesFlag -> Bool
(WithAdversariesFlag -> WithAdversariesFlag -> Bool)
-> (WithAdversariesFlag -> WithAdversariesFlag -> Bool)
-> Eq WithAdversariesFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WithAdversariesFlag -> WithAdversariesFlag -> Bool
== :: WithAdversariesFlag -> WithAdversariesFlag -> Bool
$c/= :: WithAdversariesFlag -> WithAdversariesFlag -> Bool
/= :: WithAdversariesFlag -> WithAdversariesFlag -> Bool
Eq

-- | A flag to indicate if properties are tested using the same schedule for the
-- honest peers, or if each peer should used its own schedule.
data NumHonestSchedulesFlag = OneScheduleForAllPeers | OneSchedulePerHonestPeer

-- | Test of ChainSync Jumping (CSJ).
--
-- This test features several peers that all sync the “honest” chain (ie. the
-- trunk of the block tree) with CSJ enabled. What we expect to observe is that
-- one of the honest peers becomes the dynamo while the others become jumpers.
-- Because the jumpers will agree to all the jumps, the whole syncing should
-- happen with CSJ.
--
-- There are two variants of this test: the “happy path” variant features no
-- adversaries. As such, everything should happen with one dynamo and no
-- objector. Another variant adds adversaries, so we expect to see some
-- dynamo-vs-objector action.
--
-- Regardless, the final property is that “honest” headers should only ever be
-- downloaded at most once from honest peers. They may however be downloaded
-- several times from adversaries. This is true except when almost caught-up:
-- when the dynamo or objector is caught-up, it gets disengaged and one of the
-- jumpers takes its place and starts serving headers. This might lead to
-- duplication of headers, but only in a window of @jumpSize@ slots near the tip
-- of the chain.
testCsj ::
  forall blk.
  ( HasHeader blk
  , HasHeader (Header blk)
  , IssueTestBlock blk
  , Ord blk
  , Condense (Header blk)
  , Eq (Header blk)
  ) =>
  String -> WithAdversariesFlag -> NumHonestSchedulesFlag -> ConformanceTest blk
testCsj :: forall blk.
(HasHeader blk, HasHeader (Header blk), IssueTestBlock blk,
 Ord blk, Condense (Header blk), Eq (Header blk)) =>
String
-> WithAdversariesFlag
-> NumHonestSchedulesFlag
-> ConformanceTest blk
testCsj String
description WithAdversariesFlag
adversariesFlag NumHonestSchedulesFlag
numHonestSchedules = do
  let genForks :: Gen Word
genForks = case WithAdversariesFlag
adversariesFlag of
        WithAdversariesFlag
NoAdversaries -> Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
0
        WithAdversariesFlag
WithAdversaries -> (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
2, Word
4)
  String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> Property)
-> ConformanceTest blk
forall prop blk.
Testable prop =>
String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> prop)
-> ConformanceTest blk
mkConformanceTest
    String
description
    AdjustTestCount
adjustTestCount
    AdjustMaxSize
adjustMaxSize
    ( GenesisTestFull blk -> GenesisTestFull blk
forall {blk} {schedule}.
GenesisTest blk schedule -> GenesisTest blk schedule
disableBoringTimeouts (GenesisTestFull blk -> GenesisTestFull blk)
-> Gen (GenesisTestFull blk) -> Gen (GenesisTestFull blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case NumHonestSchedulesFlag
numHonestSchedules of
        NumHonestSchedulesFlag
OneScheduleForAllPeers ->
          Gen Word -> Gen (GenesisTest blk ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
genChains Gen Word
genForks
            Gen (GenesisTest blk ())
-> (GenesisTest blk () -> Gen (PointSchedule blk))
-> Gen (GenesisTestFull blk)
forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
`enrichedWith` GenesisTest blk () -> Gen (PointSchedule blk)
genDuplicatedHonestSchedule
        NumHonestSchedulesFlag
OneSchedulePerHonestPeer ->
          Gen Word -> Gen Word -> Gen (GenesisTest blk ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen Word -> Gen (GenesisTest blk ())
genChainsWithExtraHonestPeers ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
2, Word
4)) Gen Word
genForks
            Gen (GenesisTest blk ())
-> (GenesisTest blk () -> Gen (PointSchedule blk))
-> Gen (GenesisTestFull blk)
forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
`enrichedWith` GenesisTest blk () -> Gen (PointSchedule blk)
forall blk.
HasHeader blk =>
GenesisTest blk () -> Gen (PointSchedule blk)
genUniformSchedulePoints
    )
    ( SchedulerConfig
defaultSchedulerConfig
        { scEnableCSJ = True
        , scEnableLoE = True
        , scEnableLoP = True
        , scEnableChainSelStarvation = adversariesFlag == NoAdversaries
        }
    )
    -- \^ NOTE: When there are adversaries and the ChainSel
    -- starvation detection of BlockFetch is enabled, then our property does
    -- not actually hold, because peer simulator-based tests have virtually
    -- infinite CPU, and therefore ChainSel gets starved at every tick, which
    -- makes us cycle the dynamos, which can lead to some extra headers being
    -- downloaded.

    GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
forall blk.
(HasHeader blk, Ord blk) =>
GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
shrinkPeerSchedules
    ( \GenesisTestFull blk
gt StateView{[TraceEvent blk]
svTrace :: [TraceEvent blk]
svTrace :: forall blk. StateView blk -> [TraceEvent blk]
svTrace} ->
        let
          -- The list of 'TraceDownloadedHeader' events that are not newer than
          -- jumpSize from the tip of the chain. These are the ones that we
          -- expect to see only once per header if CSJ works properly.
          headerHonestDownloadEvents :: [(PeerId, Header blk)]
headerHonestDownloadEvents =
            (TraceEvent blk -> Maybe (PeerId, Header blk))
-> [TraceEvent blk] -> [(PeerId, Header blk)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
              ( \case
                  TraceChainSyncClientEvent PeerId
pid (TraceDownloadedHeader Header blk
hdr)
                    | Bool -> Bool
not (GenesisTestFull blk -> Header blk -> Bool
isNewerThanJumpSizeFromTip GenesisTestFull blk
gt Header blk
hdr)
                    , Peers.HonestPeer Int
_ <- PeerId
pid ->
                        (PeerId, Header blk) -> Maybe (PeerId, Header blk)
forall a. a -> Maybe a
Just (PeerId
pid, Header blk
hdr)
                  TraceEvent blk
_ -> Maybe (PeerId, Header blk)
forall a. Maybe a
Nothing
              )
              [TraceEvent blk]
svTrace
          -- We receive headers at most once from honest peer. The only
          -- exception is when an honest peer gets to be the objector, until an
          -- adversary dies, and then the dynamo. In that specific case, we
          -- might re-download jumpSize blocks. TODO: If we ever choose to
          -- promote objectors to dynamo to reuse their state, then we could
          -- make this bound tighter.
          receivedHeadersAtMostOnceFromHonestPeers :: Bool
receivedHeadersAtMostOnceFromHonestPeers =
            [(PeerId, Header blk)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PeerId, Header blk)]
headerHonestDownloadEvents
              Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [Header blk] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Header blk] -> [Header blk]
forall a. Eq a => [a] -> [a]
nub ([Header blk] -> [Header blk]) -> [Header blk] -> [Header blk]
forall a b. (a -> b) -> a -> b
$ (PeerId, Header blk) -> Header blk
forall a b. (a, b) -> b
snd ((PeerId, Header blk) -> Header blk)
-> [(PeerId, Header blk)] -> [Header blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, Header blk)]
headerHonestDownloadEvents)
                Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo (SlotNo -> Word64) -> SlotNo -> Word64
forall a b. (a -> b) -> a -> b
$ CSJParams -> SlotNo
csjpJumpSize (CSJParams -> SlotNo) -> CSJParams -> SlotNo
forall a b. (a -> b) -> a -> b
$ GenesisTestFull blk -> CSJParams
forall blk schedule. GenesisTest blk schedule -> CSJParams
gtCSJParams GenesisTestFull blk
gt)
         in
          String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate
            String
""
            [ if [(PeerId, Header blk)]
headerHonestDownloadEvents [(PeerId, Header blk)] -> [(PeerId, Header blk)] -> Bool
forall a. Eq a => a -> a -> Bool
== []
                then String
"All headers are within the last jump window"
                else String
"There exist headers that have to be downloaded exactly once"
            ]
            (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
              ( String
"Downloaded headers (except jumpSize slots near the tip):\n"
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ ( [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                         (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
                           (String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                             (\String
peer String
header -> String
peer String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" | " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
header)
                             (PaddingDirection -> [PeerId] -> [String]
forall a. Condense a => PaddingDirection -> [a] -> [String]
condenseListWithPadding PaddingDirection
PadRight ([PeerId] -> [String]) -> [PeerId] -> [String]
forall a b. (a -> b) -> a -> b
$ (PeerId, Header blk) -> PeerId
forall a b. (a, b) -> a
fst ((PeerId, Header blk) -> PeerId)
-> [(PeerId, Header blk)] -> [PeerId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, Header blk)]
headerHonestDownloadEvents)
                             (PaddingDirection -> [Header blk] -> [String]
forall a. Condense a => PaddingDirection -> [a] -> [String]
condenseListWithPadding PaddingDirection
PadRight ([Header blk] -> [String]) -> [Header blk] -> [String]
forall a b. (a -> b) -> a -> b
$ (PeerId, Header blk) -> Header blk
forall a b. (a, b) -> b
snd ((PeerId, Header blk) -> Header blk)
-> [(PeerId, Header blk)] -> [Header blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, Header blk)]
headerHonestDownloadEvents)
                     )
              )
              Bool
receivedHeadersAtMostOnceFromHonestPeers
    )
 where
  genDuplicatedHonestSchedule :: GenesisTest blk () -> Gen (PointSchedule blk)
  genDuplicatedHonestSchedule :: GenesisTest blk () -> Gen (PointSchedule blk)
genDuplicatedHonestSchedule gt :: GenesisTest blk ()
gt@GenesisTest{Word
gtExtraHonestPeers :: Word
gtExtraHonestPeers :: forall blk schedule. GenesisTest blk schedule -> Word
gtExtraHonestPeers} = do
    ps@PointSchedule{psSchedule = Peers{honestPeers, adversarialPeers}} <- GenesisTest blk () -> Gen (PointSchedule blk)
forall blk.
HasHeader blk =>
GenesisTest blk () -> Gen (PointSchedule blk)
genUniformSchedulePoints GenesisTest blk ()
gt
    pure $
      ps
        { psSchedule =
            Peers.unionWithKey
              (\PeerId
_ PeerSchedule blk
_ PeerSchedule blk
_ -> String -> PeerSchedule blk
forall a. HasCallStack => String -> a
error String
"should not happen")
              ( peers'
                  (replicate (fromIntegral gtExtraHonestPeers + 1) (getHonestPeer honestPeers))
                  []
              )
              (Peers Map.empty adversarialPeers)
        }

  isNewerThanJumpSizeFromTip :: GenesisTestFull blk -> Header blk -> Bool
  isNewerThanJumpSizeFromTip :: GenesisTestFull blk -> Header blk -> Bool
isNewerThanJumpSizeFromTip GenesisTestFull blk
gt Header blk
hdr =
    let jumpSize :: SlotNo
jumpSize = CSJParams -> SlotNo
csjpJumpSize (CSJParams -> SlotNo) -> CSJParams -> SlotNo
forall a b. (a -> b) -> a -> b
$ GenesisTestFull blk -> CSJParams
forall blk schedule. GenesisTest blk schedule -> CSJParams
gtCSJParams GenesisTestFull blk
gt
        tipSlot :: WithOrigin SlotNo
tipSlot = AnchoredFragment blk -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot (AnchoredFragment blk -> WithOrigin SlotNo)
-> AnchoredFragment blk -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk (BlockTree blk -> AnchoredFragment blk)
-> BlockTree blk -> AnchoredFragment blk
forall a b. (a -> b) -> a -> b
$ GenesisTestFull blk -> BlockTree blk
forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree GenesisTestFull blk
gt
        hdrSlot :: SlotNo
hdrSlot = Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr
     in -- Sanity check: add @1 +@ after @>@ and watch the World burn.
        SlotNo
hdrSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
jumpSize SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= WithOrigin SlotNo -> SlotNo
forall t. (Bounded t, Enum t) => WithOrigin t -> t
succWithOrigin WithOrigin SlotNo
tipSlot

  disableBoringTimeouts :: GenesisTest blk schedule -> GenesisTest blk schedule
disableBoringTimeouts GenesisTest blk schedule
gt =
    GenesisTest blk schedule
gt
      { gtChainSyncTimeouts =
          (gtChainSyncTimeouts gt)
            { mustReplyTimeout = Nothing
            , idleTimeout = Nothing
            }
      }