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

-- | Peer simulator tests based on randomly generated schedules. They share the
-- same property stating that the immutable tip should be on the trunk of the
-- block tree with the right age (roughly @k@ blocks from the tip). Contrary to
-- other tests cases (eg. long range attack), the schedules are not particularly
-- biased towards a specific situation.
module Test.Consensus.Genesis.Tests.Uniform
  ( TestKey
  , genUniformSchedulePoints
  , testSuite
  ) where

import Cardano.Slotting.Slot (SlotNo (SlotNo), WithOrigin (..))
import Control.Monad (replicateM)
import Control.Monad.Class.MonadTime.SI (Time (..), addTime)
import qualified Data.IntSet as IntSet
import Data.List (intercalate, sort, uncons)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Word (Word64)
import GHC.Stack (HasCallStack)
import Ouroboros.Consensus.Block.Abstract
  ( ChainHash (..)
  , GetHeader
  , WithOrigin (NotOrigin)
  )
import Ouroboros.Consensus.Util.Condense (condense)
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Block (blockNo, blockSlot, unBlockNo)
import Ouroboros.Network.Protocol.Limits (shortWait)
import Test.Consensus.BlockTree (BlockTree (..), btbSuffix)
import Test.Consensus.Genesis.Setup
import Test.Consensus.Genesis.Setup.Classifiers
import Test.Consensus.Genesis.TestSuite
import Test.Consensus.PeerSimulator.ChainSync (chainSyncNoTimeouts)
import Test.Consensus.PeerSimulator.Run
  ( SchedulerConfig (..)
  , defaultSchedulerConfig
  )
import Test.Consensus.PeerSimulator.StateView
import Test.Consensus.PointSchedule
import Test.Consensus.PointSchedule.Peers
  ( Peers (..)
  , getPeerIds
  , isHonestPeerId
  , peers'
  )
import Test.Consensus.PointSchedule.Shrinking
  ( shrinkByRemovingAdversaries
  , shrinkPeerSchedules
  )
import Test.Consensus.PointSchedule.SinglePeer
  ( SchedulePoint (ScheduleBlockPoint, ScheduleTipPoint)
  )
import Test.Ouroboros.Consensus.ChainGenerator.Params (Delta (Delta))
import Test.QuickCheck
import qualified Test.QuickCheck as QC
import Test.Util.Orphans.IOLike ()
import Test.Util.PartialAccessors
import Test.Util.QuickCheck (le)
import Text.Printf (printf)

-- | 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
  = BlockFetchLeashingAttack
  | Downtime
  | LeashingAttackStalling
  | LeashingAttackTimeLimited
  | LOEStalling
  | ServeAdversarialBranches
  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, Int -> TestKey -> ShowS
[TestKey] -> ShowS
TestKey -> String
(Int -> TestKey -> ShowS)
-> (TestKey -> String) -> ([TestKey] -> ShowS) -> Show TestKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestKey -> ShowS
showsPrec :: Int -> TestKey -> ShowS
$cshow :: TestKey -> String
show :: TestKey -> String
$cshowList :: [TestKey] -> ShowS
showList :: [TestKey] -> ShowS
Show, 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 ::
  ( AF.HasHeader blk
  , GetHeader blk
  , IssueTestBlock blk
  , Ord blk
  ) =>
  TestSuite blk TestKey
testSuite :: forall blk.
(HasHeader blk, GetHeader 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
"uniform" (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
BlockFetchLeashingAttack -> ConformanceTest blk
forall blk.
(HasHeader blk, GetHeader blk, IssueTestBlock blk, Ord blk) =>
ConformanceTest blk
testBlockFetchLeashingAttack
  TestKey
Downtime -> ConformanceTest blk
forall blk.
(HasHeader blk, GetHeader blk, IssueTestBlock blk, Ord blk) =>
ConformanceTest blk
testDowntime
  TestKey
LeashingAttackStalling -> ConformanceTest blk
forall blk.
(HasHeader blk, GetHeader blk, IssueTestBlock blk, Ord blk) =>
ConformanceTest blk
testLeashingAttackStalling
  TestKey
LeashingAttackTimeLimited -> ConformanceTest blk
forall blk.
(HasHeader blk, GetHeader blk, IssueTestBlock blk, Ord blk) =>
ConformanceTest blk
testLeashingAttackTimeLimited
  TestKey
LOEStalling -> ConformanceTest blk
forall blk.
(HasHeader blk, GetHeader blk, IssueTestBlock blk, Ord blk) =>
ConformanceTest blk
testLoeStalling
  TestKey
ServeAdversarialBranches -> ConformanceTest blk
forall blk.
(HasHeader blk, GetHeader blk, Ord blk, IssueTestBlock blk) =>
ConformanceTest blk
testServeAdversarialBranches

-- | The conjunction of
--
--  * no honest peer has been disconnected,
--  * the immutable tip is on the best chain, and
--  * the immutable tip is no older than s + d + 1 slots
theProperty :: (AF.HasHeader blk, GetHeader blk) => GenesisTestFull blk -> StateView blk -> Property
theProperty :: forall blk.
(HasHeader blk, GetHeader blk) =>
GenesisTestFull blk -> StateView blk -> Property
theProperty GenesisTestFull blk
genesisTest stateView :: StateView blk
stateView@StateView{AnchoredFragment (Header blk)
svSelectedChain :: AnchoredFragment (Header blk)
svSelectedChain :: forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain} =
  Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify Bool
genesisWindowAfterIntersection String
"Full genesis window after intersection" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (ChainHash (Header blk)
immutableTipHash ChainHash (Header blk) -> ChainHash (Header blk) -> Bool
forall a. Eq a => a -> a -> Bool
== ChainHash (Header blk)
forall {k} (b :: k). ChainHash b
GenesisHash) String
"Immutable tip is Origin" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label String
disconnectedLabel (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (Int
advCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [BlockTreeBranch blk] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (BlockTree blk -> [BlockTreeBranch blk]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches BlockTree blk
gtBlockTree)) String
"Some adversaries performed rollbacks" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
killedPeers (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            -- We require the honest chain to fit a Genesis window, because otherwise its tip may suggest
            -- to the governor that the density is too low.
            Bool
longerThanGenesisWindow Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
              [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
                [ String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Honest peers shouldn't be disconnected" (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (PeerId -> Bool) -> [PeerId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PeerId -> Bool
isHonestPeerId [PeerId]
disconnected)
                , String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"The immutable tip should be honest: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Anchor (Header blk) -> String
forall a. Show a => a -> String
show Anchor (Header blk)
immutableTip) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
                    GenesisTestFull blk -> StateView blk -> Bool
forall blk.
GetHeader blk =>
GenesisTestFull blk -> StateView blk -> Bool
honestImmutableTip GenesisTestFull blk
genesisTest StateView blk
stateView
                , Property
immutableTipIsRecent
                ]
 where
  advCount :: Int
advCount = Map Int (PeerSchedule blk) -> Int
forall k a. Map k a -> Int
Map.size (Peers (PeerSchedule blk) -> Map Int (PeerSchedule blk)
forall a. Peers a -> Map Int a
adversarialPeers (PointSchedule blk -> Peers (PeerSchedule blk)
forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule (PointSchedule blk -> Peers (PeerSchedule blk))
-> PointSchedule blk -> Peers (PeerSchedule blk)
forall a b. (a -> b) -> a -> b
$ GenesisTestFull blk -> PointSchedule blk
forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule GenesisTestFull blk
genesisTest))

  immutableTipIsRecent :: Property
immutableTipIsRecent =
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"The immutable tip is too old: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
immutableTipAge) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      Word64
immutableTipAge Word64 -> Word64 -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`le` Word64
s Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
d Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1

  SlotNo Word64
immutableTipAge = case (WithOrigin SlotNo
honestTipSlot, WithOrigin SlotNo
immutableTipSlot) of
    (At SlotNo
h, At SlotNo
i) -> SlotNo
h SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
i
    (At SlotNo
h, WithOrigin SlotNo
Origin) -> SlotNo
h
    (WithOrigin SlotNo, WithOrigin SlotNo)
_ -> SlotNo
0

  immutableTipHash :: ChainHash (Header blk)
immutableTipHash = Anchor (Header blk) -> ChainHash (Header blk)
forall block. Anchor block -> ChainHash block
AF.anchorToHash Anchor (Header blk)
immutableTip

  immutableTip :: Anchor (Header blk)
immutableTip = AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment (Header blk)
svSelectedChain

  immutableTipSlot :: WithOrigin SlotNo
immutableTipSlot = Anchor (Header blk) -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
AF.anchorToSlotNo (AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment (Header blk)
svSelectedChain)

  disconnectedLabel :: String
disconnectedLabel =
    String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"disconnected %.1f%% of adversaries" Double
disconnectedPercent

  disconnected :: [PeerId]
disconnected = StateView blk -> [PeerId]
forall blk. StateView blk -> [PeerId]
collectDisconnectedPeers StateView blk
stateView

  disconnectedPercent :: Double
  disconnectedPercent :: Double
disconnectedPercent =
    Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([PeerId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PeerId]
disconnected) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
advCount

  killedPeers :: String
killedPeers = case [PeerId]
disconnected of
    [] -> String
"No peers were disconnected"
    [PeerId]
peers -> String
"Some peers were disconnected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (PeerId -> String
forall a. Condense a => a -> String
condense (PeerId -> String) -> [PeerId] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PeerId]
peers)

  honestTipSlot :: WithOrigin SlotNo
honestTipSlot =
    SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At (SlotNo -> WithOrigin SlotNo) -> SlotNo -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$
      blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot (blk -> SlotNo) -> blk -> SlotNo
forall a b. (a -> b) -> a -> b
$
        (Time, blk) -> blk
forall a b. (a, b) -> b
snd ((Time, blk) -> blk) -> (Time, blk) -> blk
forall a b. (a -> b) -> a -> b
$
          [(Time, blk)] -> (Time, blk)
forall a. HasCallStack => [a] -> a
last ([(Time, blk)] -> (Time, blk)) -> [(Time, blk)] -> (Time, blk)
forall a b. (a -> b) -> a -> b
$
            ((Time, SchedulePoint blk) -> Maybe (Time, blk))
-> PeerSchedule blk -> [(Time, blk)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Time, SchedulePoint blk) -> Maybe (Time, blk)
forall blk. (Time, SchedulePoint blk) -> Maybe (Time, blk)
fromBlockPoint (PeerSchedule blk -> [(Time, blk)])
-> PeerSchedule blk -> [(Time, blk)]
forall a b. (a -> b) -> a -> b
$
              Map Int (PeerSchedule blk) -> PeerSchedule blk
forall a. Map Int a -> a
getHonestPeer (Map Int (PeerSchedule blk) -> PeerSchedule blk)
-> Map Int (PeerSchedule blk) -> PeerSchedule blk
forall a b. (a -> b) -> a -> b
$
                Peers (PeerSchedule blk) -> Map Int (PeerSchedule blk)
forall a. Peers a -> Map Int a
honestPeers (Peers (PeerSchedule blk) -> Map Int (PeerSchedule blk))
-> Peers (PeerSchedule blk) -> Map Int (PeerSchedule blk)
forall a b. (a -> b) -> a -> b
$
                  PointSchedule blk -> Peers (PeerSchedule blk)
forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule (PointSchedule blk -> Peers (PeerSchedule blk))
-> PointSchedule blk -> Peers (PeerSchedule blk)
forall a b. (a -> b) -> a -> b
$
                    GenesisTestFull blk -> PointSchedule blk
forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule GenesisTestFull blk
genesisTest

  GenesisTest{BlockTree blk
gtBlockTree :: BlockTree blk
gtBlockTree :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree, gtGenesisWindow :: forall blk schedule. GenesisTest blk schedule -> GenesisWindow
gtGenesisWindow = GenesisWindow Word64
s, gtDelay :: forall blk schedule. GenesisTest blk schedule -> Delta
gtDelay = Delta Int
d} = GenesisTestFull blk
genesisTest

  Classifiers{Bool
genesisWindowAfterIntersection :: Bool
genesisWindowAfterIntersection :: Classifiers -> Bool
genesisWindowAfterIntersection, Bool
longerThanGenesisWindow :: Bool
longerThanGenesisWindow :: Classifiers -> Bool
longerThanGenesisWindow} = GenesisTestFull blk -> Classifiers
forall blk schedule.
HasHeader blk =>
GenesisTest blk schedule -> Classifiers
classifiers GenesisTestFull blk
genesisTest

fromBlockPoint :: (Time, SchedulePoint blk) -> Maybe (Time, blk)
fromBlockPoint :: forall blk. (Time, SchedulePoint blk) -> Maybe (Time, blk)
fromBlockPoint (Time
t, ScheduleBlockPoint (NotOrigin blk
bp)) = (Time, blk) -> Maybe (Time, blk)
forall a. a -> Maybe a
Just (Time
t, blk
bp)
fromBlockPoint (Time, SchedulePoint blk)
_ = Maybe (Time, blk)
forall a. Maybe a
Nothing

-- | Tests that the immutable tip is not delayed and stays honest with the
-- adversarial peers serving adversarial branches.
testServeAdversarialBranches ::
  ( AF.HasHeader blk
  , GetHeader blk
  , Ord blk
  , IssueTestBlock blk
  ) =>
  ConformanceTest blk
testServeAdversarialBranches :: forall blk.
(HasHeader blk, GetHeader blk, Ord blk, IssueTestBlock blk) =>
ConformanceTest blk
testServeAdversarialBranches =
  String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> Property)
-> ConformanceTest blk
forall prop blk.
Testable prop =>
String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> prop)
-> ConformanceTest blk
mkConformanceTest
    String
"serve adversarial branches"
    AdjustTestCount
adjustTestCount
    AdjustMaxSize
adjustMaxSize
    (Gen Word -> Gen (GenesisTest blk ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
genChains ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
QC.choose (Word
1, Word
4)) Gen (GenesisTest blk ())
-> (GenesisTest blk () -> Gen (PointSchedule blk))
-> Gen (GenesisTestFull blk)
forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
`enrichedWith` GenesisTest blk () -> Gen (PointSchedule blk)
forall blk.
HasHeader blk =>
GenesisTest blk () -> Gen (PointSchedule blk)
genUniformSchedulePoints)
    ( SchedulerConfig
defaultSchedulerConfig
        { scTraceState = False
        , scTrace = False
        , scEnableLoE = True
        , scEnableCSJ = True
        , scEnableLoP = False
        , scEnableChainSyncTimeouts = False
        , scEnableBlockFetchTimeouts = False
        }
    )
    -- We cannot shrink by removing points from the adversarial schedules.
    -- Removing ticks could make an adversary unable to serve any blocks or headers.
    -- Because LoP and timeouts are disabled, this would cause the immutable tip
    -- to get stuck indefinitely, as the adversary wouldn't get disconnected.
    --
    -- We don't enable timeouts in this test and we don't wait long enough for
    -- timeouts to expire. The leashing attack tests are testing the timeouts
    -- together with LoP.
    GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
forall blk.
(HasHeader blk, Ord blk) =>
GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
shrinkByRemovingAdversaries
    GenesisTestFull blk -> StateView blk -> Property
forall blk.
(HasHeader blk, GetHeader blk) =>
GenesisTestFull blk -> StateView blk -> Property
theProperty

genUniformSchedulePoints ::
  AF.HasHeader blk =>
  GenesisTest blk () -> QC.Gen (PointSchedule blk)
genUniformSchedulePoints :: forall blk.
HasHeader blk =>
GenesisTest blk () -> Gen (PointSchedule blk)
genUniformSchedulePoints GenesisTest blk ()
gt = (forall s. STGenM QCGen s -> ST s (PointSchedule blk))
-> Gen (PointSchedule blk)
forall a. (forall s. STGenM QCGen s -> ST s a) -> Gen a
stToGen (PointsGeneratorParams
-> BlockTree blk -> STGenM QCGen s -> ST s (PointSchedule blk)
forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
PointsGeneratorParams
-> BlockTree blk -> g -> m (PointSchedule blk)
uniformPoints PointsGeneratorParams
pointsGeneratorParams (GenesisTest blk () -> BlockTree blk
forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree GenesisTest blk ()
gt))
 where
  pointsGeneratorParams :: PointsGeneratorParams
pointsGeneratorParams =
    PointsGeneratorParams
      { pgpExtraHonestPeers :: Int
pgpExtraHonestPeers = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$ GenesisTest blk () -> Word
forall blk schedule. GenesisTest blk schedule -> Word
gtExtraHonestPeers GenesisTest blk ()
gt
      , pgpDowntime :: DowntimeParams
pgpDowntime = DowntimeParams
NoDowntime
      }

-- Note [Leashing attacks]
--
-- A leashing attack would be successfully conducted by a point schedule meeting
-- either of two conditions:
--
-- 1) it causes the node under test to stop making progress (i.e. the immutable
--    tip doesn't get close to the last genesis window of the honest chain), or
-- 2) it causes the node under test to still make progress but it is too slow
--    (in some sense of slow)
--
-- We produce schedules meeting the first condition by dropping random points
-- from the schedule of adversarial peers. If peers don't send the headers or
-- the blocks that they promised with a tip point, the node under test could
-- wait indefinitely without advancing the immutable tip.
--
-- We produce schedules meeting the second condition by stopping the execution
-- of the schedule after an amount of time that depends on the amount of blocks
-- to sync up and the timeouts allowed by Limit of Patience.
-- If the adversarial peers succeed in delaying the immutable tip, interrupting
-- the test at this point should cause the immutable tip to be too far behind
-- the last genesis window of the honest chain.

-- | Test that the leashing attacks do not delay the immutable tip.
--
-- See Note [Leashing attacks]
testLeashingAttackStalling ::
  forall blk.
  ( AF.HasHeader blk
  , GetHeader blk
  , IssueTestBlock blk
  , Ord blk
  ) =>
  ConformanceTest blk
testLeashingAttackStalling :: forall blk.
(HasHeader blk, GetHeader blk, IssueTestBlock blk, Ord blk) =>
ConformanceTest blk
testLeashingAttackStalling =
  String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> Property)
-> ConformanceTest blk
forall prop blk.
Testable prop =>
String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> prop)
-> ConformanceTest blk
mkConformanceTest
    String
"stalling leashing attack"
    AdjustTestCount
adjustTestCount
    AdjustMaxSize
adjustMaxSize
    (Gen Word -> Gen (GenesisTest blk ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
genChains ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
QC.choose (Word
1, Word
4)) Gen (GenesisTest blk ())
-> (GenesisTest blk () -> Gen (PointSchedule blk))
-> Gen (GenesisTestFull blk)
forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
`enrichedWith` GenesisTest blk () -> Gen (PointSchedule blk)
genLeashingSchedule)
    SchedulerConfig
defaultSchedulerConfig
      { scTrace = False
      , scEnableLoE = True
      , scEnableLoP = True
      , scEnableCSJ = True
      , scEnableBlockFetchTimeouts = False
      }
    GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
forall blk.
(HasHeader blk, Ord blk) =>
GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
shrinkPeerSchedules
    GenesisTestFull blk -> StateView blk -> Property
forall blk.
(HasHeader blk, GetHeader blk) =>
GenesisTestFull blk -> StateView blk -> Property
theProperty
 where
  -- \| Produces schedules that might cause the node under test to stall.
  --
  -- This is achieved by dropping random points from the schedule of each peer
  -- and by adding sufficient time at the end of a test to allow LoP and
  -- timeouts to disconnect adversaries.
  genLeashingSchedule :: GenesisTest blk () -> QC.Gen (PointSchedule blk)
  genLeashingSchedule :: GenesisTest blk () -> Gen (PointSchedule blk)
genLeashingSchedule GenesisTest blk ()
genesisTest = do
    ps@PointSchedule{psSchedule = sch} <-
      GenesisTest blk () -> PointSchedule blk -> PointSchedule blk
forall blk a.
GenesisTest blk a -> PointSchedule blk -> PointSchedule blk
ensureScheduleDuration GenesisTest blk ()
genesisTest (PointSchedule blk -> PointSchedule blk)
-> Gen (PointSchedule blk) -> Gen (PointSchedule blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenesisTest blk () -> Gen (PointSchedule blk)
forall blk.
HasHeader blk =>
GenesisTest blk () -> Gen (PointSchedule blk)
genUniformSchedulePoints GenesisTest blk ()
genesisTest
    advs <- mapM dropRandomPoints $ adversarialPeers sch
    pure $ ps{psSchedule = sch{adversarialPeers = advs}}

dropRandomPoints :: [(Time, SchedulePoint blk)] -> QC.Gen [(Time, SchedulePoint blk)]
dropRandomPoints :: forall blk.
[(Time, SchedulePoint blk)] -> Gen [(Time, SchedulePoint blk)]
dropRandomPoints [(Time, SchedulePoint blk)]
ps = do
  let lenps :: Int
lenps = [(Time, SchedulePoint blk)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Time, SchedulePoint blk)]
ps
      dropsMax :: Int
dropsMax = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
lenps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
  dropCount <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
dropsMax Int
2, Int
dropsMax)
  let dedup = (NonEmpty Int -> Int) -> [NonEmpty Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty Int -> Int
forall a. NonEmpty a -> a
NE.head ([NonEmpty Int] -> [Int])
-> ([Int] -> [NonEmpty Int]) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [NonEmpty Int]
forall (f :: * -> *) a. (Foldable f, Eq a) => f a -> [NonEmpty a]
NE.group
  is <- fmap (dedup . sort) $ replicateM dropCount $ QC.choose (0, lenps - 1)
  pure $ dropElemsAt ps is
 where
  dropElemsAt :: [a] -> [Int] -> [a]
  dropElemsAt :: forall a. [a] -> [Int] -> [a]
dropElemsAt [a]
xs [Int]
is' =
    let is :: IntSet
is = [Int] -> IntSet
IntSet.fromList [Int]
is'
     in [a
x | (a
x, Int
i) <- [a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs [Int
0 ..], Int
i Int -> IntSet -> Bool
`IntSet.notMember` IntSet
is]

-- | Test that the leashing attacks do not delay the immutable tip after. The
-- immutable tip needs to be advanced enough when the honest peer has offered
-- all of its ticks.
--
-- See Note [Leashing attacks]
testLeashingAttackTimeLimited ::
  forall blk.
  ( AF.HasHeader blk
  , GetHeader blk
  , IssueTestBlock blk
  , Ord blk
  ) =>
  ConformanceTest blk
testLeashingAttackTimeLimited :: forall blk.
(HasHeader blk, GetHeader blk, IssueTestBlock blk, Ord blk) =>
ConformanceTest blk
testLeashingAttackTimeLimited =
  String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> Property)
-> ConformanceTest blk
forall prop blk.
Testable prop =>
String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> prop)
-> ConformanceTest blk
mkConformanceTest
    String
"time limited leashing attack"
    AdjustTestCount
adjustTestCount
    AdjustMaxSize
adjustMaxSize
    (Gen Word -> Gen (GenesisTest blk ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
genChains ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
QC.choose (Word
1, Word
4)) Gen (GenesisTest blk ())
-> (GenesisTest blk () -> Gen (PointSchedule blk))
-> Gen (GenesisTestFull blk)
forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
`enrichedWith` GenesisTest blk () -> Gen (PointSchedule blk)
genTimeLimitedSchedule)
    SchedulerConfig
defaultSchedulerConfig
      { scTrace = False
      , scEnableLoE = True
      , scEnableLoP = True
      , scEnableCSJ = True
      , scEnableBlockFetchTimeouts = False
      }
    GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
forall blk.
(HasHeader blk, Ord blk) =>
GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
shrinkPeerSchedules
    GenesisTestFull blk -> StateView blk -> Property
forall blk.
(HasHeader blk, GetHeader blk) =>
GenesisTestFull blk -> StateView blk -> Property
theProperty
 where
  -- \| A schedule which doesn't run past the last event of the honest peer
  genTimeLimitedSchedule :: GenesisTest blk () -> QC.Gen (PointSchedule blk)
  genTimeLimitedSchedule :: GenesisTest blk () -> Gen (PointSchedule blk)
genTimeLimitedSchedule GenesisTest blk ()
genesisTest = do
    Peers honests advs0 <- PointSchedule blk -> Peers (PeerSchedule blk)
forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule (PointSchedule blk -> Peers (PeerSchedule blk))
-> Gen (PointSchedule blk) -> Gen (Peers (PeerSchedule blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenesisTest blk () -> Gen (PointSchedule blk)
forall blk.
HasHeader blk =>
GenesisTest blk () -> Gen (PointSchedule blk)
genUniformSchedulePoints GenesisTest blk ()
genesisTest
    let timeLimit =
          ChainSyncTimeout
-> LoPBucketParams
-> PeerSchedule blk
-> [PeerSchedule blk]
-> Time
estimateTimeBound
            (GenesisTest blk () -> ChainSyncTimeout
forall blk schedule. GenesisTest blk schedule -> ChainSyncTimeout
gtChainSyncTimeouts GenesisTest blk ()
genesisTest)
            (GenesisTest blk () -> LoPBucketParams
forall blk schedule. GenesisTest blk schedule -> LoPBucketParams
gtLoPBucketParams GenesisTest blk ()
genesisTest)
            (Map Int (PeerSchedule blk) -> PeerSchedule blk
forall a. Map Int a -> a
getHonestPeer Map Int (PeerSchedule blk)
honests)
            (Map Int (PeerSchedule blk) -> [PeerSchedule blk]
forall k a. Map k a -> [a]
Map.elems Map Int (PeerSchedule blk)
advs0)
        advs1 = (PeerSchedule blk -> PeerSchedule blk)
-> Map Int (PeerSchedule blk) -> Map Int (PeerSchedule blk)
forall a b. (a -> b) -> Map Int a -> Map Int b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Time -> PeerSchedule blk -> PeerSchedule blk
forall {b} {b}. Ord b => b -> [(b, b)] -> [(b, b)]
takePointsUntil Time
timeLimit) Map Int (PeerSchedule blk)
advs0
    advs <- mapM dropRandomPoints advs1
    pure $
      PointSchedule
        { psSchedule = Peers honests advs
        , psStartOrder = []
        , psMinEndTime = addGracePeriodDelay (length advs) timeLimit
        }

  takePointsUntil :: b -> [(b, b)] -> [(b, b)]
takePointsUntil b
limit = ((b, b) -> Bool) -> [(b, b)] -> [(b, b)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= b
limit) (b -> Bool) -> ((b, b) -> b) -> (b, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, b) -> b
forall a b. (a, b) -> a
fst)

  estimateTimeBound ::
    ChainSyncTimeout ->
    LoPBucketParams ->
    PeerSchedule blk ->
    [PeerSchedule blk] ->
    Time
  estimateTimeBound :: ChainSyncTimeout
-> LoPBucketParams
-> PeerSchedule blk
-> [PeerSchedule blk]
-> Time
estimateTimeBound ChainSyncTimeout
cst LoPBucketParams{Integer
lbpCapacity :: Integer
lbpCapacity :: LoPBucketParams -> Integer
lbpCapacity, Rational
lbpRate :: Rational
lbpRate :: LoPBucketParams -> Rational
lbpRate} PeerSchedule blk
honest [PeerSchedule blk]
advs =
    let firstTipPointTime :: Time
firstTipPointTime = (Time, WithOrigin blk) -> Time
forall a b. (a, b) -> a
fst ((Time, WithOrigin blk) -> Time) -> (Time, WithOrigin blk) -> Time
forall a b. (a -> b) -> a -> b
$ [(Time, WithOrigin blk)] -> (Time, WithOrigin blk)
forall a. HasCallStack => [a] -> a
headCallStack (((Time, SchedulePoint blk) -> Maybe (Time, WithOrigin blk))
-> PeerSchedule blk -> [(Time, WithOrigin blk)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Time, SchedulePoint blk) -> Maybe (Time, WithOrigin blk)
forall {a} {blk}.
(a, SchedulePoint blk) -> Maybe (a, WithOrigin blk)
fromTipPoint PeerSchedule blk
honest)
        lastBlockPoint :: (Time, blk)
lastBlockPoint = [(Time, blk)] -> (Time, blk)
forall a. HasCallStack => [a] -> a
last (((Time, SchedulePoint blk) -> Maybe (Time, blk))
-> PeerSchedule blk -> [(Time, blk)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Time, SchedulePoint blk) -> Maybe (Time, blk)
forall blk. (Time, SchedulePoint blk) -> Maybe (Time, blk)
fromBlockPoint PeerSchedule blk
honest)
        peerCount :: DiffTime
peerCount = Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> DiffTime) -> Int -> DiffTime
forall a b. (a -> b) -> a -> b
$ [PeerSchedule blk] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PeerSchedule blk]
advs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        maxBlockNo :: DiffTime
maxBlockNo = Word64 -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> DiffTime) -> Word64 -> DiffTime
forall a b. (a -> b) -> a -> b
$ [Word64] -> Word64
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Word64] -> Word64) -> [Word64] -> Word64
forall a b. (a -> b) -> a -> b
$ Word64
0 Word64 -> [Word64] -> [Word64]
forall a. a -> [a] -> [a]
: PeerSchedule blk -> [Word64]
blockPointNos PeerSchedule blk
honest [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ (PeerSchedule blk -> [Word64]) -> [PeerSchedule blk] -> [Word64]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PeerSchedule blk -> [Word64]
blockPointNos [PeerSchedule blk]
advs
        timeCapacity :: DiffTime
timeCapacity = Rational -> DiffTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> DiffTime) -> Rational -> DiffTime
forall a b. (a -> b) -> a -> b
$ (Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
lbpCapacity) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
lbpRate
        timePerToken :: DiffTime
timePerToken = Rational -> DiffTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> DiffTime) -> Rational -> DiffTime
forall a b. (a -> b) -> a -> b
$ Rational
1 Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
lbpRate
        intersectDiffTime :: DiffTime
intersectDiffTime = DiffTime -> Maybe DiffTime -> DiffTime
forall a. a -> Maybe a -> a
fromMaybe (String -> DiffTime
forall a. HasCallStack => String -> a
error String
"no intersect timeout") (ChainSyncTimeout -> Maybe DiffTime
intersectTimeout ChainSyncTimeout
cst)
     in -- Since the moment a peer offers the first tip, LoP should
        -- start ticking for it. This can be no later than what the intersect
        -- timeout allows for all peers.
        --
        -- Additionally, the actual delay might be greater if the honest peer
        -- has its last tick dispatched later.
        --
        -- Adversarial peers might cause more ticks to be sent as well. We
        -- bound it all by considering the highest block number that is ever
        -- sent.
        DiffTime -> Time -> Time
addTime DiffTime
1 (Time -> Time) -> Time -> Time
forall a b. (a -> b) -> a -> b
$
          Time -> Time -> Time
forall a. Ord a => a -> a -> a
max
            ((Time, blk) -> Time
forall a b. (a, b) -> a
fst (Time, blk)
lastBlockPoint)
            ( DiffTime -> Time -> Time
addTime
                (DiffTime
intersectDiffTime DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
timePerToken DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
maxBlockNo DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
timeCapacity DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
peerCount)
                Time
firstTipPointTime
            )

  blockPointNos :: [(Time, SchedulePoint blk)] -> [Word64]
  blockPointNos :: PeerSchedule blk -> [Word64]
blockPointNos =
    ((Time, blk) -> Word64) -> [(Time, blk)] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map (BlockNo -> Word64
unBlockNo (BlockNo -> Word64)
-> ((Time, blk) -> BlockNo) -> (Time, blk) -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo (blk -> BlockNo) -> ((Time, blk) -> blk) -> (Time, blk) -> BlockNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, blk) -> blk
forall a b. (a, b) -> b
snd)
      ([(Time, blk)] -> [Word64])
-> (PeerSchedule blk -> [(Time, blk)])
-> PeerSchedule blk
-> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Time, SchedulePoint blk) -> Maybe (Time, blk))
-> PeerSchedule blk -> [(Time, blk)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Time, SchedulePoint blk) -> Maybe (Time, blk)
forall blk. (Time, SchedulePoint blk) -> Maybe (Time, blk)
fromBlockPoint

  fromTipPoint :: (a, SchedulePoint blk) -> Maybe (a, WithOrigin blk)
fromTipPoint (a
t, ScheduleTipPoint WithOrigin blk
bp) = (a, WithOrigin blk) -> Maybe (a, WithOrigin blk)
forall a. a -> Maybe a
Just (a
t, WithOrigin blk
bp)
  fromTipPoint (a, SchedulePoint blk)
_ = Maybe (a, WithOrigin blk)
forall a. Maybe a
Nothing

headCallStack :: HasCallStack => [a] -> a
headCallStack :: forall a. HasCallStack => [a] -> a
headCallStack = \case
  a
x : [a]
_ -> a
x
  [a]
_ -> String -> a
forall a. HasCallStack => String -> a
error String
"headCallStack: empty list"

-- | Test that enabling the LoE causes the selection to remain at
-- the first fork intersection (keeping the immutable tip honest).
testLoeStalling ::
  forall blk.
  ( AF.HasHeader blk
  , GetHeader blk
  , IssueTestBlock blk
  , Ord blk
  ) =>
  ConformanceTest blk
testLoeStalling :: forall blk.
(HasHeader blk, GetHeader blk, IssueTestBlock blk, Ord blk) =>
ConformanceTest blk
testLoeStalling =
  String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> Property)
-> ConformanceTest blk
forall prop blk.
Testable prop =>
String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> prop)
-> ConformanceTest blk
mkConformanceTest
    String
"the LoE stalls the chain, but the immutable tip is honest"
    AdjustTestCount
adjustTestCount
    AdjustMaxSize
adjustMaxSize
    ( do
        gt <-
          Gen Word -> Gen (GenesisTest blk ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
genChains ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
QC.choose (Word
1, Word
4))
            Gen (GenesisTest blk ())
-> (GenesisTest blk () -> Gen (PointSchedule blk))
-> Gen (GenesisTestFull blk)
forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
`enrichedWith` GenesisTest blk () -> Gen (PointSchedule blk)
forall blk.
HasHeader blk =>
GenesisTest blk () -> Gen (PointSchedule blk)
genUniformSchedulePoints
        pure gt{gtChainSyncTimeouts = chainSyncNoTimeouts{canAwaitTimeout = shortWait}}
    )
    SchedulerConfig
defaultSchedulerConfig
      { scEnableLoE = True
      , scEnableCSJ = True
      , scEnableBlockFetchTimeouts = False
      }
    GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
forall blk.
(HasHeader blk, Ord blk) =>
GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
shrinkPeerSchedules
    GenesisTestFull blk -> StateView blk -> Property
prop
 where
  prop :: GenesisTestFull blk -> StateView blk -> Property
  prop :: GenesisTestFull blk -> StateView blk -> Property
prop gt :: GenesisTestFull blk
gt@GenesisTest{gtBlockTree :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree = BlockTree{AnchoredFragment blk
btTrunk :: AnchoredFragment blk
btTrunk :: forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk, [BlockTreeBranch blk]
btBranches :: forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches :: [BlockTreeBranch blk]
btBranches}} sv :: StateView blk
sv@StateView{AnchoredFragment (Header blk)
svSelectedChain :: forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain :: AnchoredFragment (Header blk)
svSelectedChain} =
    Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify ((ChainHash blk -> Bool) -> [ChainHash blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ChainHash blk -> ChainHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== ChainHash blk
selectionTip) [ChainHash blk]
allTips) String
"The selection is at a branch tip" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      Bool -> String -> Bool -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify ((AnchoredFragment blk -> Bool) -> [AnchoredFragment blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any AnchoredFragment blk -> Bool
anchorIsImmutableTip [AnchoredFragment blk]
suffixes) String
"The immutable tip is at a fork intersection" (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
        GenesisTestFull blk -> StateView blk -> Bool
forall blk.
GetHeader blk =>
GenesisTestFull blk -> StateView blk -> Bool
honestImmutableTip GenesisTestFull blk
gt StateView blk
sv
   where
    anchorIsImmutableTip :: AnchoredFragment blk -> Bool
anchorIsImmutableTip AnchoredFragment blk
branch = Anchor blk -> ChainHash blk
forall block. Anchor block -> ChainHash block
AF.anchorToHash (AnchoredFragment blk -> Anchor blk
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment blk
branch) ChainHash blk -> ChainHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== ChainHash blk
immutableTipHash

    immutableTipHash :: ChainHash blk
immutableTipHash = ChainHash (Header blk) -> ChainHash blk
forall blk. ChainHash (Header blk) -> ChainHash blk
castHeaderHash (ChainHash (Header blk) -> ChainHash blk)
-> (Anchor (Header blk) -> ChainHash (Header blk))
-> Anchor (Header blk)
-> ChainHash blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchor (Header blk) -> ChainHash (Header blk)
forall block. Anchor block -> ChainHash block
AF.anchorToHash (Anchor (Header blk) -> ChainHash blk)
-> Anchor (Header blk) -> ChainHash blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment (Header blk)
svSelectedChain

    selectionTip :: ChainHash blk
selectionTip = ChainHash (Header blk) -> ChainHash blk
forall blk. ChainHash (Header blk) -> ChainHash blk
castHeaderHash (ChainHash (Header blk) -> ChainHash blk)
-> ChainHash (Header blk) -> ChainHash blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> ChainHash (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> ChainHash block
AF.headHash AnchoredFragment (Header blk)
svSelectedChain

    allTips :: [ChainHash blk]
allTips = AnchoredFragment blk -> ChainHash blk
forall block.
HasHeader block =>
AnchoredFragment block -> ChainHash block
AF.headHash (AnchoredFragment blk -> ChainHash blk)
-> [AnchoredFragment blk] -> [ChainHash blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AnchoredFragment blk
btTrunk AnchoredFragment blk
-> [AnchoredFragment blk] -> [AnchoredFragment blk]
forall a. a -> [a] -> [a]
: [AnchoredFragment blk]
suffixes)

    suffixes :: [AnchoredFragment blk]
suffixes = BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix (BlockTreeBranch blk -> AnchoredFragment blk)
-> [BlockTreeBranch blk] -> [AnchoredFragment blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockTreeBranch blk]
btBranches

-- | This test sets 'scDowntime', which instructs the scheduler to shut all components down whenever a tick's duration
-- is greater than 11 seconds, and restarts it while only preserving the immutable DB after advancing the time.
--
-- This ensures that a user may shut down their machine while syncing without additional vulnerabilities.
testDowntime ::
  ( AF.HasHeader blk
  , GetHeader blk
  , IssueTestBlock blk
  , Ord blk
  ) =>
  ConformanceTest blk
testDowntime :: forall blk.
(HasHeader blk, GetHeader blk, IssueTestBlock blk, Ord blk) =>
ConformanceTest blk
testDowntime =
  String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> Property)
-> ConformanceTest blk
forall prop blk.
Testable prop =>
String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> prop)
-> ConformanceTest blk
mkConformanceTest
    String
"the node is shut down and restarted after some time"
    AdjustTestCount
adjustTestCount
    -- This is a crude way of ensuring that we don't get chains with more
    -- than 100 blocks, because this test writes the immutable chain to disk
    -- and `instance Binary TestBlock` chokes on long chains.
    (let AdjustMaxSize Int -> Int
ams = AdjustMaxSize
adjustMaxSize in (Int -> Int) -> AdjustMaxSize
AdjustMaxSize ((Int -> Int) -> AdjustMaxSize) -> (Int -> Int) -> AdjustMaxSize
forall a b. (a -> b) -> a -> b
$ Int -> Int
ams (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a b. a -> b -> a
const Int
10)
    ( Gen Word -> Gen (GenesisTest blk ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
genChains ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
QC.choose (Word
1, Word
4)) Gen (GenesisTest blk ())
-> (GenesisTest blk () -> Gen (PointSchedule blk))
-> Gen (GenesisTestFull blk)
forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
`enrichedWith` \GenesisTest blk ()
gt ->
        GenesisTest blk () -> PointSchedule blk -> PointSchedule blk
forall blk a.
GenesisTest blk a -> PointSchedule blk -> PointSchedule blk
ensureScheduleDuration GenesisTest blk ()
gt (PointSchedule blk -> PointSchedule blk)
-> Gen (PointSchedule blk) -> Gen (PointSchedule blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s. STGenM QCGen s -> ST s (PointSchedule blk))
-> Gen (PointSchedule blk)
forall a. (forall s. STGenM QCGen s -> ST s a) -> Gen a
stToGen (PointsGeneratorParams
-> BlockTree blk -> STGenM QCGen s -> ST s (PointSchedule blk)
forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
PointsGeneratorParams
-> BlockTree blk -> g -> m (PointSchedule blk)
uniformPoints (GenesisTest blk () -> PointsGeneratorParams
forall {blk} {schedule}.
GenesisTest blk schedule -> PointsGeneratorParams
pointsGeneratorParams GenesisTest blk ()
gt) (GenesisTest blk () -> BlockTree blk
forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree GenesisTest blk ()
gt))
    )
    SchedulerConfig
defaultSchedulerConfig
      { scEnableLoE = True
      , scEnableLoP = True
      , scDowntime = Just 11
      , scEnableCSJ = True
      , scEnableBlockFetchTimeouts = False
      }
    GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
forall blk.
(HasHeader blk, Ord blk) =>
GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
shrinkPeerSchedules
    ( \GenesisTestFull blk
genesisTest StateView blk
stateView ->
        String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
          ( [String] -> String
unlines
              [ String
"TODO: Shutting down the node inserts delays in the simulation that"
              , String
"are not reflected in the point schedule table. Reporting these delays"
              , String
"correctly is still to be done."
              ]
          )
          (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ GenesisTestFull blk -> StateView blk -> Property
forall blk.
(HasHeader blk, GetHeader blk) =>
GenesisTestFull blk -> StateView blk -> Property
theProperty GenesisTestFull blk
genesisTest StateView blk
stateView
    )
 where
  pointsGeneratorParams :: GenesisTest blk schedule -> PointsGeneratorParams
pointsGeneratorParams GenesisTest blk schedule
gt =
    PointsGeneratorParams
      { pgpExtraHonestPeers :: Int
pgpExtraHonestPeers = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (GenesisTest blk schedule -> Word
forall blk schedule. GenesisTest blk schedule -> Word
gtExtraHonestPeers GenesisTest blk schedule
gt)
      , pgpDowntime :: DowntimeParams
pgpDowntime = SecurityParam -> DowntimeParams
DowntimeWithSecurityParam (GenesisTest blk schedule -> SecurityParam
forall blk schedule. GenesisTest blk schedule -> SecurityParam
gtSecurityParam GenesisTest blk schedule
gt)
      }

-- | Test that the block fetch leashing attack does not delay the immutable tip.
-- This leashing attack consists in having adversarial peers that behave
-- honestly when it comes to ChainSync but refuse to send blocks. A proper node
-- under test should detect those behaviours as adversarial and find a way to
-- make progress.
--
-- See Note [Leashing attacks]
testBlockFetchLeashingAttack ::
  forall blk.
  ( AF.HasHeader blk
  , GetHeader blk
  , IssueTestBlock blk
  , Ord blk
  ) =>
  ConformanceTest blk
testBlockFetchLeashingAttack :: forall blk.
(HasHeader blk, GetHeader blk, IssueTestBlock blk, Ord blk) =>
ConformanceTest blk
testBlockFetchLeashingAttack =
  String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> Property)
-> ConformanceTest blk
forall prop blk.
Testable prop =>
String
-> AdjustTestCount
-> AdjustMaxSize
-> Gen (GenesisTestFull blk)
-> SchedulerConfig
-> (GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk])
-> (GenesisTestFull blk -> StateView blk -> prop)
-> ConformanceTest blk
mkConformanceTest
    String
"block fetch leashing attack"
    AdjustTestCount
adjustTestCount
    AdjustMaxSize
adjustMaxSize
    (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 () -> Gen (PointSchedule blk))
-> Gen (GenesisTestFull blk)
forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
`enrichedWith` GenesisTest blk () -> Gen (PointSchedule blk)
genBlockFetchLeashingSchedule)
    SchedulerConfig
defaultSchedulerConfig
      { scEnableLoE = True
      , scEnableLoP = True
      , scEnableCSJ = True
      , scEnableBlockFetchTimeouts = False
      }
    GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
forall blk.
(HasHeader blk, Ord blk) =>
GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
shrinkPeerSchedules
    GenesisTestFull blk -> StateView blk -> Property
forall blk.
(HasHeader blk, GetHeader blk) =>
GenesisTestFull blk -> StateView blk -> Property
theProperty
 where
  genBlockFetchLeashingSchedule :: GenesisTest blk () -> QC.Gen (PointSchedule blk)
  genBlockFetchLeashingSchedule :: GenesisTest blk () -> Gen (PointSchedule blk)
genBlockFetchLeashingSchedule GenesisTest blk ()
genesisTest = do
    -- A schedule with several honest peers and no adversaries. We will then
    -- keep one of those as honest and remove the block points from the
    -- others, hence producing one honest peer and several adversaries.
    PointSchedule{psSchedule} <-
      (forall s. STGenM QCGen s -> ST s (PointSchedule blk))
-> Gen (PointSchedule blk)
forall a. (forall s. STGenM QCGen s -> ST s a) -> Gen a
stToGen ((forall s. STGenM QCGen s -> ST s (PointSchedule blk))
 -> Gen (PointSchedule blk))
-> (forall s. STGenM QCGen s -> ST s (PointSchedule blk))
-> Gen (PointSchedule blk)
forall a b. (a -> b) -> a -> b
$
        PointsGeneratorParams
-> BlockTree blk -> STGenM QCGen s -> ST s (PointSchedule blk)
forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
PointsGeneratorParams
-> BlockTree blk -> g -> m (PointSchedule blk)
uniformPoints
          (PointsGeneratorParams{pgpExtraHonestPeers :: Int
pgpExtraHonestPeers = Int
1, pgpDowntime :: DowntimeParams
pgpDowntime = DowntimeParams
NoDowntime})
          (GenesisTest blk () -> BlockTree blk
forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree GenesisTest blk ()
genesisTest)
    peers <- QC.shuffle $ Map.elems $ honestPeers psSchedule
    let (honest, adversaries) = fromMaybe (error "blockFetchLeashingAttack") $ uncons peers
        adversaries' = (PeerSchedule blk -> PeerSchedule blk)
-> [PeerSchedule blk] -> [PeerSchedule blk]
forall a b. (a -> b) -> [a] -> [b]
map (((Time, SchedulePoint blk) -> Bool)
-> PeerSchedule blk -> PeerSchedule blk
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Time, SchedulePoint blk) -> Bool)
-> (Time, SchedulePoint blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchedulePoint blk -> Bool
isBlockPoint (SchedulePoint blk -> Bool)
-> ((Time, SchedulePoint blk) -> SchedulePoint blk)
-> (Time, SchedulePoint blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, SchedulePoint blk) -> SchedulePoint blk
forall a b. (a, b) -> b
snd)) [PeerSchedule blk]
adversaries
        psSchedule' = [PeerSchedule blk]
-> [PeerSchedule blk] -> Peers (PeerSchedule blk)
forall a. [a] -> [a] -> Peers a
peers' [PeerSchedule blk
honest] [PeerSchedule blk]
adversaries'
    -- Important to shuffle the order in which the peers start, otherwise the
    -- honest peer starts first and systematically becomes dynamo.
    psStartOrder <- shuffle $ getPeerIds psSchedule'
    let maxTime =
          Int -> Time -> Time
addGracePeriodDelay ([PeerSchedule blk] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PeerSchedule blk]
adversaries') (Time -> Time) -> Time -> Time
forall a b. (a -> b) -> a -> b
$
            [Time] -> Time
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Time] -> Time) -> [Time] -> Time
forall a b. (a -> b) -> a -> b
$
              DiffTime -> Time
Time DiffTime
0 Time -> [Time] -> [Time]
forall a. a -> [a] -> [a]
: [Time
pt | PeerSchedule blk
s <- PeerSchedule blk
honest PeerSchedule blk -> [PeerSchedule blk] -> [PeerSchedule blk]
forall a. a -> [a] -> [a]
: [PeerSchedule blk]
adversaries', (Time
pt, SchedulePoint blk
_) <- Int -> PeerSchedule blk -> PeerSchedule blk
forall a. Int -> [a] -> [a]
take Int
1 (PeerSchedule blk -> PeerSchedule blk
forall a. [a] -> [a]
reverse PeerSchedule blk
s)]
    pure $
      PointSchedule
        { psSchedule = psSchedule'
        , psStartOrder
        , -- Allow to run the blockfetch decision logic after the last tick
          -- 11 is the grace period for unresponsive peers that should send
          -- blocks
          psMinEndTime = addTime 11 maxTime
        }

  isBlockPoint :: SchedulePoint blk -> Bool
  isBlockPoint :: SchedulePoint blk -> Bool
isBlockPoint (ScheduleBlockPoint WithOrigin blk
_) = Bool
True
  isBlockPoint SchedulePoint blk
_ = Bool
False

-- | Add a delay at the end of tests to account for retention of blocks
-- by adversarial peers in blockfetch. This delay is 10 seconds per
-- adversarial peer.
addGracePeriodDelay :: Int -> Time -> Time
addGracePeriodDelay :: Int -> Time -> Time
addGracePeriodDelay Int
adversaryCount = DiffTime -> Time -> Time
addTime (Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
adversaryCount DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
10)