{-# 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', 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 (adjustQuickCheckTests)

tests :: TestTree
tests :: TestTree
tests =
  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
adjustQuickCheckTests (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10) (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),
      TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"wait behind forecast horizon" Property
prop_waitBehindForecastHorizon,
      (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (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),
      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
adjustQuickCheckTests (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
adjustQuickCheckTests (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)
    ]

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 TestBlock ()
gt@GenesisTest {BlockTree TestBlock
gtBlockTree :: BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
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 :: PointSchedule TestBlock
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' = GenesisTest TestBlock ()
gt {gtLoPBucketParams = LoPBucketParams {lbpCapacity = 10, lbpRate = 1}}
        GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock))
-> GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock)
forall a b. (a -> b) -> a -> b
$ GenesisTest TestBlock ()
gt' GenesisTest TestBlock ()
-> PointSchedule TestBlock -> GenesisTestFull TestBlock
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PointSchedule TestBlock
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
            { $sel:psSchedule:PointSchedule :: Peers (PeerSchedule blk)
psSchedule = 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)]
            , $sel:psMinEndTime:PointSchedule :: 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
            }

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 TestBlock ()
gt@GenesisTest {BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree TestBlock
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 :: PointSchedule TestBlock
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' = GenesisTest TestBlock ()
gt {gtLoPBucketParams = LoPBucketParams {lbpCapacity = 10, lbpRate = 1}}
        GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock))
-> GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock)
forall a b. (a -> b) -> a -> b
$ GenesisTest TestBlock ()
gt' GenesisTest TestBlock ()
-> PointSchedule TestBlock -> GenesisTestFull TestBlock
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PointSchedule TestBlock
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
        { $sel:psSchedule:PointSchedule :: 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)
            ]
        , $sel:psMinEndTime:PointSchedule :: 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 TestBlock ()
gt@GenesisTest {BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree TestBlock
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 :: Rational
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 :: PointSchedule TestBlock
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' = GenesisTest TestBlock ()
gt {gtLoPBucketParams = LoPBucketParams {lbpCapacity, lbpRate}}
        GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock))
-> GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock)
forall a b. (a -> b) -> a -> b
$ GenesisTest TestBlock ()
gt' GenesisTest TestBlock ()
-> PointSchedule TestBlock -> GenesisTestFull TestBlock
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PointSchedule TestBlock
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) =
      Peers (PeerSchedule blk) -> PointSchedule blk
forall blk. Peers (PeerSchedule blk) -> PointSchedule blk
mkPointSchedule (Peers (PeerSchedule blk) -> PointSchedule blk)
-> Peers (PeerSchedule blk) -> PointSchedule blk
forall a b. (a -> b) -> a -> b
$ 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)
                ]
            )

-- 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 TestBlock ()
gt@GenesisTest {BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree TestBlock
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' = GenesisTest TestBlock ()
gt {gtLoPBucketParams = LoPBucketParams {lbpCapacity = 10, lbpRate = 1}}
              ps :: PointSchedule TestBlock
ps = BlockTree TestBlock -> PointSchedule TestBlock
forall blk. HasHeader blk => BlockTree blk -> PointSchedule blk
delaySchedule BlockTree TestBlock
gtBlockTree
          GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock))
-> GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock)
forall a b. (a -> b) -> a -> b
$ GenesisTest TestBlock ()
gt' GenesisTest TestBlock ()
-> PointSchedule TestBlock -> GenesisTestFull TestBlock
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PointSchedule TestBlock
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
$sel:gtBlockTree:GenesisTest :: 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)
$sel:psSchedule:PointSchedule :: Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule, Time
$sel:psMinEndTime:PointSchedule :: Time
psMinEndTime :: Time
psMinEndTime}