{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Consensus.Genesis.Setup.GenChains (
GenesisTest (..)
, genChains
, genChainsWithExtraHonestPeers
) where
import Cardano.Ledger.BaseTypes (nonZeroOr)
import Cardano.Slotting.Time (slotLengthFromSec)
import Control.Monad (replicateM)
import qualified Control.Monad.Except as Exn
import Data.List as List (foldl')
import Data.Proxy (Proxy (..))
import Data.Time.Clock (DiffTime)
import qualified Data.Vector.Unboxed as Vector
import Data.Word (Word8)
import Ouroboros.Consensus.Block.Abstract hiding (Header)
import Ouroboros.Consensus.Protocol.Abstract
(SecurityParam (SecurityParam))
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Protocol.ChainSync.Codec
(ChainSyncTimeout (..))
import Ouroboros.Network.Protocol.Limits (shortWait)
import qualified Test.Consensus.BlockTree as BT
import Test.Consensus.PointSchedule
import qualified Test.Ouroboros.Consensus.ChainGenerator.Adversarial as A
import Test.Ouroboros.Consensus.ChainGenerator.Adversarial
(genPrefixBlockCount)
import Test.Ouroboros.Consensus.ChainGenerator.Counting
(Count (Count), getVector)
import qualified Test.Ouroboros.Consensus.ChainGenerator.Honest as H
import Test.Ouroboros.Consensus.ChainGenerator.Honest
(ChainSchema (ChainSchema), HonestRecipe (..))
import Test.Ouroboros.Consensus.ChainGenerator.Params
import qualified Test.Ouroboros.Consensus.ChainGenerator.Slot as S
import Test.Ouroboros.Consensus.ChainGenerator.Slot (S)
import qualified Test.QuickCheck as QC
import Test.QuickCheck.Extras (unsafeMapSuchThatJust)
import Test.QuickCheck.Random (QCGen)
import Test.Util.Orphans.IOLike ()
import Test.Util.TestBlock hiding (blockTree)
genHonestChainSchema :: QC.Gen (Asc, H.HonestRecipe, H.SomeHonestChainSchema)
genHonestChainSchema :: Gen (Asc, HonestRecipe, SomeHonestChainSchema)
genHonestChainSchema = do
asc <- Gen Asc
genAsc
honestRecipe <- H.genHonestRecipe
H.SomeCheckedHonestRecipe Proxy Proxy honestRecipe' <-
case Exn.runExcept $ H.checkHonestRecipe honestRecipe of
Left NoSuchHonestChainSchema
exn -> [Char] -> Gen SomeCheckedHonestRecipe
forall a. HasCallStack => [Char] -> a
error ([Char] -> Gen SomeCheckedHonestRecipe)
-> [Char] -> Gen SomeCheckedHonestRecipe
forall a b. (a -> b) -> a -> b
$ [Char]
"impossible! " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (HonestRecipe, NoSuchHonestChainSchema) -> [Char]
forall a. Show a => a -> [Char]
show (HonestRecipe
honestRecipe, NoSuchHonestChainSchema
exn)
Right SomeCheckedHonestRecipe
honestRecipe' -> SomeCheckedHonestRecipe -> Gen SomeCheckedHonestRecipe
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeCheckedHonestRecipe
honestRecipe'
(seed :: QCGen) <- QC.arbitrary
let schema = Maybe Asc
-> CheckedHonestRecipe base hon -> QCGen -> ChainSchema base hon
forall base hon g.
RandomGen g =>
Maybe Asc
-> CheckedHonestRecipe base hon -> g -> ChainSchema base hon
H.uniformTheHonestChain (Asc -> Maybe Asc
forall a. a -> Maybe a
Just Asc
asc) CheckedHonestRecipe base hon
honestRecipe' QCGen
seed
pure (asc, honestRecipe, H.SomeHonestChainSchema Proxy Proxy schema)
genAlternativeChainSchema :: (H.HonestRecipe, H.ChainSchema base hon) -> QC.Gen (Int, [S])
genAlternativeChainSchema :: forall base hon.
(HonestRecipe, ChainSchema base hon) -> Gen (Int, [S])
genAlternativeChainSchema (HonestRecipe
testRecipeH, ChainSchema base hon
arHonest) =
Gen (Maybe (Int, [S])) -> Gen (Int, [S])
forall a. Gen (Maybe a) -> Gen a
unsafeMapSuchThatJust (Gen (Maybe (Int, [S])) -> Gen (Int, [S]))
-> Gen (Maybe (Int, [S])) -> Gen (Int, [S])
forall a b. (a -> b) -> a -> b
$ do
let H.HonestRecipe Kcp
kcp Scg
scg Delta
delta Len
_len = HonestRecipe
testRecipeH
(seedPrefix :: QCGen) <- Gen QCGen
forall a. Arbitrary a => Gen a
QC.arbitrary
let arPrefix = HonestRecipe
-> QCGen -> ChainSchema base hon -> Var hon 'ActiveSlotE
forall g base hon.
RandomGen g =>
HonestRecipe -> g -> ChainSchema base hon -> Var hon 'ActiveSlotE
genPrefixBlockCount HonestRecipe
testRecipeH QCGen
seedPrefix ChainSchema base hon
arHonest
let testRecipeA = A.AdversarialRecipe {
Var hon 'ActiveSlotE
arPrefix :: Var hon 'ActiveSlotE
arPrefix :: Var hon 'ActiveSlotE
A.arPrefix,
arParams :: (Kcp, Scg, Delta)
A.arParams = (Kcp
kcp, Scg
scg, Delta
delta),
ChainSchema base hon
arHonest :: ChainSchema base hon
arHonest :: ChainSchema base hon
A.arHonest
}
alternativeAsc <- ascFromBits <$> QC.choose (1 :: Word8, maxBound - 1)
case Exn.runExcept $ A.checkAdversarialRecipe testRecipeA of
Left NoSuchAdversarialChainSchema
e -> case NoSuchAdversarialChainSchema
e of
NoSuchAdversarialChainSchema
A.NoSuchAdversarialBlock -> Maybe (Int, [S]) -> Gen (Maybe (Int, [S]))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Int, [S])
forall a. Maybe a
Nothing
NoSuchAdversarialChainSchema
A.NoSuchCompetitor -> [Char] -> Gen (Maybe (Int, [S]))
forall a. HasCallStack => [Char] -> a
error ([Char] -> Gen (Maybe (Int, [S])))
-> [Char] -> Gen (Maybe (Int, [S]))
forall a b. (a -> b) -> a -> b
$ [Char]
"impossible! " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> NoSuchAdversarialChainSchema -> [Char]
forall a. Show a => a -> [Char]
show NoSuchAdversarialChainSchema
e
NoSuchAdversarialChainSchema
A.NoSuchIntersection -> [Char] -> Gen (Maybe (Int, [S]))
forall a. HasCallStack => [Char] -> a
error ([Char] -> Gen (Maybe (Int, [S])))
-> [Char] -> Gen (Maybe (Int, [S]))
forall a b. (a -> b) -> a -> b
$ [Char]
"impossible! " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> NoSuchAdversarialChainSchema -> [Char]
forall a. Show a => a -> [Char]
show NoSuchAdversarialChainSchema
e
Right (A.SomeCheckedAdversarialRecipe Proxy adv
_ CheckedAdversarialRecipe base hon adv
testRecipeA'') -> do
let Count Int
prefixCount = Var hon 'ActiveSlotE
arPrefix
(seed :: QCGen) <- Gen QCGen
forall a. Arbitrary a => Gen a
QC.arbitrary
let H.ChainSchema _ v = A.uniformAdversarialChain (Just alternativeAsc) testRecipeA'' seed
pure $ Just (prefixCount, Vector.toList (getVector v))
genChains :: QC.Gen Word -> QC.Gen (GenesisTest TestBlock ())
genChains :: Gen Word -> Gen (GenesisTest TestBlock ())
genChains = Gen Word -> Gen Word -> Gen (GenesisTest TestBlock ())
genChainsWithExtraHonestPeers (Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
0)
genChainsWithExtraHonestPeers :: QC.Gen Word -> QC.Gen Word -> QC.Gen (GenesisTest TestBlock ())
Gen Word
genNumExtraHonest Gen Word
genNumForks = do
(_, honestRecipe, someHonestChainSchema) <- Gen (Asc, HonestRecipe, SomeHonestChainSchema)
genHonestChainSchema
H.SomeHonestChainSchema _ _ honestChainSchema <- pure someHonestChainSchema
let ChainSchema _ vH = honestChainSchema
goodChain = [TestBlock] -> AnchoredFragment TestBlock
mkTestFragment [TestBlock]
goodBlocks
goodBlocks = [TestBlock] -> [S] -> Int -> [TestBlock]
mkTestBlocks [] [S]
slotsH Int
0
slotsH = Vector S -> [S]
forall a. Unbox a => Vector a -> [a]
Vector.toList (Vector hon 'SlotE S -> Vector S
forall {k1} {k2} (base :: k1) (elem :: k2) a.
Vector base elem a -> Vector a
getVector Vector hon 'SlotE S
vH)
HonestRecipe (Kcp kcp) (Scg scg) delta _len = honestRecipe
numForks <- genNumForks
gtExtraHonestPeers <- genNumExtraHonest
alternativeChainSchemas <- replicateM (fromIntegral numForks) (genAlternativeChainSchema (honestRecipe, honestChainSchema))
pure $ GenesisTest {
gtSecurityParam =
SecurityParam $
nonZeroOr (fromIntegral kcp) $ error "Generated Kcp was zero. Cannot construct a NonZero value for the SecurityParam.",
gtGenesisWindow = GenesisWindow (fromIntegral scg),
gtForecastRange = ForecastRange (fromIntegral scg),
gtDelay = delta,
gtSlotLength = slotLengthFromSec 20,
gtChainSyncTimeouts = chainSyncTimeouts,
gtBlockFetchTimeouts = blockFetchTimeouts,
gtLoPBucketParams = LoPBucketParams { lbpCapacity = 50, lbpRate = 10 },
gtCSJParams = CSJParams $ fromIntegral scg,
gtBlockTree = List.foldl' (flip BT.addBranch') (BT.mkTrunk goodChain) $ zipWith (genAdversarialFragment goodBlocks) [1..] alternativeChainSchemas,
gtExtraHonestPeers,
gtSchedule = ()
}
where
genAdversarialFragment :: [TestBlock] -> Int -> (Int, [S]) -> AnchoredFragment TestBlock
genAdversarialFragment :: [TestBlock] -> Int -> (Int, [S]) -> AnchoredFragment TestBlock
genAdversarialFragment [TestBlock]
goodBlocks Int
forkNo (Int
prefixCount, [S]
slotsA)
= [TestBlock] -> AnchoredFragment TestBlock
mkTestFragment ([TestBlock] -> [S] -> Int -> [TestBlock]
mkTestBlocks [TestBlock]
prefix [S]
slotsA Int
forkNo)
where
prefix :: [TestBlock]
prefix = Int -> [TestBlock] -> [TestBlock]
forall a. Int -> [a] -> [a]
drop ([TestBlock] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestBlock]
goodBlocks Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
prefixCount) [TestBlock]
goodBlocks
mkTestFragment :: [TestBlock] -> AnchoredFragment TestBlock
mkTestFragment :: [TestBlock] -> AnchoredFragment TestBlock
mkTestFragment =
Anchor TestBlock -> [TestBlock] -> AnchoredFragment TestBlock
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AF.fromNewestFirst Anchor TestBlock
forall block. Anchor block
AF.AnchorGenesis
mkTestBlocks :: [TestBlock] -> [S] -> Int -> [TestBlock]
mkTestBlocks :: [TestBlock] -> [S] -> Int -> [TestBlock]
mkTestBlocks [TestBlock]
pre [S]
active Int
forkNo =
([TestBlock], SlotNo) -> [TestBlock]
forall a b. (a, b) -> a
fst ((([TestBlock], SlotNo) -> S -> ([TestBlock], SlotNo))
-> ([TestBlock], SlotNo) -> [S] -> ([TestBlock], SlotNo)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ([TestBlock], SlotNo) -> S -> ([TestBlock], SlotNo)
folder ([], SlotNo
0) [S]
active)
where
folder :: ([TestBlock], SlotNo) -> S -> ([TestBlock], SlotNo)
folder ([TestBlock]
chain, SlotNo
inc) S
s | Proxy 'NotInverted -> S -> Bool
forall (pol :: Pol) (proxy :: Pol -> *).
POL pol =>
proxy pol -> S -> Bool
forall (proxy :: Pol -> *). proxy 'NotInverted -> S -> Bool
S.test Proxy 'NotInverted
S.notInverted S
s = (SlotNo -> [TestBlock] -> [TestBlock]
issue SlotNo
inc [TestBlock]
chain, SlotNo
0)
| Bool
otherwise = ([TestBlock]
chain, SlotNo
inc SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1)
issue :: SlotNo -> [TestBlock] -> [TestBlock]
issue SlotNo
inc (TestBlock
h : [TestBlock]
t) = SlotNo -> TestBlock -> TestBlock
incSlot SlotNo
inc (TestBlock -> TestBlock
successorBlock TestBlock
h) TestBlock -> [TestBlock] -> [TestBlock]
forall a. a -> [a] -> [a]
: TestBlock
h TestBlock -> [TestBlock] -> [TestBlock]
forall a. a -> [a] -> [a]
: [TestBlock]
t
issue SlotNo
inc [] | [] <- [TestBlock]
pre = [SlotNo -> TestBlock -> TestBlock
incSlot SlotNo
inc ((Word64 -> TestBlock
firstBlock (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
forkNo)) {tbSlot = 0})]
| TestBlock
h : [TestBlock]
t <- [TestBlock]
pre = SlotNo -> TestBlock -> TestBlock
incSlot SlotNo
inc ((Word64 -> Word64) -> TestBlock -> TestBlock
modifyFork (Word64 -> Word64 -> Word64
forall a b. a -> b -> a
const (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
forkNo)) (TestBlock -> TestBlock
successorBlock TestBlock
h)) TestBlock -> [TestBlock] -> [TestBlock]
forall a. a -> [a] -> [a]
: TestBlock
h TestBlock -> [TestBlock] -> [TestBlock]
forall a. a -> [a] -> [a]
: [TestBlock]
t
incSlot :: SlotNo -> TestBlock -> TestBlock
incSlot :: SlotNo -> TestBlock -> TestBlock
incSlot SlotNo
n TestBlock
b = TestBlock
b { tbSlot = tbSlot b + n }
chainSyncTimeouts :: ChainSyncTimeout
chainSyncTimeouts :: ChainSyncTimeout
chainSyncTimeouts =
ChainSyncTimeout
{ Maybe DiffTime
canAwaitTimeout :: Maybe DiffTime
canAwaitTimeout :: Maybe DiffTime
canAwaitTimeout,
Maybe DiffTime
intersectTimeout :: Maybe DiffTime
intersectTimeout :: Maybe DiffTime
intersectTimeout,
Maybe DiffTime
mustReplyTimeout :: Maybe DiffTime
mustReplyTimeout :: Maybe DiffTime
mustReplyTimeout,
Maybe DiffTime
idleTimeout :: Maybe DiffTime
idleTimeout :: Maybe DiffTime
idleTimeout
}
where
canAwaitTimeout :: Maybe DiffTime
canAwaitTimeout :: Maybe DiffTime
canAwaitTimeout = Maybe DiffTime
shortWait
intersectTimeout :: Maybe DiffTime
intersectTimeout :: Maybe DiffTime
intersectTimeout = Maybe DiffTime
shortWait
idleTimeout :: Maybe DiffTime
idleTimeout :: Maybe DiffTime
idleTimeout = Maybe DiffTime
forall a. Maybe a
Nothing
mustReplyTimeout :: Maybe DiffTime
mustReplyTimeout :: Maybe DiffTime
mustReplyTimeout = Maybe DiffTime
forall a. Maybe a
Nothing
blockFetchTimeouts :: BlockFetchTimeout
blockFetchTimeouts :: BlockFetchTimeout
blockFetchTimeouts =
BlockFetchTimeout
{ busyTimeout :: Maybe DiffTime
busyTimeout = DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just DiffTime
60,
streamingTimeout :: Maybe DiffTime
streamingTimeout = DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just DiffTime
60
}