{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
module Test.ThreadNet.Shelley (tests) where
import Cardano.Crypto.Hash (ShortHash)
import qualified Cardano.Ledger.BaseTypes as SL (UnitInterval,
mkNonceFromNumber, shelleyProtVer, unboundRational)
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Ledger.Shelley.Core as SL
import qualified Cardano.Ledger.Shelley.Translation as SL
(toFromByronTranslationContext)
import qualified Cardano.Protocol.TPraos.OCert as SL
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
import Control.Monad (replicateM)
import qualified Data.Map.Strict as Map
import Data.Word (Word64)
import Lens.Micro ((^.))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config.SecurityParam
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool (extractTxs)
import Ouroboros.Consensus.Node.NetworkProtocolVersion
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.NodeId
import Ouroboros.Consensus.Protocol.TPraos (TPraos)
import Ouroboros.Consensus.Shelley.Eras (EraCrypto)
import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock)
import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley
import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
import Ouroboros.Consensus.Shelley.Node
import Test.Consensus.Shelley.MockCrypto (MockCrypto, MockShelley)
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.ThreadNet.General
import Test.ThreadNet.Infra.Shelley
import Test.ThreadNet.Network (TestNodeInitialization (..),
nodeOutputFinalLedger)
import Test.ThreadNet.TxGen.Shelley
import Test.ThreadNet.Util.NodeJoinPlan (trivialNodeJoinPlan)
import Test.ThreadNet.Util.NodeRestarts (noRestarts)
import Test.ThreadNet.Util.NodeToNodeVersion (genVersion)
import Test.ThreadNet.Util.Seed (runGen)
import Test.Util.HardFork.Future (singleEraFuture)
import Test.Util.Orphans.Arbitrary ()
import Test.Util.Slots (NumSlots (..))
import Test.Util.TestEnv
type Era = MockShelley ShortHash
type Proto = TPraos (MockCrypto ShortHash)
data TestSetup = TestSetup
{ TestSetup -> DecentralizationParam
setupD :: DecentralizationParam
, TestSetup -> DecentralizationParam
setupD2 :: DecentralizationParam
, TestSetup -> Nonce
setupInitialNonce :: SL.Nonce
, TestSetup -> SecurityParam
setupK :: SecurityParam
, TestSetup -> TestConfig
setupTestConfig :: TestConfig
, TestSetup
-> (NodeToNodeVersion,
BlockNodeToNodeVersion (ShelleyBlock Proto Era))
setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion (ShelleyBlock Proto Era))
}
deriving (Int -> TestSetup -> ShowS
[TestSetup] -> ShowS
TestSetup -> String
(Int -> TestSetup -> ShowS)
-> (TestSetup -> String)
-> ([TestSetup] -> ShowS)
-> Show TestSetup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestSetup -> ShowS
showsPrec :: Int -> TestSetup -> ShowS
$cshow :: TestSetup -> String
show :: TestSetup -> String
$cshowList :: [TestSetup] -> ShowS
showList :: [TestSetup] -> ShowS
Show)
minK :: Word64
minK :: Word64
minK = Word64
5
maxK :: Word64
maxK :: Word64
maxK = Word64
10
activeSlotCoeff :: Rational
activeSlotCoeff :: Rational
activeSlotCoeff = Rational
0.5
instance Arbitrary TestSetup where
arbitrary :: Gen TestSetup
arbitrary = do
DecentralizationParam
setupD <- Gen DecentralizationParam
forall a. Arbitrary a => Gen a
arbitrary
DecentralizationParam
setupD2 <- Gen DecentralizationParam
forall a. Arbitrary a => Gen a
arbitrary
Nonce
setupInitialNonce <- [(Int, Gen Nonce)] -> Gen Nonce
forall a. [(Int, Gen a)] -> Gen a
frequency
[ (Int
1, Nonce -> Gen Nonce
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nonce
SL.NeutralNonce)
, (Int
9, Word64 -> Nonce
SL.mkNonceFromNumber (Word64 -> Nonce) -> Gen Word64 -> Gen Nonce
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
forall a. Arbitrary a => Gen a
arbitrary)
]
SecurityParam
setupK <- Word64 -> SecurityParam
SecurityParam (Word64 -> SecurityParam) -> Gen Word64 -> Gen SecurityParam
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
minK, Word64
maxK)
TestConfig
setupTestConfig <- Gen TestConfig
forall a. Arbitrary a => Gen a
arbitrary
(NodeToNodeVersion, ShelleyNodeToNodeVersion)
setupVersion <- Proxy (ShelleyBlock Proto Era)
-> Gen
(NodeToNodeVersion,
BlockNodeToNodeVersion (ShelleyBlock Proto Era))
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> Gen (NodeToNodeVersion, BlockNodeToNodeVersion blk)
genVersion (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ShelleyBlock Proto Era))
TestSetup -> Gen TestSetup
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestSetup
{ DecentralizationParam
setupD :: DecentralizationParam
setupD :: DecentralizationParam
setupD
, DecentralizationParam
setupD2 :: DecentralizationParam
setupD2 :: DecentralizationParam
setupD2
, Nonce
setupInitialNonce :: Nonce
setupInitialNonce :: Nonce
setupInitialNonce
, SecurityParam
setupK :: SecurityParam
setupK :: SecurityParam
setupK
, TestConfig
setupTestConfig :: TestConfig
setupTestConfig :: TestConfig
setupTestConfig
, (NodeToNodeVersion,
BlockNodeToNodeVersion (ShelleyBlock Proto Era))
(NodeToNodeVersion, ShelleyNodeToNodeVersion)
setupVersion :: (NodeToNodeVersion,
BlockNodeToNodeVersion (ShelleyBlock Proto Era))
setupVersion :: (NodeToNodeVersion, ShelleyNodeToNodeVersion)
setupVersion
}
newtype NightlyTestSetup = NightlyTestSetup TestSetup
deriving (Int -> NightlyTestSetup -> ShowS
[NightlyTestSetup] -> ShowS
NightlyTestSetup -> String
(Int -> NightlyTestSetup -> ShowS)
-> (NightlyTestSetup -> String)
-> ([NightlyTestSetup] -> ShowS)
-> Show NightlyTestSetup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NightlyTestSetup -> ShowS
showsPrec :: Int -> NightlyTestSetup -> ShowS
$cshow :: NightlyTestSetup -> String
show :: NightlyTestSetup -> String
$cshowList :: [NightlyTestSetup] -> ShowS
showList :: [NightlyTestSetup] -> ShowS
Show)
instance Arbitrary NightlyTestSetup where
shrink :: NightlyTestSetup -> [NightlyTestSetup]
shrink (NightlyTestSetup TestSetup
setup) = TestSetup -> NightlyTestSetup
NightlyTestSetup (TestSetup -> NightlyTestSetup)
-> [TestSetup] -> [NightlyTestSetup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestSetup -> [TestSetup]
forall a. Arbitrary a => a -> [a]
shrink TestSetup
setup
arbitrary :: Gen NightlyTestSetup
arbitrary = do
TestSetup
setup <- Gen TestSetup
forall a. Arbitrary a => Gen a
arbitrary
Bool
moreEpochs <- [(Int, Gen Bool)] -> Gen Bool
forall a. [(Int, Gen a)] -> Gen a
frequency [(Int
3, Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False), (Int
1, Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)]
TestSetup -> NightlyTestSetup
NightlyTestSetup (TestSetup -> NightlyTestSetup)
-> Gen TestSetup -> Gen NightlyTestSetup
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Bool -> Bool
not Bool
moreEpochs then TestSetup -> Gen TestSetup
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestSetup
setup else do
let TestSetup
{ SecurityParam
setupK :: TestSetup -> SecurityParam
setupK :: SecurityParam
setupK
, TestConfig
setupTestConfig :: TestSetup -> TestConfig
setupTestConfig :: TestConfig
setupTestConfig
} = TestSetup
setup
TestConfig
{ NumSlots
numSlots :: NumSlots
numSlots :: TestConfig -> NumSlots
numSlots
} = TestConfig
setupTestConfig
NumSlots Word64
t = NumSlots
numSlots
Word64
factor <- (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
2)
let t' :: Word64
t' = Word64
t Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
factor Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* EpochSize -> Word64
unEpochSize (SecurityParam -> Rational -> EpochSize
mkEpochSize SecurityParam
setupK Rational
activeSlotCoeff)
TestSetup -> Gen TestSetup
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestSetup
setup
{ setupTestConfig = setupTestConfig
{ numSlots = NumSlots t'
}
}
tests :: TestTree
tests :: TestTree
tests = String -> [TestTree] -> TestTree
testGroup String
"Shelley ThreadNet"
[ let name :: String
name = String
"simple convergence" in
(TestEnv -> TestTree) -> TestTree
askTestEnv ((TestEnv -> TestTree) -> TestTree)
-> (TestEnv -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \case
TestEnv
Nightly -> String -> (NightlyTestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
name ((NightlyTestSetup -> Property) -> TestTree)
-> (NightlyTestSetup -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ \(NightlyTestSetup TestSetup
setup) ->
TestSetup -> Property
prop_simple_real_tpraos_convergence TestSetup
setup
TestEnv
_ -> (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ String -> (TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
name TestSetup -> Property
prop_simple_real_tpraos_convergence
]
prop_simple_real_tpraos_convergence :: TestSetup -> Property
prop_simple_real_tpraos_convergence :: TestSetup -> Property
prop_simple_real_tpraos_convergence TestSetup
{ DecentralizationParam
setupD :: TestSetup -> DecentralizationParam
setupD :: DecentralizationParam
setupD
, DecentralizationParam
setupD2 :: TestSetup -> DecentralizationParam
setupD2 :: DecentralizationParam
setupD2
, Nonce
setupInitialNonce :: TestSetup -> Nonce
setupInitialNonce :: Nonce
setupInitialNonce
, SecurityParam
setupK :: TestSetup -> SecurityParam
setupK :: SecurityParam
setupK
, TestConfig
setupTestConfig :: TestSetup -> TestConfig
setupTestConfig :: TestConfig
setupTestConfig
, (NodeToNodeVersion,
BlockNodeToNodeVersion (ShelleyBlock Proto Era))
setupVersion :: TestSetup
-> (NodeToNodeVersion,
BlockNodeToNodeVersion (ShelleyBlock Proto Era))
setupVersion :: (NodeToNodeVersion,
BlockNodeToNodeVersion (ShelleyBlock Proto Era))
setupVersion
} =
String -> String -> Property -> Property
countertabulate String
"Epoch number of last slot"
( Word64 -> String
forall a. Show a => a -> String
show (Word64 -> String) -> Word64 -> String
forall a b. (a -> b) -> a -> b
$
if Word64
0 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= NumSlots -> Word64
unNumSlots NumSlots
numSlots then Word64
0 else
(NumSlots -> Word64
unNumSlots NumSlots
numSlots Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` EpochSize -> Word64
unEpochSize EpochSize
epochSize
) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
String -> String -> Property -> Property
countertabulate String
"Updating d"
( if Bool -> Bool
not Bool
dShouldUpdate then String
"No" else
String
"Yes, " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Ordering -> String
forall a. Show a => a -> String
show (DecentralizationParam -> DecentralizationParam -> Ordering
forall a. Ord a => a -> a -> Ordering
compare DecentralizationParam
setupD DecentralizationParam
setupD2)
) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (SecurityParam -> String
forall a. Show a => a -> String
show SecurityParam
setupK) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
PropGeneralArgs (ShelleyBlock Proto Era)
-> TestOutput (ShelleyBlock Proto Era) -> Property
forall blk.
(Condense blk, Condense (HeaderHash blk), Eq blk, RunNode blk) =>
PropGeneralArgs blk -> TestOutput blk -> Property
prop_general PropGeneralArgs
{ pgaBlockProperty :: ShelleyBlock Proto Era -> Property
pgaBlockProperty = Property -> ShelleyBlock Proto Era -> Property
forall a b. a -> b -> a
const (Property -> ShelleyBlock Proto Era -> Property)
-> Property -> ShelleyBlock Proto Era -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
, pgaCountTxs :: ShelleyBlock Proto Era -> Word64
pgaCountTxs = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64)
-> (ShelleyBlock Proto Era -> Int)
-> ShelleyBlock Proto Era
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenTx (ShelleyBlock Proto Era)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([GenTx (ShelleyBlock Proto Era)] -> Int)
-> (ShelleyBlock Proto Era -> [GenTx (ShelleyBlock Proto Era)])
-> ShelleyBlock Proto Era
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBlock Proto Era -> [GenTx (ShelleyBlock Proto Era)]
forall blk. HasTxs blk => blk -> [GenTx blk]
extractTxs
, pgaExpectedCannotForge :: SlotNo
-> NodeId -> WrapCannotForge (ShelleyBlock Proto Era) -> Bool
pgaExpectedCannotForge = SlotNo
-> NodeId -> WrapCannotForge (ShelleyBlock Proto Era) -> Bool
forall blk. SlotNo -> NodeId -> WrapCannotForge blk -> Bool
noExpectedCannotForges
, pgaFirstBlockNo :: BlockNo
pgaFirstBlockNo = BlockNo
0
, pgaFixedMaxForkLength :: Maybe NumBlocks
pgaFixedMaxForkLength = Maybe NumBlocks
forall a. Maybe a
Nothing
, pgaFixedSchedule :: Maybe LeaderSchedule
pgaFixedSchedule = Maybe LeaderSchedule
forall a. Maybe a
Nothing
, pgaSecurityParam :: SecurityParam
pgaSecurityParam = SecurityParam
setupK
, pgaTestConfig :: TestConfig
pgaTestConfig = TestConfig
setupTestConfig
, pgaTestConfigB :: TestConfigB (ShelleyBlock Proto Era)
pgaTestConfigB = TestConfigB (ShelleyBlock Proto Era)
testConfigB
}
TestOutput (ShelleyBlock Proto Era)
testOutput Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
Property
prop_checkFinalD
where
countertabulate :: String -> String -> Property -> Property
countertabulate :: String -> String -> Property -> Property
countertabulate String
lbl String
s =
String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
lbl [String
s] (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
lbl String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s)
TestConfig
{ Seed
initSeed :: Seed
initSeed :: TestConfig -> Seed
initSeed
, NumCoreNodes
numCoreNodes :: NumCoreNodes
numCoreNodes :: TestConfig -> NumCoreNodes
numCoreNodes
, NumSlots
numSlots :: TestConfig -> NumSlots
numSlots :: NumSlots
numSlots
} = TestConfig
setupTestConfig
testConfigB :: TestConfigB (ShelleyBlock Proto Era)
testConfigB :: TestConfigB (ShelleyBlock Proto Era)
testConfigB = TestConfigB
{ forgeEbbEnv :: Maybe (ForgeEbbEnv (ShelleyBlock Proto Era))
forgeEbbEnv = Maybe (ForgeEbbEnv (ShelleyBlock Proto Era))
forall a. Maybe a
Nothing
, future :: Future
future = SlotLength -> EpochSize -> Future
singleEraFuture SlotLength
tpraosSlotLength EpochSize
epochSize
, messageDelay :: CalcMessageDelay (ShelleyBlock Proto Era)
messageDelay = CalcMessageDelay (ShelleyBlock Proto Era)
forall blk. CalcMessageDelay blk
noCalcMessageDelay
, nodeJoinPlan :: NodeJoinPlan
nodeJoinPlan = NumCoreNodes -> NodeJoinPlan
trivialNodeJoinPlan NumCoreNodes
numCoreNodes
, nodeRestarts :: NodeRestarts
nodeRestarts = NodeRestarts
noRestarts
, txGenExtra :: TxGenExtra (ShelleyBlock Proto Era)
txGenExtra = ShelleyTxGenExtra
{ stgeGenEnv :: GenEnv Era
stgeGenEnv = WhetherToGeneratePPUs
-> [CoreNode (MockCrypto ShortHash)] -> GenEnv Era
forall h.
HashAlgorithm h =>
WhetherToGeneratePPUs
-> [CoreNode (MockCrypto h)] -> GenEnv (MockShelley h)
mkGenEnv WhetherToGeneratePPUs
inclPPUs [CoreNode (EraCrypto Era)]
[CoreNode (MockCrypto ShortHash)]
coreNodes
, stgeStartAt :: SlotNo
stgeStartAt =
Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ if Bool
includingDUpdateTx then Word64
1 else Word64
0
}
, version :: (NodeToNodeVersion,
BlockNodeToNodeVersion (ShelleyBlock Proto Era))
version = (NodeToNodeVersion,
BlockNodeToNodeVersion (ShelleyBlock Proto Era))
setupVersion
}
inclPPUs :: WhetherToGeneratePPUs
inclPPUs :: WhetherToGeneratePPUs
inclPPUs =
if Bool
includingDUpdateTx then WhetherToGeneratePPUs
DoNotGeneratePPUs else WhetherToGeneratePPUs
DoGeneratePPUs
sentinel :: SlotNo
sentinel :: SlotNo
sentinel = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ NumSlots -> Word64
unNumSlots NumSlots
numSlots
includingDUpdateTx :: Bool
includingDUpdateTx :: Bool
includingDUpdateTx = DecentralizationParam
setupD DecentralizationParam -> DecentralizationParam -> Bool
forall a. Eq a => a -> a -> Bool
/= DecentralizationParam
setupD2
dUpdatedAsOf :: SlotNo
dUpdatedAsOf :: SlotNo
dUpdatedAsOf = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ EpochSize -> Word64
unEpochSize EpochSize
epochSize
dShouldUpdate :: Bool
dShouldUpdate :: Bool
dShouldUpdate = Bool
includingDUpdateTx Bool -> Bool -> Bool
&& SlotNo
sentinel SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
dUpdatedAsOf
testOutput :: TestOutput (ShelleyBlock Proto Era)
testOutput =
TestConfig
-> TestConfigB (ShelleyBlock Proto Era)
-> (forall (m :: * -> *).
IOLike m =>
TestConfigMB m (ShelleyBlock Proto Era))
-> TestOutput (ShelleyBlock Proto Era)
forall blk.
(RunNode blk, TxGen blk, TracingConstraints blk, HasCallStack) =>
TestConfig
-> TestConfigB blk
-> (forall (m :: * -> *). IOLike m => TestConfigMB m blk)
-> TestOutput blk
runTestNetwork TestConfig
setupTestConfig TestConfigB (ShelleyBlock Proto Era)
testConfigB TestConfigMB
{ nodeInfo :: CoreNodeId -> TestNodeInitialization m (ShelleyBlock Proto Era)
nodeInfo = \(CoreNodeId Word64
nid) ->
let (ProtocolInfo (ShelleyBlock Proto Era)
protocolInfo, m [BlockForging m (ShelleyBlock Proto Era)]
blockForging) =
ShelleyGenesis (MockCrypto ShortHash)
-> Nonce
-> ProtVer
-> CoreNode (MockCrypto ShortHash)
-> (ProtocolInfo (ShelleyBlock Proto Era),
m [BlockForging m (ShelleyBlock Proto Era)])
forall (m :: * -> *) c.
(IOLike m, PraosCrypto c,
ShelleyCompatible (TPraos c) (ShelleyEra c)) =>
ShelleyGenesis c
-> Nonce
-> ProtVer
-> CoreNode c
-> (ProtocolInfo (ShelleyBlock (TPraos c) (ShelleyEra c)),
m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))])
mkProtocolShelley
ShelleyGenesis (EraCrypto Era)
ShelleyGenesis (MockCrypto ShortHash)
genesisConfig
Nonce
setupInitialNonce
ProtVer
nextProtVer
([CoreNode (EraCrypto Era)]
[CoreNode (MockCrypto ShortHash)]
coreNodes [CoreNode (MockCrypto ShortHash)]
-> Int -> CoreNode (MockCrypto ShortHash)
forall a. HasCallStack => [a] -> Int -> a
!! Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
nid)
in TestNodeInitialization
{ tniProtocolInfo :: ProtocolInfo (ShelleyBlock Proto Era)
tniProtocolInfo = ProtocolInfo (ShelleyBlock Proto Era)
protocolInfo
, tniCrucialTxs :: [GenTx (ShelleyBlock Proto Era)]
tniCrucialTxs =
if Bool -> Bool
not Bool
includingDUpdateTx then [] else
[CoreNode (MockCrypto ShortHash)]
-> ProtVer
-> SlotNo
-> DecentralizationParam
-> [GenTx (ShelleyBlock Proto Era)]
forall c.
ShelleyBasedEra (ShelleyEra c) =>
[CoreNode c]
-> ProtVer
-> SlotNo
-> DecentralizationParam
-> [GenTx (ShelleyBlock (TPraos c) (ShelleyEra c))]
mkSetDecentralizationParamTxs
[CoreNode (EraCrypto Era)]
[CoreNode (MockCrypto ShortHash)]
coreNodes
ProtVer
nextProtVer
SlotNo
sentinel
DecentralizationParam
setupD2
, tniBlockForging :: m [BlockForging m (ShelleyBlock Proto Era)]
tniBlockForging = m [BlockForging m (ShelleyBlock Proto Era)]
blockForging
}
, mkRekeyM :: Maybe (m (RekeyM m (ShelleyBlock Proto Era)))
mkRekeyM = Maybe (m (RekeyM m (ShelleyBlock Proto Era)))
forall a. Maybe a
Nothing
}
initialKESPeriod :: SL.KESPeriod
initialKESPeriod :: KESPeriod
initialKESPeriod = Word -> KESPeriod
SL.KESPeriod Word
0
coreNodes :: [CoreNode (EraCrypto Era)]
coreNodes :: [CoreNode (EraCrypto Era)]
coreNodes = Seed
-> Gen [CoreNode (EraCrypto Era)] -> [CoreNode (EraCrypto Era)]
forall a. Seed -> Gen a -> a
runGen Seed
initSeed (Gen [CoreNode (EraCrypto Era)] -> [CoreNode (EraCrypto Era)])
-> Gen [CoreNode (EraCrypto Era)] -> [CoreNode (EraCrypto Era)]
forall a b. (a -> b) -> a -> b
$
Int
-> Gen (CoreNode (EraCrypto Era)) -> Gen [CoreNode (EraCrypto Era)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) (Gen (CoreNode (EraCrypto Era)) -> Gen [CoreNode (EraCrypto Era)])
-> Gen (CoreNode (EraCrypto Era)) -> Gen [CoreNode (EraCrypto Era)]
forall a b. (a -> b) -> a -> b
$
KESPeriod -> Gen (CoreNode (MockCrypto ShortHash))
forall c. PraosCrypto c => KESPeriod -> Gen (CoreNode c)
genCoreNode KESPeriod
initialKESPeriod
where
NumCoreNodes Word64
n = NumCoreNodes
numCoreNodes
maxLovelaceSupply :: Word64
maxLovelaceSupply :: Word64
maxLovelaceSupply =
Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([CoreNode (MockCrypto ShortHash)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreNode (EraCrypto Era)]
[CoreNode (MockCrypto ShortHash)]
coreNodes) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
initialLovelacePerCoreNode
genesisConfig :: ShelleyGenesis (EraCrypto Era)
genesisConfig :: ShelleyGenesis (EraCrypto Era)
genesisConfig =
ProtVer
-> SecurityParam
-> Rational
-> DecentralizationParam
-> Word64
-> SlotLength
-> KesConfig
-> [CoreNode (MockCrypto ShortHash)]
-> ShelleyGenesis (MockCrypto ShortHash)
forall c.
PraosCrypto c =>
ProtVer
-> SecurityParam
-> Rational
-> DecentralizationParam
-> Word64
-> SlotLength
-> KesConfig
-> [CoreNode c]
-> ShelleyGenesis c
mkGenesisConfig
ProtVer
genesisProtVer
SecurityParam
setupK
Rational
activeSlotCoeff
DecentralizationParam
setupD
Word64
maxLovelaceSupply
SlotLength
tpraosSlotLength
(Proxy (MockCrypto ShortHash) -> NumSlots -> KesConfig
forall (proxy :: * -> *) c.
Crypto c =>
proxy c -> NumSlots -> KesConfig
mkKesConfig (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(EraCrypto Era)) NumSlots
numSlots)
[CoreNode (EraCrypto Era)]
[CoreNode (MockCrypto ShortHash)]
coreNodes
epochSize :: EpochSize
epochSize :: EpochSize
epochSize = ShelleyGenesis (MockCrypto ShortHash) -> EpochSize
forall c. ShelleyGenesis c -> EpochSize
sgEpochLength ShelleyGenesis (EraCrypto Era)
ShelleyGenesis (MockCrypto ShortHash)
genesisConfig
genesisProtVer :: SL.ProtVer
genesisProtVer :: ProtVer
genesisProtVer = Version -> Natural -> ProtVer
SL.ProtVer Version
SL.shelleyProtVer Natural
0
nextProtVer :: SL.ProtVer
nextProtVer :: ProtVer
nextProtVer = ProtVer -> ProtVer
incrementMinorProtVer ProtVer
genesisProtVer
prop_checkFinalD :: Property
prop_checkFinalD :: Property
prop_checkFinalD =
[Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$
[ let ls :: NewEpochState Era
ls =
Ticked (LedgerState (ShelleyBlock Proto Era)) -> NewEpochState Era
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
Shelley.tickedShelleyLedgerState (Ticked (LedgerState (ShelleyBlock Proto Era))
-> NewEpochState Era)
-> Ticked (LedgerState (ShelleyBlock Proto Era))
-> NewEpochState Era
forall a b. (a -> b) -> a -> b
$
LedgerCfg (LedgerState (ShelleyBlock Proto Era))
-> SlotNo
-> LedgerState (ShelleyBlock Proto Era)
-> Ticked (LedgerState (ShelleyBlock Proto Era))
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick LedgerCfg (LedgerState (ShelleyBlock Proto Era))
ledgerConfig SlotNo
sentinel LedgerState (ShelleyBlock Proto Era)
lsUnticked
msg :: String
msg =
String
"The ticked final ledger state of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> NodeId -> String
forall a. Show a => a -> String
show NodeId
nid String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
String
" has an unexpected value for the d protocol parameter."
actual :: SL.UnitInterval
actual :: UnitInterval
actual = NewEpochState Era -> PParams Era
forall era. EraGov era => NewEpochState era -> PParams era
Shelley.getPParams NewEpochState Era
ls PParams Era
-> Getting UnitInterval (PParams Era) UnitInterval -> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams Era) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams Era) UnitInterval
SL.ppDG
expected :: DecentralizationParam
expected :: DecentralizationParam
expected = if Bool
dShouldUpdate then DecentralizationParam
setupD2 else DecentralizationParam
setupD
in
String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"unticked " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> LedgerState (ShelleyBlock Proto Era) -> String
forall a. Show a => a -> String
show LedgerState (ShelleyBlock Proto Era)
lsUnticked) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"ticked " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> NewEpochState Era -> String
forall a. Show a => a -> String
show NewEpochState Era
ls) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"(d,d2) = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (DecentralizationParam, DecentralizationParam) -> String
forall a. Show a => a -> String
show (DecentralizationParam
setupD, DecentralizationParam
setupD2)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
( String
"(dUpdatedAsOf, dShouldUpdate) = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
(SlotNo, Bool) -> String
forall a. Show a => a -> String
show (SlotNo
dUpdatedAsOf, Bool
dShouldUpdate)
) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
msg (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
Bool
dWasFreeToVary Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.||.
UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
SL.unboundRational UnitInterval
actual Rational -> Rational -> Property
forall a. (Eq a, Show a) => a -> a -> Property
===
DecentralizationParam -> Rational
decentralizationParamToRational DecentralizationParam
expected
| (NodeId
nid, LedgerState (ShelleyBlock Proto Era)
lsUnticked) <- [(NodeId, LedgerState (ShelleyBlock Proto Era))]
finalLedgers
]
where
dWasFreeToVary :: Bool
dWasFreeToVary :: Bool
dWasFreeToVary = case WhetherToGeneratePPUs
inclPPUs of
WhetherToGeneratePPUs
DoGeneratePPUs -> Bool
True
WhetherToGeneratePPUs
DoNotGeneratePPUs -> Bool
False
finalLedgers :: [(NodeId, LedgerState (ShelleyBlock Proto Era))]
finalLedgers :: [(NodeId, LedgerState (ShelleyBlock Proto Era))]
finalLedgers =
Map NodeId (LedgerState (ShelleyBlock Proto Era))
-> [(NodeId, LedgerState (ShelleyBlock Proto Era))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map NodeId (LedgerState (ShelleyBlock Proto Era))
-> [(NodeId, LedgerState (ShelleyBlock Proto Era))])
-> Map NodeId (LedgerState (ShelleyBlock Proto Era))
-> [(NodeId, LedgerState (ShelleyBlock Proto Era))]
forall a b. (a -> b) -> a -> b
$ NodeOutput (ShelleyBlock Proto Era)
-> LedgerState (ShelleyBlock Proto Era)
forall blk. NodeOutput blk -> LedgerState blk
nodeOutputFinalLedger (NodeOutput (ShelleyBlock Proto Era)
-> LedgerState (ShelleyBlock Proto Era))
-> Map NodeId (NodeOutput (ShelleyBlock Proto Era))
-> Map NodeId (LedgerState (ShelleyBlock Proto Era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestOutput (ShelleyBlock Proto Era)
-> Map NodeId (NodeOutput (ShelleyBlock Proto Era))
forall blk. TestOutput blk -> Map NodeId (NodeOutput blk)
testOutputNodes TestOutput (ShelleyBlock Proto Era)
testOutput
ledgerConfig :: LedgerConfig (ShelleyBlock Proto Era)
ledgerConfig :: LedgerCfg (LedgerState (ShelleyBlock Proto Era))
ledgerConfig = ShelleyGenesis (EraCrypto Era)
-> TranslationContext Era
-> EpochInfo (Except PastHorizonException)
-> MaxMajorProtVer
-> ShelleyLedgerConfig Era
forall era.
ShelleyGenesis (EraCrypto era)
-> TranslationContext era
-> EpochInfo (Except PastHorizonException)
-> MaxMajorProtVer
-> ShelleyLedgerConfig era
Shelley.mkShelleyLedgerConfig
ShelleyGenesis (EraCrypto Era)
genesisConfig
(ShelleyGenesis (MockCrypto ShortHash)
-> FromByronTranslationContext (MockCrypto ShortHash)
forall c. ShelleyGenesis c -> FromByronTranslationContext c
SL.toFromByronTranslationContext ShelleyGenesis (EraCrypto Era)
ShelleyGenesis (MockCrypto ShortHash)
genesisConfig)
(EpochSize -> SlotLength -> EpochInfo (Except PastHorizonException)
forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo EpochSize
epochSize SlotLength
tpraosSlotLength)
(Version -> MaxMajorProtVer
MaxMajorProtVer Version
forall a. Bounded a => a
maxBound)