{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# 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 (
    genUniformSchedulePoints
  , tests
  ) where

import           Cardano.Slotting.Slot (SlotNo (SlotNo), WithOrigin (..))
import           Control.Monad (replicateM)
import           Control.Monad.Class.MonadTime.SI (Time, addTime)
import           Data.List (intercalate, sort)
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 (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.ChainSync.Codec
                     (ChainSyncTimeout (..))
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.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 (..), isHonestPeerId)
import           Test.Consensus.PointSchedule.Shrinking
                     (shrinkByRemovingAdversaries, shrinkPeerSchedules)
import           Test.Consensus.PointSchedule.SinglePeer
                     (SchedulePoint (ScheduleBlockPoint, ScheduleTipPoint))
import           Test.Ouroboros.Consensus.ChainGenerator.Params (Delta (Delta))
import qualified Test.QuickCheck as QC
import           Test.QuickCheck
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Test.Util.Orphans.IOLike ()
import           Test.Util.PartialAccessors
import           Test.Util.QuickCheck (le)
import           Test.Util.TestBlock (TestBlock)
import           Test.Util.TestEnv (adjustQuickCheckMaxSize,
                     adjustQuickCheckTests)
import           Text.Printf (printf)

tests :: TestTree
tests :: TestTree
tests =
  (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
  (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckMaxSize (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
  TestName -> [TestTree] -> TestTree
testGroup TestName
"uniform" [
    -- See Note [Leashing attacks]
    TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"stalling leashing attack" Property
prop_leashingAttackStalling,
    TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"time limited leashing attack" Property
prop_leashingAttackTimeLimited,
    TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"serve adversarial branches" Property
prop_serveAdversarialBranches,
    TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"the LoE stalls the chain, but the immutable tip is honest" Property
prop_loeStalling,
    -- 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.
    (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckMaxSize (Int -> Int -> Int
forall a b. a -> b -> a
const Int
10) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
    TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"the node is shut down and restarted after some time" Property
prop_downtime
    ]

theProperty ::
  GenesisTestFull TestBlock ->
  StateView TestBlock ->
  Property
theProperty :: GenesisTestFull TestBlock -> StateView TestBlock -> Property
theProperty GenesisTestFull TestBlock
genesisTest stateView :: StateView TestBlock
stateView@StateView{AnchoredFragment (Header TestBlock)
svSelectedChain :: AnchoredFragment (Header TestBlock)
svSelectedChain :: forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain} =
  Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify Bool
genesisWindowAfterIntersection TestName
"Full genesis window after intersection" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify ([Word64] -> Bool
forall {a}. [a] -> Bool
isOrigin [Word64]
immutableTipHash) TestName
"Immutable tip is Origin" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
label TestName
disconnectedLabel (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Int
advCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [BlockTreeBranch TestBlock] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (BlockTree TestBlock -> [BlockTreeBranch TestBlock]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches BlockTree TestBlock
gtBlockTree)) TestName
"Some adversaries performed rollbacks" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
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 [
    TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"An honest peer was 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),
    TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"The immutable tip is not honest: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Anchor (Header TestBlock) -> TestName
forall a. Show a => a -> TestName
show Anchor (Header TestBlock)
immutableTip) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Bool -> Property
forall prop. Testable prop => prop -> Property
property ([Word64] -> Bool
isHonest [Word64]
immutableTipHash),
    Property
immutableTipIsRecent
  ]
  where
    advCount :: Int
advCount = Map Int (PeerSchedule TestBlock) -> Int
forall k a. Map k a -> Int
Map.size (Peers (PeerSchedule TestBlock) -> Map Int (PeerSchedule TestBlock)
forall a. Peers a -> Map Int a
adversarialPeers (PointSchedule TestBlock -> Peers (PeerSchedule TestBlock)
forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule (PointSchedule TestBlock -> Peers (PeerSchedule TestBlock))
-> PointSchedule TestBlock -> Peers (PeerSchedule TestBlock)
forall a b. (a -> b) -> a -> b
$ GenesisTestFull TestBlock -> PointSchedule TestBlock
forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule GenesisTestFull TestBlock
genesisTest))

    immutableTipIsRecent :: Property
immutableTipIsRecent =
      TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Age of the immutable tip: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Word64 -> TestName
forall a. Show a => a -> TestName
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

    isOrigin :: [a] -> Bool
isOrigin = [a] -> Bool
forall {a}. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null

    isHonest :: [Word64] -> Bool
isHonest = (Word64 -> Bool) -> [Word64] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Word64
0 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
==)

    immutableTipHash :: [Word64]
immutableTipHash = ChainHash (Header TestBlock) -> [Word64]
forall block.
(HeaderHash block ~ TestHash) =>
ChainHash block -> [Word64]
simpleHash (Anchor (Header TestBlock) -> ChainHash (Header TestBlock)
forall block. Anchor block -> ChainHash block
AF.anchorToHash Anchor (Header TestBlock)
immutableTip)

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

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

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

    disconnected :: [PeerId]
disconnected = StateView TestBlock -> [PeerId]
forall blk. StateView blk -> [PeerId]
collectDisconnectedPeers StateView TestBlock
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 :: TestName
killedPeers = case [PeerId]
disconnected of
      [] -> TestName
"No peers were disconnected"
      [PeerId]
peers -> TestName
"Some peers were disconnected: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName -> [TestName] -> TestName
forall a. [a] -> [[a]] -> [a]
intercalate TestName
", " (PeerId -> TestName
forall a. Condense a => a -> TestName
condense (PeerId -> TestName) -> [PeerId] -> [TestName]
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
$ TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot (TestBlock -> SlotNo) -> TestBlock -> SlotNo
forall a b. (a -> b) -> a -> b
$ (Time, TestBlock) -> TestBlock
forall a b. (a, b) -> b
snd ((Time, TestBlock) -> TestBlock) -> (Time, TestBlock) -> TestBlock
forall a b. (a -> b) -> a -> b
$ [(Time, TestBlock)] -> (Time, TestBlock)
forall a. HasCallStack => [a] -> a
last ([(Time, TestBlock)] -> (Time, TestBlock))
-> [(Time, TestBlock)] -> (Time, TestBlock)
forall a b. (a -> b) -> a -> b
$ ((Time, SchedulePoint TestBlock) -> Maybe (Time, TestBlock))
-> PeerSchedule TestBlock -> [(Time, TestBlock)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Time, SchedulePoint TestBlock) -> Maybe (Time, TestBlock)
forall blk. (Time, SchedulePoint blk) -> Maybe (Time, blk)
fromBlockPoint (PeerSchedule TestBlock -> [(Time, TestBlock)])
-> PeerSchedule TestBlock -> [(Time, TestBlock)]
forall a b. (a -> b) -> a -> b
$ Map Int (PeerSchedule TestBlock) -> PeerSchedule TestBlock
forall a. Map Int a -> a
getHonestPeer (Map Int (PeerSchedule TestBlock) -> PeerSchedule TestBlock)
-> Map Int (PeerSchedule TestBlock) -> PeerSchedule TestBlock
forall a b. (a -> b) -> a -> b
$ Peers (PeerSchedule TestBlock) -> Map Int (PeerSchedule TestBlock)
forall a. Peers a -> Map Int a
honestPeers (Peers (PeerSchedule TestBlock)
 -> Map Int (PeerSchedule TestBlock))
-> Peers (PeerSchedule TestBlock)
-> Map Int (PeerSchedule TestBlock)
forall a b. (a -> b) -> a -> b
$ PointSchedule TestBlock -> Peers (PeerSchedule TestBlock)
forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule (PointSchedule TestBlock -> Peers (PeerSchedule TestBlock))
-> PointSchedule TestBlock -> Peers (PeerSchedule TestBlock)
forall a b. (a -> b) -> a -> b
$ GenesisTestFull TestBlock -> PointSchedule TestBlock
forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule GenesisTestFull TestBlock
genesisTest

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

    Classifiers {Bool
genesisWindowAfterIntersection :: Bool
genesisWindowAfterIntersection :: Classifiers -> Bool
genesisWindowAfterIntersection, Bool
longerThanGenesisWindow :: Bool
longerThanGenesisWindow :: Classifiers -> Bool
longerThanGenesisWindow} = GenesisTestFull TestBlock -> Classifiers
forall blk schedule.
HasHeader blk =>
GenesisTest blk schedule -> Classifiers
classifiers GenesisTestFull TestBlock
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.
prop_serveAdversarialBranches :: Property
prop_serveAdversarialBranches :: Property
prop_serveAdversarialBranches = Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> Property)
-> Property
forall prop.
Testable prop =>
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> prop)
-> Property
forAllGenesisTest

    (Gen Word -> Gen (GenesisTest TestBlock ())
genChains ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
QC.choose (Word
1, Word
4)) Gen (GenesisTest TestBlock ())
-> (GenesisTest TestBlock () -> Gen (PointSchedule TestBlock))
-> Gen (GenesisTestFull TestBlock)
forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
`enrichedWith` GenesisTest TestBlock () -> Gen (PointSchedule TestBlock)
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 TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinkByRemovingAdversaries

    GenesisTestFull TestBlock -> StateView TestBlock -> Property
theProperty

genUniformSchedulePoints :: GenesisTest TestBlock () -> QC.Gen (PointSchedule TestBlock)
genUniformSchedulePoints :: GenesisTest TestBlock () -> Gen (PointSchedule TestBlock)
genUniformSchedulePoints GenesisTest TestBlock ()
gt = (forall s. STGenM QCGen s -> ST s (PointSchedule TestBlock))
-> Gen (PointSchedule TestBlock)
forall a. (forall s. STGenM QCGen s -> ST s a) -> Gen a
stToGen (PointsGeneratorParams
-> BlockTree TestBlock
-> STGenM QCGen s
-> ST s (PointSchedule TestBlock)
forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
PointsGeneratorParams
-> BlockTree blk -> g -> m (PointSchedule blk)
uniformPoints PointsGeneratorParams
pointsGeneratorParams (GenesisTest TestBlock () -> BlockTree TestBlock
forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree GenesisTest TestBlock ()
gt))
  where
    pointsGeneratorParams :: PointsGeneratorParams
pointsGeneratorParams = PointsGeneratorParams
      { $sel:pgpExtraHonestPeers:PointsGeneratorParams :: 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 TestBlock () -> Word
forall blk schedule. GenesisTest blk schedule -> Word
gtExtraHonestPeers GenesisTest TestBlock ()
gt
      , $sel:pgpDowntime:PointsGeneratorParams :: 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
prop_leashingAttackStalling :: Property
prop_leashingAttackStalling :: Property
prop_leashingAttackStalling =
  Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> Property)
-> Property
forall prop.
Testable prop =>
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> prop)
-> Property
forAllGenesisTest

    (GenesisTestFull TestBlock -> GenesisTestFull TestBlock
forall {blk} {schedule}.
GenesisTest blk schedule -> GenesisTest blk schedule
disableBoringTimeouts (GenesisTestFull TestBlock -> GenesisTestFull TestBlock)
-> Gen (GenesisTestFull TestBlock)
-> Gen (GenesisTestFull TestBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word -> Gen (GenesisTest TestBlock ())
genChains ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
QC.choose (Word
1, Word
4)) Gen (GenesisTest TestBlock ())
-> (GenesisTest TestBlock () -> Gen (PointSchedule TestBlock))
-> Gen (GenesisTestFull TestBlock)
forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
`enrichedWith` GenesisTest TestBlock () -> Gen (PointSchedule TestBlock)
genLeashingSchedule)

    SchedulerConfig
defaultSchedulerConfig
      { scTrace = False
      , scEnableLoE = True
      , scEnableLoP = True
      , scEnableCSJ = True
      }

    GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinkPeerSchedules

    GenesisTestFull TestBlock -> StateView TestBlock -> 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 TestBlock () -> QC.Gen (PointSchedule TestBlock)
    genLeashingSchedule :: GenesisTest TestBlock () -> Gen (PointSchedule TestBlock)
genLeashingSchedule GenesisTest TestBlock ()
genesisTest = do
      ps :: PointSchedule TestBlock
ps@PointSchedule{$sel:psSchedule:PointSchedule :: forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule = Peers (PeerSchedule TestBlock)
sch} <- GenesisTest TestBlock ()
-> PointSchedule TestBlock -> PointSchedule TestBlock
forall blk a.
GenesisTest blk a -> PointSchedule blk -> PointSchedule blk
ensureScheduleDuration GenesisTest TestBlock ()
genesisTest (PointSchedule TestBlock -> PointSchedule TestBlock)
-> Gen (PointSchedule TestBlock) -> Gen (PointSchedule TestBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenesisTest TestBlock () -> Gen (PointSchedule TestBlock)
genUniformSchedulePoints GenesisTest TestBlock ()
genesisTest
      Map Int (PeerSchedule TestBlock)
advs <- (PeerSchedule TestBlock -> Gen (PeerSchedule TestBlock))
-> Map Int (PeerSchedule TestBlock)
-> Gen (Map Int (PeerSchedule TestBlock))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map Int a -> m (Map Int b)
mapM PeerSchedule TestBlock -> Gen (PeerSchedule TestBlock)
forall blk.
[(Time, SchedulePoint blk)] -> Gen [(Time, SchedulePoint blk)]
dropRandomPoints (Map Int (PeerSchedule TestBlock)
 -> Gen (Map Int (PeerSchedule TestBlock)))
-> Map Int (PeerSchedule TestBlock)
-> Gen (Map Int (PeerSchedule TestBlock))
forall a b. (a -> b) -> a -> b
$ Peers (PeerSchedule TestBlock) -> Map Int (PeerSchedule TestBlock)
forall a. Peers a -> Map Int a
adversarialPeers Peers (PeerSchedule TestBlock)
sch
      PointSchedule TestBlock -> Gen (PointSchedule TestBlock)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PointSchedule TestBlock -> Gen (PointSchedule TestBlock))
-> PointSchedule TestBlock -> Gen (PointSchedule TestBlock)
forall a b. (a -> b) -> a -> b
$ PointSchedule TestBlock
ps {psSchedule = sch {adversarialPeers = advs}}

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

    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
      Int
dropCount <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0, 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 -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
lenps Int
5)
      let dedup :: [Int] -> [Int]
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
      [Int]
is <- ([Int] -> [Int]) -> Gen [Int] -> Gen [Int]
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Int] -> [Int]
dedup ([Int] -> [Int]) -> ([Int] -> [Int]) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort) (Gen [Int] -> Gen [Int]) -> Gen [Int] -> Gen [Int]
forall a b. (a -> b) -> a -> b
$ Int -> Gen Int -> Gen [Int]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
dropCount (Gen Int -> Gen [Int]) -> Gen Int -> Gen [Int]
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0, Int
lenps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      [(Time, SchedulePoint blk)] -> Gen [(Time, SchedulePoint blk)]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Time, SchedulePoint blk)] -> Gen [(Time, SchedulePoint blk)])
-> [(Time, SchedulePoint blk)] -> Gen [(Time, SchedulePoint blk)]
forall a b. (a -> b) -> a -> b
$ [(Time, SchedulePoint blk)] -> [Int] -> [(Time, SchedulePoint blk)]
forall a. [a] -> [Int] -> [a]
dropElemsAt [(Time, SchedulePoint blk)]
ps [Int]
is

    dropElemsAt :: [a] -> [Int] -> [a]
    dropElemsAt :: forall a. [a] -> [Int] -> [a]
dropElemsAt [a]
xs [] = [a]
xs
    dropElemsAt [a]
xs (Int
i:[Int]
is) =
      let ([a]
ys, [a]
zs) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [a]
xs
       in [a]
ys [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [Int] -> [a]
forall a. [a] -> [Int] -> [a]
dropElemsAt (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1 [a]
zs) [Int]
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.
--
-- This test is expected to fail because we don't test a genesis implementation
-- yet.
--
-- See Note [Leashing attacks]
prop_leashingAttackTimeLimited :: Property
prop_leashingAttackTimeLimited :: Property
prop_leashingAttackTimeLimited =
  Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> Property)
-> Property
forall prop.
Testable prop =>
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> prop)
-> Property
forAllGenesisTest

    (GenesisTestFull TestBlock -> GenesisTestFull TestBlock
forall {blk} {schedule}.
GenesisTest blk schedule -> GenesisTest blk schedule
disableBoringTimeouts (GenesisTestFull TestBlock -> GenesisTestFull TestBlock)
-> Gen (GenesisTestFull TestBlock)
-> Gen (GenesisTestFull TestBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word -> Gen (GenesisTest TestBlock ())
genChains ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
QC.choose (Word
1, Word
4)) Gen (GenesisTest TestBlock ())
-> (GenesisTest TestBlock () -> Gen (PointSchedule TestBlock))
-> Gen (GenesisTestFull TestBlock)
forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
`enrichedWith` GenesisTest TestBlock () -> Gen (PointSchedule TestBlock)
genTimeLimitedSchedule)

    SchedulerConfig
defaultSchedulerConfig
      { scTrace = False
      , scEnableLoE = True
      , scEnableLoP = True
      , scEnableBlockFetchTimeouts = False
      , scEnableCSJ = True
      }

    GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinkPeerSchedules

    GenesisTestFull TestBlock -> StateView TestBlock -> Property
theProperty

  where
    -- | A schedule which doesn't run past the last event of the honest peer
    genTimeLimitedSchedule :: GenesisTest TestBlock () -> QC.Gen (PointSchedule TestBlock)
    genTimeLimitedSchedule :: GenesisTest TestBlock () -> Gen (PointSchedule TestBlock)
genTimeLimitedSchedule GenesisTest TestBlock ()
genesisTest = do
      Peers Map Int (PeerSchedule TestBlock)
honests Map Int (PeerSchedule TestBlock)
advs0 <- PointSchedule TestBlock -> Peers (PeerSchedule TestBlock)
forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule (PointSchedule TestBlock -> Peers (PeerSchedule TestBlock))
-> Gen (PointSchedule TestBlock)
-> Gen (Peers (PeerSchedule TestBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenesisTest TestBlock () -> Gen (PointSchedule TestBlock)
genUniformSchedulePoints GenesisTest TestBlock ()
genesisTest
      let timeLimit :: Time
timeLimit = ChainSyncTimeout
-> LoPBucketParams
-> PeerSchedule TestBlock
-> [PeerSchedule TestBlock]
-> Time
forall blk.
HasHeader blk =>
ChainSyncTimeout
-> LoPBucketParams
-> PeerSchedule blk
-> [PeerSchedule blk]
-> Time
estimateTimeBound
            (GenesisTest TestBlock () -> ChainSyncTimeout
forall blk schedule. GenesisTest blk schedule -> ChainSyncTimeout
gtChainSyncTimeouts GenesisTest TestBlock ()
genesisTest)
            (GenesisTest TestBlock () -> LoPBucketParams
forall blk schedule. GenesisTest blk schedule -> LoPBucketParams
gtLoPBucketParams GenesisTest TestBlock ()
genesisTest)
            (Map Int (PeerSchedule TestBlock) -> PeerSchedule TestBlock
forall a. Map Int a -> a
getHonestPeer Map Int (PeerSchedule TestBlock)
honests)
            (Map Int (PeerSchedule TestBlock) -> [PeerSchedule TestBlock]
forall k a. Map k a -> [a]
Map.elems Map Int (PeerSchedule TestBlock)
advs0)
          advs :: Map Int (PeerSchedule TestBlock)
advs = (PeerSchedule TestBlock -> PeerSchedule TestBlock)
-> Map Int (PeerSchedule TestBlock)
-> Map Int (PeerSchedule TestBlock)
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 TestBlock -> PeerSchedule TestBlock
forall {b} {b}. Ord b => b -> [(b, b)] -> [(b, b)]
takePointsUntil Time
timeLimit) Map Int (PeerSchedule TestBlock)
advs0
      PointSchedule TestBlock -> Gen (PointSchedule TestBlock)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PointSchedule TestBlock -> Gen (PointSchedule TestBlock))
-> PointSchedule TestBlock -> Gen (PointSchedule TestBlock)
forall a b. (a -> b) -> a -> b
$ PointSchedule
        { $sel:psSchedule:PointSchedule :: Peers (PeerSchedule TestBlock)
psSchedule = Map Int (PeerSchedule TestBlock)
-> Map Int (PeerSchedule TestBlock)
-> Peers (PeerSchedule TestBlock)
forall a. Map Int a -> Map Int a -> Peers a
Peers Map Int (PeerSchedule TestBlock)
honests Map Int (PeerSchedule TestBlock)
advs
        , $sel:psMinEndTime:PointSchedule :: Time
psMinEndTime = Time
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)

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

    estimateTimeBound
      :: AF.HasHeader blk
      => ChainSyncTimeout
      -> LoPBucketParams
      -> PeerSchedule blk
      -> [PeerSchedule blk]
      -> Time
    estimateTimeBound :: forall blk.
HasHeader blk =>
ChainSyncTimeout
-> LoPBucketParams
-> PeerSchedule blk
-> [PeerSchedule blk]
-> Time
estimateTimeBound ChainSyncTimeout
cst LoPBucketParams{Integer
lbpCapacity :: Integer
$sel:lbpCapacity:LoPBucketParams :: LoPBucketParams -> Integer
lbpCapacity, Rational
lbpRate :: Rational
$sel:lbpRate:LoPBucketParams :: 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]
forall blk.
HasHeader blk =>
[(Time, SchedulePoint 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]
forall blk.
HasHeader blk =>
[(Time, SchedulePoint 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 (TestName -> DiffTime
forall a. HasCallStack => TestName -> a
error TestName
"no intersect timeout") (ChainSyncTimeout -> Maybe DiffTime
intersectTimeout ChainSyncTimeout
cst)
          -- 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.
      in 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 :: AF.HasHeader blk => [(Time, SchedulePoint blk)] -> [Word64]
    blockPointNos :: forall blk.
HasHeader blk =>
[(Time, SchedulePoint 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])
-> ([(Time, SchedulePoint blk)] -> [(Time, blk)])
-> [(Time, SchedulePoint blk)]
-> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ((Time, SchedulePoint blk) -> Maybe (Time, blk))
-> [(Time, SchedulePoint 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]
_   -> TestName -> a
forall a. HasCallStack => TestName -> a
error TestName
"headCallStack: empty list"

-- | Test that enabling the LoE using the updater that sets the LoE fragment to
-- the shared prefix (as used by the GDDG) causes the selection to remain at
-- the first fork intersection (keeping the immutable tip honest).
--
-- This is pretty slow since it relies on timeouts to terminate the test.
prop_loeStalling :: Property
prop_loeStalling :: Property
prop_loeStalling =
  Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> Property)
-> Property
forall prop.
Testable prop =>
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> prop)
-> Property
forAllGenesisTest

    (do GenesisTestFull TestBlock
gt <- Gen Word -> Gen (GenesisTest TestBlock ())
genChains ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
QC.choose (Word
1, Word
4))
                Gen (GenesisTest TestBlock ())
-> (GenesisTest TestBlock () -> Gen (PointSchedule TestBlock))
-> Gen (GenesisTestFull TestBlock)
forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
`enrichedWith`
              GenesisTest TestBlock () -> Gen (PointSchedule TestBlock)
genUniformSchedulePoints
        GenesisTestFull TestBlock -> Gen (GenesisTestFull TestBlock)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenesisTestFull TestBlock
gt {gtChainSyncTimeouts = chainSyncNoTimeouts {canAwaitTimeout = shortWait}}
    )

    SchedulerConfig
defaultSchedulerConfig {
      scEnableLoE = True,
      scEnableCSJ = True
    }

    GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinkPeerSchedules

    GenesisTestFull TestBlock -> StateView TestBlock -> Property
forall {b} {blk} {schedule}.
(HeaderHash b ~ TestHash, HeaderHash blk ~ TestHash, HasHeader b,
 HasHeader blk, HasHeader (Header blk)) =>
GenesisTest b schedule -> StateView blk -> Property
prop
  where
    prop :: GenesisTest b schedule -> StateView blk -> Property
prop GenesisTest {$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree = BlockTree {AnchoredFragment b
btTrunk :: AnchoredFragment b
btTrunk :: forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk, [BlockTreeBranch b]
btBranches :: forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches :: [BlockTreeBranch b]
btBranches}} StateView{AnchoredFragment (Header blk)
svSelectedChain :: forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain :: AnchoredFragment (Header blk)
svSelectedChain} =
      Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (([Word64] -> Bool) -> [[Word64]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Word64] -> [Word64] -> Bool
forall a. Eq a => a -> a -> Bool
== [Word64]
selectionTip) [[Word64]]
allTips) TestName
"The selection is at a branch tip" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify ((AnchoredFragment b -> Bool) -> [AnchoredFragment b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any AnchoredFragment b -> Bool
anchorIsImmutableTip [AnchoredFragment b]
suffixes) TestName
"The immutable tip is at a fork intersection" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      Bool -> Property
forall prop. Testable prop => prop -> Property
property ([Word64] -> Bool
isHonest [Word64]
immutableTipHash)
      where
        anchorIsImmutableTip :: AnchoredFragment b -> Bool
anchorIsImmutableTip AnchoredFragment b
branch = ChainHash b -> [Word64]
forall block.
(HeaderHash block ~ TestHash) =>
ChainHash block -> [Word64]
simpleHash (Anchor b -> ChainHash b
forall block. Anchor block -> ChainHash block
AF.anchorToHash (AnchoredFragment b -> Anchor b
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment b
branch)) [Word64] -> [Word64] -> Bool
forall a. Eq a => a -> a -> Bool
== [Word64]
immutableTipHash

        isHonest :: [Word64] -> Bool
isHonest = (Word64 -> Bool) -> [Word64] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Word64
0 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
==)

        immutableTipHash :: [Word64]
immutableTipHash = ChainHash (Header blk) -> [Word64]
forall block.
(HeaderHash block ~ TestHash) =>
ChainHash block -> [Word64]
simpleHash (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

        selectionTip :: [Word64]
selectionTip = ChainHash (Header blk) -> [Word64]
forall block.
(HeaderHash block ~ TestHash) =>
ChainHash block -> [Word64]
simpleHash (AnchoredFragment (Header blk) -> ChainHash (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> ChainHash block
AF.headHash AnchoredFragment (Header blk)
svSelectedChain)

        allTips :: [[Word64]]
allTips = ChainHash b -> [Word64]
forall block.
(HeaderHash block ~ TestHash) =>
ChainHash block -> [Word64]
simpleHash (ChainHash b -> [Word64])
-> (AnchoredFragment b -> ChainHash b)
-> AnchoredFragment b
-> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment b -> ChainHash b
forall block.
HasHeader block =>
AnchoredFragment block -> ChainHash block
AF.headHash (AnchoredFragment b -> [Word64])
-> [AnchoredFragment b] -> [[Word64]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AnchoredFragment b
btTrunk AnchoredFragment b -> [AnchoredFragment b] -> [AnchoredFragment b]
forall a. a -> [a] -> [a]
: [AnchoredFragment b]
suffixes)

        suffixes :: [AnchoredFragment b]
suffixes = BlockTreeBranch b -> AnchoredFragment b
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix (BlockTreeBranch b -> AnchoredFragment b)
-> [BlockTreeBranch b] -> [AnchoredFragment b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockTreeBranch b]
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.
prop_downtime :: Property
prop_downtime :: Property
prop_downtime = Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> Property)
-> Property
forall prop.
Testable prop =>
Gen (GenesisTestFull TestBlock)
-> SchedulerConfig
-> (GenesisTestFull TestBlock
    -> StateView TestBlock -> [GenesisTestFull TestBlock])
-> (GenesisTestFull TestBlock -> StateView TestBlock -> prop)
-> Property
forAllGenesisTest

    (Gen Word -> Gen (GenesisTest TestBlock ())
genChains ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
QC.choose (Word
1, Word
4)) Gen (GenesisTest TestBlock ())
-> (GenesisTest TestBlock () -> Gen (PointSchedule TestBlock))
-> Gen (GenesisTestFull TestBlock)
forall (f :: * -> *) (m :: * -> *) a b.
(Functor f, Monad m) =>
m (f a) -> (f a -> m b) -> m (f b)
`enrichedWith` \ GenesisTest TestBlock ()
gt ->
      GenesisTest TestBlock ()
-> PointSchedule TestBlock -> PointSchedule TestBlock
forall blk a.
GenesisTest blk a -> PointSchedule blk -> PointSchedule blk
ensureScheduleDuration GenesisTest TestBlock ()
gt (PointSchedule TestBlock -> PointSchedule TestBlock)
-> Gen (PointSchedule TestBlock) -> Gen (PointSchedule TestBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s. STGenM QCGen s -> ST s (PointSchedule TestBlock))
-> Gen (PointSchedule TestBlock)
forall a. (forall s. STGenM QCGen s -> ST s a) -> Gen a
stToGen (PointsGeneratorParams
-> BlockTree TestBlock
-> STGenM QCGen s
-> ST s (PointSchedule TestBlock)
forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
PointsGeneratorParams
-> BlockTree blk -> g -> m (PointSchedule blk)
uniformPoints (GenesisTest TestBlock () -> PointsGeneratorParams
forall {blk} {schedule}.
GenesisTest blk schedule -> PointsGeneratorParams
pointsGeneratorParams GenesisTest TestBlock ()
gt) (GenesisTest TestBlock () -> BlockTree TestBlock
forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree GenesisTest TestBlock ()
gt)))

    SchedulerConfig
defaultSchedulerConfig
      { scEnableLoE = True
      , scEnableLoP = True
      , scDowntime = Just 11
      , scEnableCSJ = True
      }

    GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinkPeerSchedules

    GenesisTestFull TestBlock -> StateView TestBlock -> Property
theProperty

  where
    pointsGeneratorParams :: GenesisTest blk schedule -> PointsGeneratorParams
pointsGeneratorParams GenesisTest blk schedule
gt = PointsGeneratorParams
      { $sel:pgpExtraHonestPeers:PointsGeneratorParams :: 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)
      , $sel:pgpDowntime:PointsGeneratorParams :: DowntimeParams
pgpDowntime = SecurityParam -> DowntimeParams
DowntimeWithSecurityParam (GenesisTest blk schedule -> SecurityParam
forall blk schedule. GenesisTest blk schedule -> SecurityParam
gtSecurityParam GenesisTest blk schedule
gt)
      }