{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

module Test.Consensus.Genesis.Tests.LoP (tests) where

import Data.Functor (($>))
import Data.Ratio ((%))
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient
import Ouroboros.Consensus.Util.IOLike
  ( DiffTime
  , Time (Time)
  , fromException
  )
import Ouroboros.Consensus.Util.LeakyBucket
  ( secondsRationalToDiffTime
  )
import Ouroboros.Network.AnchoredFragment
  ( AnchoredFragment
  , HasHeader
  )
import qualified Ouroboros.Network.AnchoredFragment as AF
import Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..))
import Test.Consensus.Genesis.Setup
import Test.Consensus.PeerSimulator.Run
  ( SchedulerConfig (..)
  , defaultSchedulerConfig
  )
import Test.Consensus.PeerSimulator.StateView
import Test.Consensus.PointSchedule
import Test.Consensus.PointSchedule.Peers
  ( peers'
  , peersOnlyAdversary
  , peersOnlyHonest
  )
import Test.Consensus.PointSchedule.Shrinking (shrinkPeerSchedules)
import Test.Consensus.PointSchedule.SinglePeer
  ( scheduleBlockPoint
  , scheduleHeaderPoint
  , scheduleTipPoint
  )
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Util.Orphans.IOLike ()
import Test.Util.PartialAccessors
import Test.Util.TestEnv
  ( adjustQuickCheckMaxSize
  , adjustQuickCheckTests
  )

tests :: TestTree
tests :: TestTree
tests =
  (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
    TestName -> [TestTree] -> TestTree
testGroup
      TestName
"LoP"
      [ -- \| NOTE: Running the test that must _not_ timeout (@prop_smoke False@) takes
        -- significantly more time than the one that does. This is because the former
        -- does all the computation (serving the headers, validating them, serving the
        -- block, validating them) while the former does nothing, because it timeouts
        -- before reaching the last tick of the point schedule.
        (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckMaxSize (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
          TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"wait just enough" (Bool -> Property
prop_wait Bool
False)
      , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"wait too much" (Bool -> Property
prop_wait Bool
True)
      , (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckMaxSize (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
          TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"wait behind forecast horizon" Property
prop_waitBehindForecastHorizon
      , (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckMaxSize (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
          TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"serve just fast enough" (Bool -> Property
prop_serve Bool
False)
      , (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckMaxSize (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
          TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"serve too slow" (Bool -> Property
prop_serve Bool
True)
      , (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckMaxSize (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
          TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"delaying attack succeeds without LoP" (Bool -> Property
prop_delayAttack Bool
False)
      , (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckMaxSize (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
          TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"delaying attack fails with LoP" (Bool -> Property
prop_delayAttack Bool
True)
      ]

-- | Simple test in which we connect to only one peer, who advertises the tip of
-- the block tree trunk and then does nothing. If the given boolean,
-- @mustTimeout@, if @True@, then we wait just long enough for the LoP bucket to
-- empty; we expect to observe an 'EmptyBucket' exception in the ChainSync
-- client. If @mustTimeout@ is @False@, then we wait not quite as long, so the
-- LoP bucket should not be empty at the end of the test and we should observe
-- no exception in the ChainSync client.
prop_wait :: Bool -> Property
prop_wait :: Bool -> Property
prop_wait Bool
mustTimeout =
  Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> Bool)
-> Property
forall prop.
Testable prop =>
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> prop)
-> Property
forAllGenesisTest
    ( do
        gt@GenesisTest{gtBlockTree} <- Gen Word -> Gen (GenesisTest TestBlock ())
genChains (Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
0)
        let ps = DiffTime -> AnchoredFragment TestBlock -> PointSchedule TestBlock
forall blk.
HasHeader blk =>
DiffTime -> AnchoredFragment blk -> PointSchedule blk
dullSchedule DiffTime
10 (BlockTree TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree TestBlock
gtBlockTree)
            gt' = GenesisTest TestBlock ()
gt{gtLoPBucketParams = LoPBucketParams{lbpCapacity = 10, lbpRate = 1}}
        pure $ gt' $> ps
    )
    -- NOTE: Crucially, there must not be timeouts for this test.
    (SchedulerConfig
defaultSchedulerConfig{scEnableChainSyncTimeouts = False, scEnableLoP = True})
    GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinkPeerSchedules
    ( \GenesisTestFull TestBlock
_ StateView TestBlock
stateView ->
        case PeerSimulatorComponent -> StateView TestBlock -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncClient StateView TestBlock
stateView of
          [] -> Bool -> Bool
not Bool
mustTimeout
          [SomeException -> Maybe ChainSyncClientException
forall e. Exception e => SomeException -> Maybe e
fromException -> Just ChainSyncClientException
CSClient.EmptyBucket] -> Bool
mustTimeout
          [SomeException]
_ -> Bool
False
    )
 where
  dullSchedule :: HasHeader blk => DiffTime -> AnchoredFragment blk -> PointSchedule blk
  dullSchedule :: forall blk.
HasHeader blk =>
DiffTime -> AnchoredFragment blk -> PointSchedule blk
dullSchedule DiffTime
_ (AF.Empty Anchor blk
_) = TestName -> PointSchedule blk
forall a. HasCallStack => TestName -> a
error TestName
"requires a non-empty block tree"
  dullSchedule DiffTime
timeout (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
_ AF.:> blk
tipBlock) =
    let DiffTime
offset :: DiffTime = if Bool
mustTimeout then DiffTime
1 else -DiffTime
1
     in PointSchedule
          { psSchedule :: Peers (PeerSchedule blk)
psSchedule =
              (if Bool
mustTimeout then PeerSchedule blk -> Peers (PeerSchedule blk)
forall a. a -> Peers a
peersOnlyAdversary else PeerSchedule blk -> Peers (PeerSchedule blk)
forall a. a -> Peers a
peersOnlyHonest)
                [(DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleTipPoint blk
tipBlock)]
          , psStartOrder :: [PeerId]
psStartOrder = []
          , psMinEndTime :: Time
psMinEndTime = DiffTime -> Time
Time (DiffTime -> Time) -> DiffTime -> Time
forall a b. (a -> b) -> a -> b
$ DiffTime
timeout DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
offset
          }

-- | Simple test in which we connect to only one peer, who advertises the tip of
-- the block tree trunk, serves all of its headers, and then does nothing.
-- Because the peer does not send its blocks, then the ChainSync client will end
-- up stuck, waiting behind the forecast horizon. We expect that the LoP will
-- then be disabled and that, therefore, one could wait forever in this state.
-- We disable the timeouts and check that, indeed, the ChainSync client observes
-- no exception.
prop_waitBehindForecastHorizon :: Property
prop_waitBehindForecastHorizon :: Property
prop_waitBehindForecastHorizon =
  Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> Bool)
-> Property
forall prop.
Testable prop =>
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> prop)
-> Property
forAllGenesisTest
    ( do
        gt@GenesisTest{gtBlockTree} <- Gen Word -> Gen (GenesisTest TestBlock ())
genChains (Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
0)
        let ps = AnchoredFragment TestBlock -> PointSchedule TestBlock
forall blk.
HasHeader blk =>
AnchoredFragment blk -> PointSchedule blk
dullSchedule (BlockTree TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree TestBlock
gtBlockTree)
            gt' = GenesisTest TestBlock ()
gt{gtLoPBucketParams = LoPBucketParams{lbpCapacity = 10, lbpRate = 1}}
        pure $ gt' $> ps
    )
    -- NOTE: Crucially, there must not be timeouts for this test.
    (SchedulerConfig
defaultSchedulerConfig{scEnableChainSyncTimeouts = False, scEnableLoP = True})
    GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinkPeerSchedules
    ( \GenesisTestFull TestBlock
_ StateView TestBlock
stateView ->
        case PeerSimulatorComponent -> StateView TestBlock -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncClient StateView TestBlock
stateView of
          [] -> Bool
True
          [SomeException]
_ -> Bool
False
    )
 where
  dullSchedule :: HasHeader blk => AnchoredFragment blk -> PointSchedule blk
  dullSchedule :: forall blk.
HasHeader blk =>
AnchoredFragment blk -> PointSchedule blk
dullSchedule (AF.Empty Anchor blk
_) = TestName -> PointSchedule blk
forall a. HasCallStack => TestName -> a
error TestName
"requires a non-empty block tree"
  dullSchedule (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
_ AF.:> blk
tipBlock) =
    PointSchedule
      { psSchedule :: Peers (PeerSchedule blk)
psSchedule =
          PeerSchedule blk -> Peers (PeerSchedule blk)
forall a. a -> Peers a
peersOnlyHonest (PeerSchedule blk -> Peers (PeerSchedule blk))
-> PeerSchedule blk -> Peers (PeerSchedule blk)
forall a b. (a -> b) -> a -> b
$
            [ (DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleTipPoint blk
tipBlock)
            , (DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
tipBlock)
            ]
      , psStartOrder :: [PeerId]
psStartOrder = []
      , psMinEndTime :: Time
psMinEndTime = DiffTime -> Time
Time DiffTime
11
      }

-- | Simple test where we serve all the chain at regular intervals, but just
-- slow enough to lose against the LoP bucket.
--
-- Let @c@ be the bucket capacity, @r@ be the bucket rate and @t@ be the time
-- between blocks, then the bucket level right right before getting the token
-- for the @k@th block will be:
--
-- > c - krt + (k-1)
--
-- (Note: if @rt ≥ 1@, otherwise it will simply be @c - rt@.) If we are to
-- survive at least (resp. succumb before) @k > 0@ blocks, then this value will
-- be positive (resp. negative). This is equivalent to saying that @rt@ must be
-- lower (resp. greater) than @(c+k-1) / k@.
--
-- We will have two versions of this test: one where we serve the @n-1@th block
-- but succumb before serving the @n@th block, and one where we do manage to
-- serve the @n@th block, barely.
prop_serve :: Bool -> Property
prop_serve :: Bool -> Property
prop_serve Bool
mustTimeout =
  Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> Bool)
-> Property
forall prop.
Testable prop =>
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> prop)
-> Property
forAllGenesisTest
    ( do
        gt@GenesisTest{gtBlockTree} <- Gen Word -> Gen (GenesisTest TestBlock ())
genChains (Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
0)
        let lbpRate = Int -> Rational
forall n. Integral n => n -> Rational
borderlineRate (AnchoredFragment TestBlock -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length (BlockTree TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree TestBlock
gtBlockTree))
            ps = AnchoredFragment TestBlock -> PointSchedule TestBlock
forall blk.
HasHeader blk =>
AnchoredFragment blk -> PointSchedule blk
makeSchedule (BlockTree TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree TestBlock
gtBlockTree)
            gt' = GenesisTest TestBlock ()
gt{gtLoPBucketParams = LoPBucketParams{lbpCapacity, lbpRate}}
        pure $ gt' $> ps
    )
    -- NOTE: Crucially, there must not be timeouts for this test.
    (SchedulerConfig
defaultSchedulerConfig{scEnableChainSyncTimeouts = False, scEnableLoP = True})
    GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinkPeerSchedules
    ( \GenesisTestFull TestBlock
_ StateView TestBlock
stateView ->
        case PeerSimulatorComponent -> StateView TestBlock -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncClient StateView TestBlock
stateView of
          [] -> Bool -> Bool
not Bool
mustTimeout
          [SomeException -> Maybe ChainSyncClientException
forall e. Exception e => SomeException -> Maybe e
fromException -> Just ChainSyncClientException
CSClient.EmptyBucket] -> Bool
mustTimeout
          [SomeException]
_ -> Bool
False
    )
 where
  Integer
lbpCapacity :: Integer = Integer
10
  Rational
timeBetweenBlocks :: Rational = Rational
0.100

  -- \| Rate that is almost the limit between surviving and succumbing to the
  -- LoP bucket, given a number of blocks. One should not exactly use the
  -- limit rate because it is unspecified what would happen in IOSim and it
  -- would simply be flakey in IO.
  borderlineRate :: Integral n => n -> Rational
  borderlineRate :: forall n. Integral n => n -> Rational
borderlineRate n
numberOfBlocks =
    (if Bool
mustTimeout then (Integer
105 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
100) else (Integer
95 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
100))
      Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* ( (Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
lbpCapacity Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ n -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral n
numberOfBlocks Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
1)
            Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ (Rational
timeBetweenBlocks Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* n -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral n
numberOfBlocks)
        )

  -- \| Make a schedule serving the given fragment with regularity, one block
  -- every 'timeBetweenBlocks'. NOTE: We must do something at @Time 0@
  -- otherwise the others times will be shifted such that the first one is 0.
  makeSchedule :: HasHeader blk => AnchoredFragment blk -> PointSchedule blk
  makeSchedule :: forall blk.
HasHeader blk =>
AnchoredFragment blk -> PointSchedule blk
makeSchedule (AF.Empty Anchor blk
_) = TestName -> PointSchedule blk
forall a. HasCallStack => TestName -> a
error TestName
"fragment must have at least one block"
  makeSchedule fragment :: AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
fragment@(AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
_ AF.:> blk
tipBlock) =
    PointSchedule
      { psSchedule :: Peers (PeerSchedule blk)
psSchedule =
          (if Bool
mustTimeout then PeerSchedule blk -> Peers (PeerSchedule blk)
forall a. a -> Peers a
peersOnlyAdversary else PeerSchedule blk -> Peers (PeerSchedule blk)
forall a. a -> Peers a
peersOnlyHonest) (PeerSchedule blk -> Peers (PeerSchedule blk))
-> PeerSchedule blk -> Peers (PeerSchedule blk)
forall a b. (a -> b) -> a -> b
$
            (DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleTipPoint blk
tipBlock)
              (Time, SchedulePoint blk) -> PeerSchedule blk -> PeerSchedule blk
forall a. a -> [a] -> [a]
: ( (((Rational, blk) -> PeerSchedule blk)
 -> [(Rational, blk)] -> PeerSchedule blk)
-> [(Rational, blk)]
-> ((Rational, blk) -> PeerSchedule blk)
-> PeerSchedule blk
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Rational, blk) -> PeerSchedule blk)
-> [(Rational, blk)] -> PeerSchedule blk
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Rational] -> [blk] -> [(Rational, blk)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Rational
1 ..] (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
fragment)) (((Rational, blk) -> PeerSchedule blk) -> PeerSchedule blk)
-> ((Rational, blk) -> PeerSchedule blk) -> PeerSchedule blk
forall a b. (a -> b) -> a -> b
$ \(Rational
i, blk
block) ->
                    [ (DiffTime -> Time
Time (Rational -> DiffTime
secondsRationalToDiffTime (Rational
i Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
timeBetweenBlocks)), blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
block)
                    , (DiffTime -> Time
Time (Rational -> DiffTime
secondsRationalToDiffTime (Rational
i Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
timeBetweenBlocks)), blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint blk
block)
                    ]
                )
      , psStartOrder :: [PeerId]
psStartOrder = []
      , psMinEndTime :: Time
psMinEndTime = DiffTime -> Time
Time DiffTime
0
      }

-- NOTE: Same as 'LoE.prop_adversaryHitsTimeouts' with LoP instead of timeouts.
prop_delayAttack :: Bool -> Property
prop_delayAttack :: Bool -> Property
prop_delayAttack Bool
lopEnabled =
  -- 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.
  -- If this point gets removed by the shrinker, we lose that property and the test becomes useless.
  Property -> Property
forall prop. Testable prop => prop -> Property
noShrinking (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> Bool)
-> Property
forall prop.
Testable prop =>
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> prop)
-> Property
forAllGenesisTest
      ( do
          gt@GenesisTest{gtBlockTree} <- Gen Word -> Gen (GenesisTest TestBlock ())
genChains (Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
1)
          let gt' = GenesisTest TestBlock ()
gt{gtLoPBucketParams = LoPBucketParams{lbpCapacity = 10, lbpRate = 1}}
              ps = BlockTree TestBlock -> PointSchedule TestBlock
forall blk. HasHeader blk => BlockTree blk -> PointSchedule blk
delaySchedule BlockTree TestBlock
gtBlockTree
          pure $ gt' $> ps
      )
      -- NOTE: Crucially, there must not be timeouts for this test.
      ( SchedulerConfig
defaultSchedulerConfig
          { scEnableChainSyncTimeouts = False
          , scEnableLoE = True
          , scEnableLoP = lopEnabled
          }
      )
      GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinkPeerSchedules
      ( \GenesisTest{BlockTree TestBlock
gtBlockTree :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree TestBlock
gtBlockTree} stateView :: StateView TestBlock
stateView@StateView{AnchoredFragment (Header TestBlock)
svSelectedChain :: AnchoredFragment (Header TestBlock)
svSelectedChain :: forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain} ->
          let
            -- The tip of the blocktree trunk.
            treeTipPoint :: Point TestBlock
treeTipPoint = AnchoredFragment TestBlock -> Point TestBlock
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment TestBlock -> Point TestBlock)
-> AnchoredFragment TestBlock -> Point TestBlock
forall a b. (a -> b) -> a -> b
$ BlockTree TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree TestBlock
gtBlockTree
            -- The tip of the selection.
            selectedTipPoint :: Point TestBlock
selectedTipPoint = Point (Header TestBlock) -> Point TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
AF.castPoint (Point (Header TestBlock) -> Point TestBlock)
-> Point (Header TestBlock) -> Point TestBlock
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header TestBlock) -> Point (Header TestBlock)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header TestBlock)
svSelectedChain
            -- If LoP is enabled, then the adversary should have been killed
            -- and the selection should be the whole trunk.
            selectedCorrect :: Bool
selectedCorrect = Bool
lopEnabled Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (Point TestBlock
treeTipPoint Point TestBlock -> Point TestBlock -> Bool
forall a. Eq a => a -> a -> Bool
== Point TestBlock
selectedTipPoint)
            -- If LoP is enabled, then we expect exactly one `EmptyBucket`
            -- exception in the adversary's ChainSync.
            exceptionsCorrect :: Bool
exceptionsCorrect = case PeerSimulatorComponent -> StateView TestBlock -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncClient StateView TestBlock
stateView of
              [] -> Bool -> Bool
not Bool
lopEnabled
              [SomeException -> Maybe ChainSyncClientException
forall e. Exception e => SomeException -> Maybe e
fromException -> Just ChainSyncClientException
CSClient.EmptyBucket] -> Bool
lopEnabled
              [SomeException]
_ -> Bool
False
           in
            Bool
selectedCorrect Bool -> Bool -> Bool
&& Bool
exceptionsCorrect
      )
 where
  delaySchedule :: HasHeader blk => BlockTree blk -> PointSchedule blk
  delaySchedule :: forall blk. HasHeader blk => BlockTree blk -> PointSchedule blk
delaySchedule BlockTree blk
tree =
    let trunkTip :: blk
trunkTip = BlockTree blk -> blk
forall blk. HasHeader blk => BlockTree blk -> blk
getTrunkTip BlockTree blk
tree
        branch :: BlockTreeBranch blk
branch = BlockTree blk -> BlockTreeBranch blk
forall blk. BlockTree blk -> BlockTreeBranch blk
getOnlyBranch BlockTree blk
tree
        intersectM :: Maybe blk
intersectM = case BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbPrefix BlockTreeBranch blk
branch of
          (AF.Empty Anchor blk
_) -> Maybe blk
forall a. Maybe a
Nothing
          (AnchoredFragment blk
_ AF.:> blk
tipBlock) -> blk -> Maybe blk
forall a. a -> Maybe a
Just blk
tipBlock
        branchTip :: blk
branchTip = BlockTree blk -> blk
forall blk. HasHeader blk => BlockTree blk -> blk
getOnlyBranchTip BlockTree blk
tree
        psSchedule :: Peers (PeerSchedule blk)
psSchedule =
          [PeerSchedule blk]
-> [PeerSchedule blk] -> Peers (PeerSchedule blk)
forall a. [a] -> [a] -> Peers a
peers'
            -- Eagerly serve the honest tree, but after the adversary has
            -- advertised its chain.
            [ (DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleTipPoint blk
trunkTip) (Time, SchedulePoint blk) -> PeerSchedule blk -> PeerSchedule blk
forall a. a -> [a] -> [a]
: case Maybe blk
intersectM of
                Maybe blk
Nothing ->
                  [ (DiffTime -> Time
Time DiffTime
0.5, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
trunkTip)
                  , (DiffTime -> Time
Time DiffTime
0.5, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint blk
trunkTip)
                  ]
                Just blk
intersect ->
                  [ (DiffTime -> Time
Time DiffTime
0.5, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
intersect)
                  , (DiffTime -> Time
Time DiffTime
0.5, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint blk
intersect)
                  , (DiffTime -> Time
Time DiffTime
5, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
trunkTip)
                  , (DiffTime -> Time
Time DiffTime
5, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint blk
trunkTip)
                  ]
            ]
            -- Advertise the alternate branch early, but don't serve it
            -- past the intersection, and wait for LoP bucket.
            [ (DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleTipPoint blk
branchTip) (Time, SchedulePoint blk) -> PeerSchedule blk -> PeerSchedule blk
forall a. a -> [a] -> [a]
: case Maybe blk
intersectM of
                -- the alternate branch forks from `Origin`
                Maybe blk
Nothing -> []
                -- the alternate branch forks from `intersect`
                Just blk
intersect ->
                  [ (DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
intersect)
                  , (DiffTime -> Time
Time DiffTime
0, blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint blk
intersect)
                  ]
            ]
        -- Wait for LoP bucket to empty
        psMinEndTime :: Time
psMinEndTime = DiffTime -> Time
Time DiffTime
11
     in PointSchedule{Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule, psStartOrder :: [PeerId]
psStartOrder = [], Time
psMinEndTime :: Time
psMinEndTime :: Time
psMinEndTime}