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

-- | Limit on Patience tests.
module Test.Consensus.Genesis.Tests.LoP
  ( TestKey
  , testSuite
  ) where

import Cardano.Ledger.BaseTypes.NonZero (unNonZero)
import Data.Functor (($>))
import Data.Ratio ((%))
import Ouroboros.Consensus.Block.Abstract (Header, HeaderFields (..), unSlotNo)
import Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..))
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.Genesis.TestSuite
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.QuickCheck.Gen (suchThat)
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
  = WaitJustEnoughUntilEmpty
  | WaitTooMuchUntilEmpty
  | WaitBehindForecastHorizon
  | ServeJustFastEnough
  | ServeTooSlow
  | DelayAttackSucceeds
  | DelayAttackFails
  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
  ) =>
  TestSuite blk TestKey
testSuite :: forall blk.
(HasHeader blk, HasHeader (Header blk), IssueTestBlock blk,
 Ord blk) =>
TestSuite blk TestKey
testSuite = String -> TestSuite blk TestKey -> TestSuite blk TestKey
forall blk key. String -> TestSuite blk key -> TestSuite blk key
group String
"LoP" (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
$ \case
  TestKey
WaitJustEnoughUntilEmpty -> String -> Bool -> ConformanceTest blk
forall blk.
(HasHeader blk, IssueTestBlock blk, Ord blk) =>
String -> Bool -> ConformanceTest blk
testWait String
"wait just enough" Bool
False
  TestKey
WaitTooMuchUntilEmpty -> String -> Bool -> ConformanceTest blk
forall blk.
(HasHeader blk, IssueTestBlock blk, Ord blk) =>
String -> Bool -> ConformanceTest blk
testWait String
"wait too much" Bool
True
  TestKey
WaitBehindForecastHorizon -> ConformanceTest blk
forall blk.
(HasHeader blk, IssueTestBlock blk, Ord blk) =>
ConformanceTest blk
testWaitBehindForecastHorizon
  TestKey
ServeJustFastEnough -> String -> Bool -> ConformanceTest blk
forall blk.
(HasHeader blk, IssueTestBlock blk, Ord blk) =>
String -> Bool -> ConformanceTest blk
testServe String
"serve just fast enough" Bool
False
  TestKey
ServeTooSlow -> String -> Bool -> ConformanceTest blk
forall blk.
(HasHeader blk, IssueTestBlock blk, Ord blk) =>
String -> Bool -> ConformanceTest blk
testServe String
"serve too slow" Bool
True
  TestKey
DelayAttackSucceeds -> String -> Bool -> ConformanceTest blk
forall blk.
(HasHeader blk, HasHeader (Header blk), IssueTestBlock blk) =>
String -> Bool -> ConformanceTest blk
testDelayAttack String
"delaying attack succeeds without LoP" Bool
False
  TestKey
DelayAttackFails -> String -> Bool -> ConformanceTest blk
forall blk.
(HasHeader blk, HasHeader (Header blk), IssueTestBlock blk) =>
String -> Bool -> ConformanceTest blk
testDelayAttack String
"delaying attack fails with LoP" 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@, is @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.
testWait ::
  ( HasHeader blk
  , IssueTestBlock blk
  , Ord blk
  ) =>
  String -> Bool -> ConformanceTest blk
testWait :: forall blk.
(HasHeader blk, IssueTestBlock blk, Ord blk) =>
String -> Bool -> ConformanceTest blk
testWait String
description Bool
mustTimeout =
  String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> Bool)
-> 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
    -- NOTE: Running the test that must _not_ timeout 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 latter does nothing, because it timeouts
    -- before reaching the last tick of the point schedule.
    (case Bool
mustTimeout of Bool
False -> AdjustMaxSize
adjustMaxSize; Bool
True -> (Int -> Int) -> AdjustMaxSize
AdjustMaxSize Int -> Int
forall a. a -> a
id)
    ( do
        gt@GenesisTest{gtBlockTree} <- Gen Word -> Gen (GenesisTest blk ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
genChains (Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
0)
        let ps = DiffTime -> AnchoredFragment blk -> PointSchedule blk
forall blk.
HasHeader blk =>
DiffTime -> AnchoredFragment blk -> PointSchedule blk
dullSchedule DiffTime
10 (BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
gtBlockTree)
            gt' = GenesisTest blk ()
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 blk -> StateView blk -> [GenesisTestFull blk]
forall blk.
(HasHeader blk, Ord blk) =>
GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
shrinkPeerSchedules
    ( \GenesisTestFull blk
_ StateView blk
stateView ->
        case PeerSimulatorComponent -> StateView blk -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncClient StateView blk
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
_) = String -> PointSchedule blk
forall a. HasCallStack => String -> a
error String
"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.
testWaitBehindForecastHorizon ::
  ( HasHeader blk
  , IssueTestBlock blk
  , Ord blk
  ) =>
  ConformanceTest blk
testWaitBehindForecastHorizon :: forall blk.
(HasHeader blk, IssueTestBlock blk, Ord blk) =>
ConformanceTest blk
testWaitBehindForecastHorizon =
  String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> Bool)
-> 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
"wait behind forecast horizon"
    AdjustTestCount
adjustTestCount
    AdjustMaxSize
adjustMaxSize
    ( do
        gt@GenesisTest{gtBlockTree} <- Gen Word -> Gen (GenesisTest blk ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
genChains (Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
0)
        let ps = AnchoredFragment blk -> PointSchedule blk
forall blk.
HasHeader blk =>
AnchoredFragment blk -> PointSchedule blk
dullSchedule (BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
gtBlockTree)
            gt' = GenesisTest blk ()
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 blk -> StateView blk -> [GenesisTestFull blk]
forall blk.
(HasHeader blk, Ord blk) =>
GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
shrinkPeerSchedules
    ( \GenesisTestFull blk
_ StateView blk
stateView ->
        case PeerSimulatorComponent -> StateView blk -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncClient StateView blk
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
_) = String -> PointSchedule blk
forall a. HasCallStack => String -> a
error String
"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 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.
testServe ::
  ( HasHeader blk
  , IssueTestBlock blk
  , Ord blk
  ) =>
  String -> Bool -> ConformanceTest blk
testServe :: forall blk.
(HasHeader blk, IssueTestBlock blk, Ord blk) =>
String -> Bool -> ConformanceTest blk
testServe String
description Bool
mustTimeout =
  String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> Bool)
-> 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
    ( do
        gt@GenesisTest{gtBlockTree} <- Gen Word -> Gen (GenesisTest blk ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
genChains (Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
0) Gen (GenesisTest blk ())
-> (GenesisTest blk () -> Bool) -> Gen (GenesisTest blk ())
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` GenesisTest blk () -> Bool
forall blk schedule.
HasHeader blk =>
GenesisTest blk schedule -> Bool
hasAtLeastOneBlockPerEpoch
        let lbpRate = Int -> Ratio Integer
forall n. Integral n => n -> Ratio Integer
borderlineRate (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length (BlockTree blk -> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
gtBlockTree))
            ps = AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
-> PointSchedule blk
forall blk.
HasHeader blk =>
AnchoredFragment blk -> PointSchedule blk
makeSchedule (BlockTree blk -> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
gtBlockTree)
            gt' = GenesisTest blk ()
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 blk -> StateView blk -> [GenesisTestFull blk]
forall blk.
(HasHeader blk, Ord blk) =>
GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
shrinkPeerSchedules
    ( \GenesisTestFull blk
_ StateView blk
stateView ->
        case PeerSimulatorComponent -> StateView blk -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncClient StateView blk
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
  Ratio Integer
timeBetweenBlocks :: Rational = Ratio Integer
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 -> Ratio Integer
borderlineRate n
numberOfBlocks =
    (if Bool
mustTimeout then (Integer
105 Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
% Integer
100) else (Integer
95 Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
% Integer
100))
      Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
* ( (Integer -> Ratio Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
lbpCapacity Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
+ n -> Ratio Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral n
numberOfBlocks Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
- Ratio Integer
1)
            Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Fractional a => a -> a -> a
/ (Ratio Integer
timeBetweenBlocks Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
* n -> Ratio Integer
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
_) = String -> PointSchedule blk
forall a. HasCallStack => String -> a
error String
"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]
: ( (((Ratio Integer, blk) -> PeerSchedule blk)
 -> [(Ratio Integer, blk)] -> PeerSchedule blk)
-> [(Ratio Integer, blk)]
-> ((Ratio Integer, blk) -> PeerSchedule blk)
-> PeerSchedule blk
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Ratio Integer, blk) -> PeerSchedule blk)
-> [(Ratio Integer, blk)] -> PeerSchedule blk
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Ratio Integer] -> [blk] -> [(Ratio Integer, blk)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Ratio Integer
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)) (((Ratio Integer, blk) -> PeerSchedule blk) -> PeerSchedule blk)
-> ((Ratio Integer, blk) -> PeerSchedule blk) -> PeerSchedule blk
forall a b. (a -> b) -> a -> b
$ \(Ratio Integer
i, blk
block) ->
                    [ (DiffTime -> Time
Time (Ratio Integer -> DiffTime
secondsRationalToDiffTime (Ratio Integer
i Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
* Ratio Integer
timeBetweenBlocks)), blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleHeaderPoint blk
block)
                    , (DiffTime -> Time
Time (Ratio Integer -> DiffTime
secondsRationalToDiffTime (Ratio Integer
i Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
* Ratio Integer
timeBetweenBlocks)), blk -> SchedulePoint blk
forall blk. blk -> SchedulePoint blk
scheduleBlockPoint blk
block)
                    ]
                )
      , psStartOrder :: [PeerId]
psStartOrder = []
      , psMinEndTime :: Time
psMinEndTime = DiffTime -> Time
Time DiffTime
0
      }

-- | Same as 'Test.Consensus.Genesis.LoE.testAdversaryHitsTimeouts'
-- with LoP instead of timeouts.
testDelayAttack ::
  ( HasHeader blk
  , HasHeader (Header blk)
  , IssueTestBlock blk
  ) =>
  String -> Bool -> ConformanceTest blk
testDelayAttack :: forall blk.
(HasHeader blk, HasHeader (Header blk), IssueTestBlock blk) =>
String -> Bool -> ConformanceTest blk
testDelayAttack String
description Bool
lopEnabled =
  String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTest blk (PointSchedule blk))
-> SchedulerConfig
-> (GenesisTest blk (PointSchedule blk)
    -> StateView blk -> [GenesisTest blk (PointSchedule blk)])
-> (GenesisTest blk (PointSchedule blk) -> StateView blk -> Bool)
-> 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
    ( do
        gt@GenesisTest{gtBlockTree} <- Gen Word -> Gen (GenesisTest blk ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
genChains (Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
1) Gen (GenesisTest blk ())
-> (GenesisTest blk () -> Bool) -> Gen (GenesisTest blk ())
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` GenesisTest blk () -> Bool
forall blk schedule.
HasHeader blk =>
GenesisTest blk schedule -> Bool
hasAtLeastOneBlockPerEpoch
        let gt' = GenesisTest blk ()
gt{gtLoPBucketParams = LoPBucketParams{lbpCapacity = 10, lbpRate = 1}}
            ps = BlockTree blk -> PointSchedule blk
forall blk. HasHeader blk => BlockTree blk -> PointSchedule blk
delaySchedule BlockTree blk
gtBlockTree
        pure $ gt' $> ps
    )
    -- NOTE: Crucially, there must not be timeouts for this test.
    ( SchedulerConfig
defaultSchedulerConfig
        { scEnableChainSyncTimeouts = False
        , scEnableLoE = True
        , scEnableLoP = 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.
    GenesisTest blk (PointSchedule blk)
-> StateView blk -> [GenesisTest blk (PointSchedule blk)]
forall a. Monoid a => a
mempty
    ( \GenesisTest{BlockTree blk
gtBlockTree :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree blk
gtBlockTree} stateView :: StateView blk
stateView@StateView{AnchoredFragment (Header blk)
svSelectedChain :: AnchoredFragment (Header blk)
svSelectedChain :: forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain} ->
        let
          -- The tip of the blocktree trunk.
          treeTipPoint :: Point blk
treeTipPoint = AnchoredFragment blk -> Point blk
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment blk -> Point blk)
-> AnchoredFragment blk -> Point blk
forall a b. (a -> b) -> a -> b
$ BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
gtBlockTree
          -- The tip of the selection.
          selectedTipPoint :: Point blk
selectedTipPoint = Point (Header blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
AF.castPoint (Point (Header blk) -> Point blk)
-> Point (Header blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
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 blk
treeTipPoint Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk
selectedTipPoint)
          -- If LoP is enabled, then we expect exactly one `EmptyBucket`
          -- exception in the adversary's ChainSync.
          exceptionsCorrect :: Bool
exceptionsCorrect = case PeerSimulatorComponent -> StateView blk -> [SomeException]
forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
ChainSyncClient StateView blk
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}

-- \| Ensure that the block tree has at least one block per epoch on all branches.
-- Otherwise, issues would arise when trying to update the ledger from era n to era n+2.
hasAtLeastOneBlockPerEpoch :: HasHeader blk => GenesisTest blk schedule -> Bool
hasAtLeastOneBlockPerEpoch :: forall blk schedule.
HasHeader blk =>
GenesisTest blk schedule -> Bool
hasAtLeastOneBlockPerEpoch GenesisTest{BlockTree blk
gtBlockTree :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree blk
gtBlockTree, SecurityParam
gtSecurityParam :: SecurityParam
gtSecurityParam :: forall blk schedule. GenesisTest blk schedule -> SecurityParam
gtSecurityParam} =
  (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> Bool)
-> [AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> Bool
forall {v} {a}. AnchoredSeq v a blk -> Bool
fragmentHasEnoughBlocks (BlockTree blk -> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
gtBlockTree AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
-> [AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk]
-> [AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk]
forall a. a -> [a] -> [a]
: (BlockTreeBranch blk
-> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull (BlockTreeBranch blk
 -> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
-> [BlockTreeBranch blk]
-> [AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockTree blk -> [BlockTreeBranch blk]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches BlockTree blk
gtBlockTree))
 where
  k :: Word64
k = NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (NonZero Word64 -> Word64) -> NonZero Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ SecurityParam -> NonZero Word64
maxRollbacks SecurityParam
gtSecurityParam
  -- \| This value comes from `defaultErasParams`, which is way out of scope from here.
  -- We should find a way to avoid repetition of this value, or at least centralize it.
  epochSize :: Word64
epochSize = Word64
10 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
k
  slotList :: AnchoredSeq v a blk -> [Word64]
slotList AnchoredSeq v a blk
frag = blk -> Word64
slotNo (blk -> Word64) -> [blk] -> [Word64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredSeq v a blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredSeq v a blk
frag
  slotNo :: blk -> Word64
slotNo = SlotNo -> Word64
unSlotNo (SlotNo -> Word64) -> (blk -> SlotNo) -> blk -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderFields blk -> SlotNo
forall k (b :: k). HeaderFields b -> SlotNo
headerFieldSlot (HeaderFields blk -> SlotNo)
-> (blk -> HeaderFields blk) -> blk -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> HeaderFields blk
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields

  fragmentHasEnoughBlocks :: AnchoredSeq v a blk -> Bool
fragmentHasEnoughBlocks AnchoredSeq v a blk
frag =
    ((Word64, Word64) -> Bool) -> [(Word64, Word64)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
      (\(Word64
prev, Word64
next) -> Word64
next Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
prev Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
epochSize)
      -- \| Add 0 at the beginning to simulate Origin
      ([Word64] -> [Word64] -> [(Word64, Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Word64
0 Word64 -> [Word64] -> [Word64]
forall a. a -> [a] -> [a]
: AnchoredSeq v a blk -> [Word64]
forall {v} {a}. AnchoredSeq v a blk -> [Word64]
slotList AnchoredSeq v a blk
frag) (AnchoredSeq v a blk -> [Word64]
forall {v} {a}. AnchoredSeq v a blk -> [Word64]
slotList AnchoredSeq v a blk
frag))