diff --git a/cabal.project b/cabal.project index 47494ceaddd..a3b781c28b3 100644 --- a/cabal.project +++ b/cabal.project @@ -27,8 +27,8 @@ source-repository-package -- NOTE: If you would like to update the above, -- see CONTRIBUTING.md#to-update-the-referenced-agda-ledger-spec index-state: - , hackage.haskell.org 2025-06-11T21:55:55Z - , cardano-haskell-packages 2025-06-11T08:32:56Z + , hackage.haskell.org 2025-08-05T00:00:00Z + , cardano-haskell-packages 2025-08-14T14:31:31Z packages: -- == Byron era == @@ -96,3 +96,9 @@ if impl(ghc >=9.12) allow-newer: -- Unique: https://github.com/kapralVV/Unique/issues/11 , Unique:hashable +-- See https://github.com/IntersectMBO/cardano-haskell-packages/issues/1123 +allow-newer: + -- https://github.com/phadej/vec/issues/121 + ral:QuickCheck, + fin:QuickCheck, + bin:QuickCheck, diff --git a/eras/allegra/impl/cardano-ledger-allegra.cabal b/eras/allegra/impl/cardano-ledger-allegra.cabal index 71e1dbef4fd..39e4fb7476e 100644 --- a/eras/allegra/impl/cardano-ledger-allegra.cabal +++ b/eras/allegra/impl/cardano-ledger-allegra.cabal @@ -91,6 +91,7 @@ library testlib Test.Cardano.Ledger.Allegra.Binary.Cddl Test.Cardano.Ledger.Allegra.CDDL Test.Cardano.Ledger.Allegra.Era + Test.Cardano.Ledger.Allegra.Era.Spec Test.Cardano.Ledger.Allegra.Examples Test.Cardano.Ledger.Allegra.Imp Test.Cardano.Ledger.Allegra.Imp.UtxowSpec diff --git a/eras/allegra/impl/test/Main.hs b/eras/allegra/impl/test/Main.hs index a5517b10682..6ab76253821 100644 --- a/eras/allegra/impl/test/Main.hs +++ b/eras/allegra/impl/test/Main.hs @@ -5,6 +5,7 @@ module Main where import Cardano.Ledger.Allegra (AllegraEra) import qualified Test.Cardano.Ledger.Allegra.Binary.CddlSpec as CddlSpec import qualified Test.Cardano.Ledger.Allegra.BinarySpec as BinarySpec +import Test.Cardano.Ledger.Allegra.Era.Spec (allegraEraSpec) import qualified Test.Cardano.Ledger.Allegra.Imp as Imp import Test.Cardano.Ledger.Allegra.ImpTest () import Test.Cardano.Ledger.Common @@ -13,7 +14,8 @@ import Test.Cardano.Ledger.Shelley.JSON (roundTripJsonShelleyEraSpec) main :: IO () main = - ledgerTestMain $ + ledgerTestMain $ do + allegraEraSpec @AllegraEra describe "Allegra" $ do BinarySpec.spec CddlSpec.spec diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Era.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Era.hs index 42e436e7f4e..0255f39f3aa 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Era.hs +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Era.hs @@ -10,6 +10,7 @@ import Cardano.Ledger.Allegra import Cardano.Ledger.Allegra.Core import Cardano.Ledger.Allegra.Scripts import Cardano.Ledger.Plutus (emptyCostModels) +import Paths_cardano_ledger_allegra import Test.Cardano.Ledger.Allegra.Arbitrary () import Test.Cardano.Ledger.Allegra.TreeDiff () import Test.Cardano.Ledger.Shelley.Era @@ -25,6 +26,8 @@ class instance EraTest AllegraEra where zeroCostModels = emptyCostModels + getEraDataFileName = getDataFileName + mkTestAccountState = mkShelleyTestAccountState accountsFromAccountsMap = shelleyAccountsFromAccountsMap diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Era/Spec.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Era/Spec.hs new file mode 100644 index 00000000000..9f4c4aaab49 --- /dev/null +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Era/Spec.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Allegra.Era.Spec ( + allegraEraSpec, +) where + +import Test.Cardano.Ledger.Allegra.ImpTest +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Ledger.Shelley.Era.Spec (shelleyEraSpec) + +-- | This spec is applicable to all eras and will be executed for every era starting with Allegra. +allegraEraSpec :: forall era. ShelleyEraImp era => Spec +allegraEraSpec = do + shelleyEraSpec @era diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs index 1cb8f647b3a..79bc7ade6d6 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs @@ -37,6 +37,8 @@ import Test.Cardano.Ledger.Allegra.TreeDiff () import Test.Cardano.Ledger.Core.KeyPair (KeyPair) import Test.Cardano.Ledger.Shelley.ImpTest +instance EraImp AllegraEra + instance ShelleyEraImp AllegraEra where impSatisfyNativeScript = impAllegraSatisfyNativeScript @@ -55,7 +57,7 @@ impAllegraSatisfyNativeScript :: impAllegraSatisfyNativeScript providedVKeyHashes txBody script = do impState <- get let - keyPairs = impState ^. impKeyPairsG + keyPairs = impState ^. keyPairsL vi = txBody ^. vldtTxBodyL satisfyMOf m Empty | m <= 0 = Just mempty diff --git a/eras/alonzo/impl/cardano-ledger-alonzo.cabal b/eras/alonzo/impl/cardano-ledger-alonzo.cabal index 306b07575a6..3812df03f3b 100644 --- a/eras/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/eras/alonzo/impl/cardano-ledger-alonzo.cabal @@ -116,6 +116,7 @@ library testlib Test.Cardano.Ledger.Alonzo.Binary.TxWitsSpec Test.Cardano.Ledger.Alonzo.CDDL Test.Cardano.Ledger.Alonzo.Era + Test.Cardano.Ledger.Alonzo.Era.Spec Test.Cardano.Ledger.Alonzo.Examples Test.Cardano.Ledger.Alonzo.Imp Test.Cardano.Ledger.Alonzo.Imp.UtxoSpec diff --git a/eras/alonzo/impl/golden/json/alonzo-genesis.json b/eras/alonzo/impl/golden/json/alonzo-genesis.json new file mode 100644 index 00000000000..3bebc761279 --- /dev/null +++ b/eras/alonzo/impl/golden/json/alonzo-genesis.json @@ -0,0 +1,196 @@ +{ + "lovelacePerUTxOWord": 34482, + "executionPrices": { + "prSteps": + { + "numerator" : 721, + "denominator" : 10000000 + }, + "prMem": + { + "numerator" : 577, + "denominator" : 10000 + } + }, + "maxTxExUnits": { + "exUnitsMem": 10000000, + "exUnitsSteps": 10000000000 + }, + "maxBlockExUnits": { + "exUnitsMem": 50000000, + "exUnitsSteps": 40000000000 + }, + "maxValueSize": 5000, + "collateralPercentage": 150, + "maxCollateralInputs": 3, + "costModels": { + "PlutusV1": { + "addInteger-cpu-arguments-intercept": 100788, + "addInteger-cpu-arguments-slope": 420, + "addInteger-memory-arguments-intercept": 1, + "addInteger-memory-arguments-slope": 1, + "appendByteString-cpu-arguments-intercept": 1000, + "appendByteString-cpu-arguments-slope": 173, + "appendByteString-memory-arguments-intercept": 0, + "appendByteString-memory-arguments-slope": 1, + "appendString-cpu-arguments-intercept": 1000, + "appendString-cpu-arguments-slope": 59957, + "appendString-memory-arguments-intercept": 4, + "appendString-memory-arguments-slope": 1, + "bData-cpu-arguments": 11183, + "bData-memory-arguments": 32, + "blake2b-cpu-arguments-intercept": 201305, + "blake2b-cpu-arguments-slope": 8356, + "blake2b-memory-arguments": 4, + "cekApplyCost-exBudgetCPU": 16000, + "cekApplyCost-exBudgetMemory": 100, + "cekBuiltinCost-exBudgetCPU": 16000, + "cekBuiltinCost-exBudgetMemory": 100, + "cekConstCost-exBudgetCPU": 16000, + "cekConstCost-exBudgetMemory": 100, + "cekDelayCost-exBudgetCPU": 16000, + "cekDelayCost-exBudgetMemory": 100, + "cekForceCost-exBudgetCPU": 16000, + "cekForceCost-exBudgetMemory": 100, + "cekLamCost-exBudgetCPU": 16000, + "cekLamCost-exBudgetMemory": 100, + "cekStartupCost-exBudgetCPU": 100, + "cekStartupCost-exBudgetMemory": 100, + "cekVarCost-exBudgetCPU": 16000, + "cekVarCost-exBudgetMemory": 100, + "chooseData-cpu-arguments": 94375, + "chooseData-memory-arguments": 32, + "chooseList-cpu-arguments": 132994, + "chooseList-memory-arguments": 32, + "chooseUnit-cpu-arguments": 61462, + "chooseUnit-memory-arguments": 4, + "consByteString-cpu-arguments-intercept": 72010, + "consByteString-cpu-arguments-slope": 178, + "consByteString-memory-arguments-intercept": 0, + "consByteString-memory-arguments-slope": 1, + "constrData-cpu-arguments": 22151, + "constrData-memory-arguments": 32, + "decodeUtf8-cpu-arguments-intercept": 91189, + "decodeUtf8-cpu-arguments-slope": 769, + "decodeUtf8-memory-arguments-intercept": 4, + "decodeUtf8-memory-arguments-slope": 2, + "divideInteger-cpu-arguments-constant": 85848, + "divideInteger-cpu-arguments-model-arguments-intercept": 228465, + "divideInteger-cpu-arguments-model-arguments-slope": 122, + "divideInteger-memory-arguments-intercept": 0, + "divideInteger-memory-arguments-minimum": 1, + "divideInteger-memory-arguments-slope": 1, + "encodeUtf8-cpu-arguments-intercept": 1000, + "encodeUtf8-cpu-arguments-slope": 42921, + "encodeUtf8-memory-arguments-intercept": 4, + "encodeUtf8-memory-arguments-slope": 2, + "equalsByteString-cpu-arguments-constant": 24548, + "equalsByteString-cpu-arguments-intercept": 29498, + "equalsByteString-cpu-arguments-slope": 38, + "equalsByteString-memory-arguments": 1, + "equalsData-cpu-arguments-intercept": 898148, + "equalsData-cpu-arguments-slope": 27279, + "equalsData-memory-arguments": 1, + "equalsInteger-cpu-arguments-intercept": 51775, + "equalsInteger-cpu-arguments-slope": 558, + "equalsInteger-memory-arguments": 1, + "equalsString-cpu-arguments-constant": 39184, + "equalsString-cpu-arguments-intercept": 1000, + "equalsString-cpu-arguments-slope": 60594, + "equalsString-memory-arguments": 1, + "fstPair-cpu-arguments": 141895, + "fstPair-memory-arguments": 32, + "headList-cpu-arguments": 83150, + "headList-memory-arguments": 32, + "iData-cpu-arguments": 15299, + "iData-memory-arguments": 32, + "ifThenElse-cpu-arguments": 76049, + "ifThenElse-memory-arguments": 1, + "indexByteString-cpu-arguments": 13169, + "indexByteString-memory-arguments": 4, + "lengthOfByteString-cpu-arguments": 22100, + "lengthOfByteString-memory-arguments": 10, + "lessThanByteString-cpu-arguments-intercept": 28999, + "lessThanByteString-cpu-arguments-slope": 74, + "lessThanByteString-memory-arguments": 1, + "lessThanEqualsByteString-cpu-arguments-intercept": 28999, + "lessThanEqualsByteString-cpu-arguments-slope": 74, + "lessThanEqualsByteString-memory-arguments": 1, + "lessThanEqualsInteger-cpu-arguments-intercept": 43285, + "lessThanEqualsInteger-cpu-arguments-slope": 552, + "lessThanEqualsInteger-memory-arguments": 1, + "lessThanInteger-cpu-arguments-intercept": 44749, + "lessThanInteger-cpu-arguments-slope": 541, + "lessThanInteger-memory-arguments": 1, + "listData-cpu-arguments": 33852, + "listData-memory-arguments": 32, + "mapData-cpu-arguments": 68246, + "mapData-memory-arguments": 32, + "mkCons-cpu-arguments": 72362, + "mkCons-memory-arguments": 32, + "mkNilData-cpu-arguments": 7243, + "mkNilData-memory-arguments": 32, + "mkNilPairData-cpu-arguments": 7391, + "mkNilPairData-memory-arguments": 32, + "mkPairData-cpu-arguments": 11546, + "mkPairData-memory-arguments": 32, + "modInteger-cpu-arguments-constant": 85848, + "modInteger-cpu-arguments-model-arguments-intercept": 228465, + "modInteger-cpu-arguments-model-arguments-slope": 122, + "modInteger-memory-arguments-intercept": 0, + "modInteger-memory-arguments-minimum": 1, + "modInteger-memory-arguments-slope": 1, + "multiplyInteger-cpu-arguments-intercept": 90434, + "multiplyInteger-cpu-arguments-slope": 519, + "multiplyInteger-memory-arguments-intercept": 0, + "multiplyInteger-memory-arguments-slope": 1, + "nullList-cpu-arguments": 74433, + "nullList-memory-arguments": 32, + "quotientInteger-cpu-arguments-constant": 85848, + "quotientInteger-cpu-arguments-model-arguments-intercept": 228465, + "quotientInteger-cpu-arguments-model-arguments-slope": 122, + "quotientInteger-memory-arguments-intercept": 0, + "quotientInteger-memory-arguments-minimum": 1, + "quotientInteger-memory-arguments-slope": 1, + "remainderInteger-cpu-arguments-constant": 85848, + "remainderInteger-cpu-arguments-model-arguments-intercept": 228465, + "remainderInteger-cpu-arguments-model-arguments-slope": 122, + "remainderInteger-memory-arguments-intercept": 0, + "remainderInteger-memory-arguments-minimum": 1, + "remainderInteger-memory-arguments-slope": 1, + "sha2_256-cpu-arguments-intercept": 270652, + "sha2_256-cpu-arguments-slope": 22588, + "sha2_256-memory-arguments": 4, + "sha3_256-cpu-arguments-intercept": 1457325, + "sha3_256-cpu-arguments-slope": 64566, + "sha3_256-memory-arguments": 4, + "sliceByteString-cpu-arguments-intercept": 20467, + "sliceByteString-cpu-arguments-slope": 1, + "sliceByteString-memory-arguments-intercept": 4, + "sliceByteString-memory-arguments-slope": 0, + "sndPair-cpu-arguments": 141992, + "sndPair-memory-arguments": 32, + "subtractInteger-cpu-arguments-intercept": 100788, + "subtractInteger-cpu-arguments-slope": 420, + "subtractInteger-memory-arguments-intercept": 1, + "subtractInteger-memory-arguments-slope": 1, + "tailList-cpu-arguments": 81663, + "tailList-memory-arguments": 32, + "trace-cpu-arguments": 59498, + "trace-memory-arguments": 32, + "unBData-cpu-arguments": 20142, + "unBData-memory-arguments": 32, + "unConstrData-cpu-arguments": 24588, + "unConstrData-memory-arguments": 32, + "unIData-cpu-arguments": 20744, + "unIData-memory-arguments": 32, + "unListData-cpu-arguments": 25933, + "unListData-memory-arguments": 32, + "unMapData-cpu-arguments": 24623, + "unMapData-memory-arguments": 32, + "verifySignature-cpu-arguments-intercept": 53384111, + "verifySignature-cpu-arguments-slope": 14333, + "verifySignature-memory-arguments": 10 + } + } +} diff --git a/eras/alonzo/impl/test/Main.hs b/eras/alonzo/impl/test/Main.hs index 7f5c80cabab..97e34d1e758 100644 --- a/eras/alonzo/impl/test/Main.hs +++ b/eras/alonzo/impl/test/Main.hs @@ -8,6 +8,7 @@ import qualified Test.Cardano.Ledger.Alonzo.Binary.CddlSpec as CddlSpec import qualified Test.Cardano.Ledger.Alonzo.Binary.CostModelsSpec as CostModelsSpec import qualified Test.Cardano.Ledger.Alonzo.Binary.TxWitsSpec as TxWitsSpec import qualified Test.Cardano.Ledger.Alonzo.BinarySpec as BinarySpec +import Test.Cardano.Ledger.Alonzo.Era.Spec (alonzoEraSpec) import qualified Test.Cardano.Ledger.Alonzo.GoldenSpec as Golden import qualified Test.Cardano.Ledger.Alonzo.GoldenTranslation as GoldenTranslation import qualified Test.Cardano.Ledger.Alonzo.Imp as Imp @@ -19,7 +20,8 @@ import Test.Cardano.Ledger.Shelley.JSON (roundTripJsonShelleyEraSpec) main :: IO () main = - ledgerTestMain $ + ledgerTestMain $ do + alonzoEraSpec @AlonzoEra describe "Alonzo" $ do BinarySpec.spec Canonical.spec diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Era.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Era.hs index 27fe93f5c57..04f24eb9a86 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Era.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Era.hs @@ -15,6 +15,7 @@ import Cardano.Ledger.Alonzo.Plutus.Context import Cardano.Ledger.Alonzo.UTxO import Cardano.Ledger.Plutus (Language (..)) import Data.TreeDiff +import Paths_cardano_ledger_alonzo import Test.Cardano.Ledger.Alonzo.Arbitrary () import Test.Cardano.Ledger.Alonzo.TreeDiff () import Test.Cardano.Ledger.Mary.Era @@ -36,6 +37,8 @@ class instance EraTest AlonzoEra where zeroCostModels = zeroTestingCostModels [PlutusV1] + getEraDataFileName = getDataFileName + mkTestAccountState = mkShelleyTestAccountState accountsFromAccountsMap = shelleyAccountsFromAccountsMap diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Era/Spec.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Era/Spec.hs new file mode 100644 index 00000000000..a6283158fb6 --- /dev/null +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Era/Spec.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Alonzo.Era.Spec ( + alonzoEraSpec, +) where + +import Test.Cardano.Ledger.Alonzo.ImpTest +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Ledger.Mary.Era.Spec (maryEraSpec) + +-- | This spec is applicable to all eras and will be executed for every era starting with Alonzo. +alonzoEraSpec :: forall era. AlonzoEraImp era => Spec +alonzoEraSpec = do + maryEraSpec @era diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs index 0729869fedc..96ce86c52d1 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs @@ -124,6 +124,42 @@ class where scriptTestContexts :: Map ScriptHash ScriptTestContext +instance EraImp AlonzoEra where + initGenesis = + pure + AlonzoGenesis + { agCoinsPerUTxOWord = CoinPerWord (Coin 34_482) + , agCostModels = testingCostModels [PlutusV1] + , agPrices = + Prices + { prMem = 577 %! 10_000 + , prSteps = 721 %! 10_000_000 + } + , agMaxTxExUnits = + ExUnits + { exUnitsMem = 10_000_000 + , exUnitsSteps = 10_000_000_000 + } + , agMaxBlockExUnits = + ExUnits + { exUnitsMem = 50_000_000 + , exUnitsSteps = 40_000_000_000 + } + , agMaxValSize = 5000 + , agCollateralPercentage = 150 + , agMaxCollateralInputs = 3 + } + +instance ShelleyEraImp AlonzoEra where + impSatisfyNativeScript = impAllegraSatisfyNativeScript + fixupTx = alonzoFixupTx + expectTxSuccess = impAlonzoExpectTxSuccess + +instance MaryEraImp AlonzoEra + +instance AlonzoEraImp AlonzoEra where + scriptTestContexts = plutusTestScripts SPlutusV1 + makeCollateralInput :: ShelleyEraImp era => ImpTestM era TxIn makeCollateralInput = do -- TODO: make more accurate @@ -399,41 +435,6 @@ plutusTestScripts lang = malformedPlutus :: Plutus l malformedPlutus = Plutus (PlutusBinary "invalid") -instance ShelleyEraImp AlonzoEra where - initGenesis = - pure - AlonzoGenesis - { agCoinsPerUTxOWord = CoinPerWord (Coin 34_482) - , agCostModels = testingCostModels [PlutusV1] - , agPrices = - Prices - { prMem = 577 %! 10_000 - , prSteps = 721 %! 10_000_000 - } - , agMaxTxExUnits = - ExUnits - { exUnitsMem = 10_000_000 - , exUnitsSteps = 10_000_000_000 - } - , agMaxBlockExUnits = - ExUnits - { exUnitsMem = 50_000_000 - , exUnitsSteps = 40_000_000_000 - } - , agMaxValSize = 5000 - , agCollateralPercentage = 150 - , agMaxCollateralInputs = 3 - } - - impSatisfyNativeScript = impAllegraSatisfyNativeScript - fixupTx = alonzoFixupTx - expectTxSuccess = impAlonzoExpectTxSuccess - -instance MaryEraImp AlonzoEra - -instance AlonzoEraImp AlonzoEra where - scriptTestContexts = plutusTestScripts SPlutusV1 - impLookupScriptContext :: forall era. AlonzoEraImp era => @@ -512,7 +513,8 @@ impAlonzoExpectTxSuccess :: ( HasCallStack , AlonzoEraImp era ) => - Tx era -> ImpTestM era () + Tx era -> + ImpTestM era () impAlonzoExpectTxSuccess tx = do utxo <- getsNES utxoL let inputs = tx ^. bodyTxL . inputsTxBodyL diff --git a/eras/babbage/impl/cardano-ledger-babbage.cabal b/eras/babbage/impl/cardano-ledger-babbage.cabal index 97548bc6fbf..e8ea5f5c231 100644 --- a/eras/babbage/impl/cardano-ledger-babbage.cabal +++ b/eras/babbage/impl/cardano-ledger-babbage.cabal @@ -107,6 +107,7 @@ library testlib Test.Cardano.Ledger.Babbage.Binary.Twiddle Test.Cardano.Ledger.Babbage.CDDL Test.Cardano.Ledger.Babbage.Era + Test.Cardano.Ledger.Babbage.Era.Spec Test.Cardano.Ledger.Babbage.Examples Test.Cardano.Ledger.Babbage.Imp Test.Cardano.Ledger.Babbage.Imp.UtxoSpec diff --git a/eras/babbage/impl/test/Main.hs b/eras/babbage/impl/test/Main.hs index 2840d8861ce..a2228af0341 100644 --- a/eras/babbage/impl/test/Main.hs +++ b/eras/babbage/impl/test/Main.hs @@ -7,6 +7,7 @@ import qualified Test.Cardano.Ledger.Alonzo.Binary.CostModelsSpec as CostModelsS import qualified Test.Cardano.Ledger.Alonzo.Binary.TxWitsSpec as TxWitsSpec import qualified Test.Cardano.Ledger.Babbage.Binary.CddlSpec as CddlSpec import qualified Test.Cardano.Ledger.Babbage.BinarySpec as BinarySpec +import Test.Cardano.Ledger.Babbage.Era.Spec (babbageEraSpec) import qualified Test.Cardano.Ledger.Babbage.GoldenSpec as Golden import qualified Test.Cardano.Ledger.Babbage.GoldenTranslation as GoldenTranslation import qualified Test.Cardano.Ledger.Babbage.Imp as Imp @@ -18,7 +19,8 @@ import Test.Cardano.Ledger.Shelley.JSON (roundTripJsonShelleyEraSpec) main :: IO () main = - ledgerTestMain $ + ledgerTestMain $ do + babbageEraSpec @BabbageEra describe "Babbage" $ do TxInfo.spec @BabbageEra GoldenTranslation.spec diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Era.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Era.hs index 87255856ba4..65ed6dca104 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Era.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Era.hs @@ -9,6 +9,7 @@ module Test.Cardano.Ledger.Babbage.Era ( import Cardano.Ledger.Babbage import Cardano.Ledger.Babbage.Core import Cardano.Ledger.Plutus (Language (..)) +import Paths_cardano_ledger_babbage import Test.Cardano.Ledger.Alonzo.Era import Test.Cardano.Ledger.Babbage.Arbitrary () import Test.Cardano.Ledger.Babbage.TreeDiff () @@ -23,6 +24,9 @@ class instance EraTest BabbageEra where zeroCostModels = zeroTestingCostModels [PlutusV1 .. PlutusV2] + + getEraDataFileName = getDataFileName + mkTestAccountState = mkShelleyTestAccountState accountsFromAccountsMap = shelleyAccountsFromAccountsMap diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Era/Spec.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Era/Spec.hs new file mode 100644 index 00000000000..defe698eca7 --- /dev/null +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Era/Spec.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Babbage.Era.Spec ( + babbageEraSpec, +) where + +import Test.Cardano.Ledger.Alonzo.Era.Spec (alonzoEraSpec) +import Test.Cardano.Ledger.Babbage.ImpTest +import Test.Cardano.Ledger.Imp.Common + +-- | This spec is applicable to all eras and will be executed for every era starting with Babbage. +babbageEraSpec :: forall era. AlonzoEraImp era => Spec +babbageEraSpec = do + alonzoEraSpec @era diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/ImpTest.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/ImpTest.hs index a8411a5c085..a22f4419df2 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/ImpTest.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/ImpTest.hs @@ -46,6 +46,8 @@ import Test.Cardano.Ledger.Babbage.Era () import Test.Cardano.Ledger.Babbage.TreeDiff () import Test.Cardano.Ledger.Plutus (testingCostModels) +instance EraImp BabbageEra + instance ShelleyEraImp BabbageEra where initNewEpochState = defaultInitNewEpochState @@ -92,7 +94,8 @@ impBabbageExpectTxSuccess :: , AlonzoEraImp era , BabbageEraTxBody era ) => - Tx era -> ImpTestM era () + Tx era -> + ImpTestM era () impBabbageExpectTxSuccess tx = do impAlonzoExpectTxSuccess tx -- Check that the balance of the collateral was returned diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 5dd46fa8a97..8763777d3b9 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -134,6 +134,7 @@ library testlib Test.Cardano.Ledger.Conway.CommitteeRatifySpec Test.Cardano.Ledger.Conway.DRepRatifySpec Test.Cardano.Ledger.Conway.Era + Test.Cardano.Ledger.Conway.Era.Spec Test.Cardano.Ledger.Conway.Examples Test.Cardano.Ledger.Conway.Genesis Test.Cardano.Ledger.Conway.GenesisSpec diff --git a/eras/conway/impl/golden/json/conway-genesis.json b/eras/conway/impl/golden/json/conway-genesis.json new file mode 100644 index 00000000000..760995a34d4 --- /dev/null +++ b/eras/conway/impl/golden/json/conway-genesis.json @@ -0,0 +1,303 @@ +{ + "poolVotingThresholds": { + "committeeNormal": 0.51, + "committeeNoConfidence": 0.51, + "hardForkInitiation": 0.51, + "motionNoConfidence": 0.51, + "ppSecurityGroup": 0.51 + }, + "dRepVotingThresholds": { + "motionNoConfidence": 0.67, + "committeeNormal": 0.67, + "committeeNoConfidence": 0.6, + "updateToConstitution": 0.75, + "hardForkInitiation": 0.6, + "ppNetworkGroup": 0.67, + "ppEconomicGroup": 0.67, + "ppTechnicalGroup": 0.67, + "ppGovGroup": 0.75, + "treasuryWithdrawal": 0.67 + }, + "committeeMinSize": 7, + "committeeMaxTermLength": 146, + "govActionLifetime": 6, + "govActionDeposit": 100000000000, + "dRepDeposit": 500000000, + "dRepActivity": 20, + "minFeeRefScriptCostPerByte": 15, + "plutusV3CostModel": [ + 100788, + 420, + 1, + 1, + 1000, + 173, + 0, + 1, + 1000, + 59957, + 4, + 1, + 11183, + 32, + 201305, + 8356, + 4, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 16000, + 100, + 100, + 100, + 16000, + 100, + 94375, + 32, + 132994, + 32, + 61462, + 4, + 72010, + 178, + 0, + 1, + 22151, + 32, + 91189, + 769, + 4, + 2, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, + 0, + 1, + 1, + 1000, + 42921, + 4, + 2, + 24548, + 29498, + 38, + 1, + 898148, + 27279, + 1, + 51775, + 558, + 1, + 39184, + 1000, + 60594, + 1, + 141895, + 32, + 83150, + 32, + 15299, + 32, + 76049, + 1, + 13169, + 4, + 22100, + 10, + 28999, + 74, + 1, + 28999, + 74, + 1, + 43285, + 552, + 1, + 44749, + 541, + 1, + 33852, + 32, + 68246, + 32, + 72362, + 32, + 7243, + 32, + 7391, + 32, + 11546, + 32, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, + 0, + 1, + 90434, + 519, + 0, + 1, + 74433, + 32, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, + 0, + 1, + 1, + 85848, + 123203, + 7305, + -900, + 1716, + 549, + 57, + 85848, + 0, + 1, + 955506, + 213312, + 0, + 2, + 270652, + 22588, + 4, + 1457325, + 64566, + 4, + 20467, + 1, + 4, + 0, + 141992, + 32, + 100788, + 420, + 1, + 1, + 81663, + 32, + 59498, + 32, + 20142, + 32, + 24588, + 32, + 20744, + 32, + 25933, + 32, + 24623, + 32, + 43053543, + 10, + 53384111, + 14333, + 10, + 43574283, + 26308, + 10, + 16000, + 100, + 16000, + 100, + 962335, + 18, + 2780678, + 6, + 442008, + 1, + 52538055, + 3756, + 18, + 267929, + 18, + 76433006, + 8868, + 18, + 52948122, + 18, + 1995836, + 36, + 3227919, + 12, + 901022, + 1, + 166917843, + 4307, + 36, + 284546, + 36, + 158221314, + 26549, + 36, + 74698472, + 36, + 333849714, + 1, + 254006273, + 72, + 2174038, + 72, + 2261318, + 64571, + 4, + 207616, + 8310, + 4, + 1293828, + 28716, + 63, + 0, + 1, + 1006041, + 43623, + 251, + 0, + 1 + ], + "constitution": { + "anchor": { + "dataHash": "ca41a91f399259bcefe57f9858e91f6d00e1a38d6d9c63d4052914ea7bd70cb2", + "url": "ipfs://bafkreifnwj6zpu3ixa4siz2lndqybyc5wnnt3jkwyutci4e2tmbnj3xrdm" + }, + "script": "fa24fb305126805cf2164c161d852a0e7330cf988f1fe558cf7d4a64" + }, + "committee": { + "members": { + "scriptHash-df0e83bde65416dade5b1f97e7f115cc1ff999550ad968850783fe50": 580, + "scriptHash-b6012034ba0a7e4afbbf2c7a1432f8824aee5299a48e38e41a952686": 580, + "scriptHash-ce8b37a72b178a37bbd3236daa7b2c158c9d3604e7aa667e6c6004b7": 580, + "scriptHash-f0dc2c00d92a45521267be2d5de1c485f6f9d14466d7e16062897cf7": 580, + "scriptHash-349e55f83e9af24813e6cb368df6a80d38951b2a334dfcdf26815558": 580, + "scriptHash-84aebcfd3e00d0f87af918fc4b5e00135f407e379893df7e7d392c6a": 580, + "scriptHash-e8165b3328027ee0d74b1f07298cb092fd99aa7697a1436f5997f625": 580 + }, + "threshold": { + "numerator": 2, + "denominator": 3 + } + } +} diff --git a/eras/conway/impl/test/Main.hs b/eras/conway/impl/test/Main.hs index 1b1e45b194d..477707a921a 100644 --- a/eras/conway/impl/test/Main.hs +++ b/eras/conway/impl/test/Main.hs @@ -7,6 +7,7 @@ import Cardano.Ledger.Conway (ConwayEra) import Cardano.Ledger.Conway.Tx (tierRefScriptFee) import Test.Cardano.Ledger.Common import qualified Test.Cardano.Ledger.Conway.Binary.CddlSpec as Cddl +import Test.Cardano.Ledger.Conway.Era.Spec (conwayEraSpec) import qualified Test.Cardano.Ledger.Conway.GenesisSpec as Genesis import qualified Test.Cardano.Ledger.Conway.GoldenSpec as GoldenSpec import qualified Test.Cardano.Ledger.Conway.GoldenTranslation as GoldenTranslation @@ -17,6 +18,7 @@ import Test.Cardano.Ledger.Shelley.JSON (roundTripJsonShelleyEraSpec) main :: IO () main = ledgerTestMain $ do + conwayEraSpec @ConwayEra describe "Conway era-generic" $ ConwaySpec.spec @ConwayEra describe "Conway era-specific" $ do GoldenTranslation.spec diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Era.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Era.hs index d2bb332102d..5e127091c5d 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Era.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Era.hs @@ -21,6 +21,7 @@ import Data.Coerce import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Lens.Micro +import Paths_cardano_ledger_conway import Test.Cardano.Ledger.Babbage.Era import Test.Cardano.Ledger.Conway.Arbitrary () import Test.Cardano.Ledger.Conway.TreeDiff () @@ -38,6 +39,8 @@ class instance EraTest ConwayEra where zeroCostModels = zeroTestingCostModels [PlutusV1 .. PlutusV3] + getEraDataFileName = getDataFileName + mkTestAccountState _mPtr = mkConwayTestAccountState accountsFromAccountsMap = coerce diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Era/Spec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Era/Spec.hs new file mode 100644 index 00000000000..86163c2a90e --- /dev/null +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Era/Spec.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Conway.Era.Spec ( + conwayEraSpec, +) where + +import Test.Cardano.Ledger.Conway.ImpTest +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Ledger.Babbage.Era.Spec (babbageEraSpec) + +-- | This spec is applicable to all eras and will be executed for every era starting with Conway. +conwayEraSpec :: forall era. ConwayEraImp era => Spec +conwayEraSpec = do + babbageEraSpec @era diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs index 1f10e1d3cad..893d9d07b13 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs @@ -42,6 +42,7 @@ import qualified Data.Set as Set import Lens.Micro import Test.Cardano.Ledger.Conway.Arbitrary () import Test.Cardano.Ledger.Conway.ImpTest +import Test.Cardano.Ledger.Core.Utils (nextMajorProtVer) import Test.Cardano.Ledger.Imp.Common import Test.Cardano.Ledger.Plutus.Examples (evenRedeemerNoDatum) @@ -419,7 +420,7 @@ spec = do hotCreds <- registerInitialCommittee (spo, _, _) <- setupPoolWithStake $ Coin 3_000_000_000 protVer <- getProtVer - gai <- submitGovAction $ HardForkInitiation SNothing (majorFollow protVer) + gai <- submitGovAction $ HardForkInitiation SNothing (nextMajorProtVer protVer) submitYesVoteCCs_ hotCreds gai submitYesVote_ (StakePoolVoter spo) gai passNEpochs 2 @@ -440,7 +441,7 @@ spec = do hotCreds <- registerInitialCommittee (spo, _, _) <- setupPoolWithStake $ Coin 3_000_000_000 protVer <- getProtVer - gai <- submitGovAction $ HardForkInitiation SNothing (majorFollow protVer) + gai <- submitGovAction $ HardForkInitiation SNothing (nextMajorProtVer protVer) submitYesVoteCCs_ hotCreds gai submitYesVote_ (StakePoolVoter spo) gai passNEpochs 2 @@ -534,7 +535,7 @@ spec = do expectDelegatedVote cred DRepAlwaysAbstain impAnn "Version should be unchanged" $ getProtVer `shouldReturn` initialProtVer - let nextVer = majorFollow initialProtVer + let nextVer = nextMajorProtVer initialProtVer hfGaid <- submitGovAction $ HardForkInitiation SNothing nextVer submitVote_ VoteYes (StakePoolVoter khSPO) hfGaid submitVote_ VoteYes (CommitteeVoter ccCred) hfGaid diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs index b12869d0ba8..d7c88716b18 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs @@ -39,6 +39,7 @@ import Lens.Micro import Test.Cardano.Ledger.Conway.Arbitrary () import Test.Cardano.Ledger.Conway.ImpTest import Test.Cardano.Ledger.Core.Rational (IsRatio (..)) +import Test.Cardano.Ledger.Core.Utils (nextMajorProtVer, nextMinorProtVer) import Test.Cardano.Ledger.Imp.Common hiding (Success) spec :: @@ -166,12 +167,12 @@ hardForkSpec :: hardForkSpec = describe "HardFork" $ do describe "Hardfork is the first one (doesn't have a GovPurposeId) " $ do - it "Hardfork minorFollow" (firstHardForkFollows minorFollow) - it "Hardfork majorFollow" (firstHardForkFollows majorFollow) + it "Hardfork minorFollow" (firstHardForkFollows nextMinorProtVer) + it "Hardfork majorFollow" (firstHardForkFollows nextMajorProtVer) it "Hardfork cantFollow" firstHardForkCantFollow describe "Hardfork is the second one (has a GovPurposeId)" $ do - it "Hardfork minorFollow" (secondHardForkFollows minorFollow) - it "Hardfork majorFollow" (secondHardForkFollows majorFollow) + it "Hardfork minorFollow" (secondHardForkFollows nextMinorProtVer) + it "Hardfork majorFollow" (secondHardForkFollows nextMajorProtVer) it "Hardfork cantFollow" secondHardForkCantFollow pparamUpdateSpec :: @@ -1166,7 +1167,7 @@ firstHardForkCantFollow :: ImpTestM era () firstHardForkCantFollow = do protver0 <- getProtVer - let protver1 = minorFollow protver0 + let protver1 = nextMinorProtVer protver0 protver2 = cantFollow protver1 proposal <- mkProposal $ HardForkInitiation SNothing protver2 submitFailingProposal @@ -1187,7 +1188,7 @@ secondHardForkFollows :: ImpTestM era () secondHardForkFollows computeNewFromOld = do protver0 <- getProtVer - let protver1 = minorFollow protver0 + let protver1 = nextMinorProtVer protver0 protver2 = computeNewFromOld protver1 gaid1 <- submitGovAction $ HardForkInitiation SNothing protver1 submitGovAction_ $ HardForkInitiation (SJust (GovPurposeId gaid1)) protver2 @@ -1202,7 +1203,7 @@ secondHardForkCantFollow :: ImpTestM era () secondHardForkCantFollow = do protver0 <- getProtVer - let protver1 = minorFollow protver0 + let protver1 = nextMinorProtVer protver0 protver2 = cantFollow protver1 gaid1 <- mkProposal (HardForkInitiation SNothing protver1) >>= submitProposal mkProposal (HardForkInitiation (SJust (GovPurposeId gaid1)) protver2) diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs index 679ea826221..c5b14c6fbd1 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs @@ -33,6 +33,7 @@ import Lens.Micro import Test.Cardano.Ledger.Conway.ImpTest import Test.Cardano.Ledger.Core.KeyPair import Test.Cardano.Ledger.Core.Rational ((%!)) +import Test.Cardano.Ledger.Core.Utils (nextMajorProtVer) import Test.Cardano.Ledger.Imp.Common spec :: @@ -82,7 +83,7 @@ initiateHardForkWithLessThanMinimalCommitteeSize = anchor <- arbitrary mHotCred <- resignCommitteeColdKey committeeMember anchor protVer <- getProtVer - gai <- submitGovAction $ HardForkInitiation SNothing (majorFollow protVer) + gai <- submitGovAction $ HardForkInitiation SNothing (nextMajorProtVer protVer) submitYesVoteCCs_ (maybe NE.toList (\hotCred -> NE.filter (/= hotCred)) mHotCred hotCs) gai submitYesVote_ (StakePoolVoter spoK1) gai if hardforkConwayBootstrapPhase protVer @@ -117,7 +118,7 @@ spoAndCCVotingSpec = do (spoC, _, _) <- setupPoolWithStake $ Coin 1_000_000_000 protVer <- getProtVer - gai <- submitGovAction $ HardForkInitiation SNothing (majorFollow protVer) + gai <- submitGovAction $ HardForkInitiation SNothing (nextMajorProtVer protVer) submitYesVote_ (StakePoolVoter spoC) gai -- CC members expired so their votes don't count - we are stuck! @@ -146,15 +147,14 @@ spoAndCCVotingSpec = do describe "When CC threshold is 0" $ do -- During the bootstrap phase, proposals that modify the committee are not allowed, -- hence we need to directly set the threshold for the initial members - let - modifyCommittee f = modifyNES $ \nes -> - nes - & newEpochStateGovStateL . committeeGovStateL %~ f - & newEpochStateDRepPulsingStateL %~ modifyDRepPulser - where - modifyDRepPulser pulser = - case finishDRepPulser pulser of - (snapshot, rState) -> DRComplete snapshot (rState & rsEnactStateL . ensCommitteeL %~ f) + let modifyCommittee f = modifyNES $ \nes -> + nes + & newEpochStateGovStateL . committeeGovStateL %~ f + & newEpochStateDRepPulsingStateL %~ modifyDRepPulser + where + modifyDRepPulser pulser = + case finishDRepPulser pulser of + (snapshot, rState) -> DRComplete snapshot (rState & rsEnactStateL . ensCommitteeL %~ f) it "SPOs alone can enact hard-fork during bootstrap" $ do (spoC, _, _) <- setupPoolWithStake $ Coin 1_000_000_000 protVer <- getProtVer @@ -162,7 +162,7 @@ spoAndCCVotingSpec = do let nextProtVer = protVer {pvMajor = nextMajorVersion} modifyCommittee $ fmap (committeeThresholdL .~ 0 %! 1) - gai <- submitGovAction $ HardForkInitiation SNothing (majorFollow protVer) + gai <- submitGovAction $ HardForkInitiation SNothing (nextMajorProtVer protVer) submitYesVote_ (StakePoolVoter spoC) gai @@ -531,7 +531,7 @@ spoVotesForHardForkInitiation = _ <- setupPoolWithStake $ Coin 100_000_000 modifyPParams $ ppPoolVotingThresholdsL . pvtHardForkInitiationL .~ 1 %! 2 protVer <- getProtVer - gai <- submitGovAction $ HardForkInitiation SNothing (majorFollow protVer) + gai <- submitGovAction $ HardForkInitiation SNothing (nextMajorProtVer protVer) impAnn "Submit CC yes vote" $ submitYesVoteCCs_ hotCCs gai logString $ "Committee: " <> showExpr hotCCs GovActionState {gasCommitteeVotes} <- getGovActionState gai @@ -724,8 +724,7 @@ votingSpec = -- The proposal deposit comes from the root UTxO cc <- KeyHashObj <$> freshKeyHash curEpochNo <- getsNES nesELL - let - newCommitteMembers = Map.singleton cc $ addEpochInterval curEpochNo (EpochInterval 10) + let newCommitteMembers = Map.singleton cc $ addEpochInterval curEpochNo (EpochInterval 10) addCCGaid <- mkProposalWithRewardAccount (UpdateCommittee SNothing mempty newCommitteMembers (75 %! 100)) @@ -740,8 +739,7 @@ votingSpec = getLastEnactedCommittee `shouldReturn` SNothing -- Submit another proposal to bump up the active voting stake cc' <- KeyHashObj <$> freshKeyHash - let - newCommitteMembers' = Map.singleton cc' $ addEpochInterval curEpochNo (EpochInterval 10) + let newCommitteMembers' = Map.singleton cc' $ addEpochInterval curEpochNo (EpochInterval 10) mkProposalWithRewardAccount (UpdateCommittee SNothing mempty newCommitteMembers' (75 %! 100)) dRepRewardAccount @@ -767,16 +765,14 @@ votingSpec = -- After this both stakingKH1 and stakingKH3 are expected to have 1_000_000 ADA of stake, each cc <- KeyHashObj <$> freshKeyHash curEpochNo <- getsNES nesELL - let - newCommitteMembers = Map.singleton cc $ addEpochInterval curEpochNo (EpochInterval 10) + let newCommitteMembers = Map.singleton cc $ addEpochInterval curEpochNo (EpochInterval 10) addCCGaid <- mkProposalWithRewardAccount (UpdateCommittee SNothing mempty newCommitteMembers (75 %! 100)) dRepRewardAccount1 >>= submitProposal cc' <- KeyHashObj <$> freshKeyHash - let - newCommitteMembers' = Map.singleton cc' $ addEpochInterval curEpochNo (EpochInterval 10) + let newCommitteMembers' = Map.singleton cc' $ addEpochInterval curEpochNo (EpochInterval 10) mkProposalWithRewardAccount (UpdateCommittee SNothing mempty newCommitteMembers' (75 %! 100)) dRepRewardAccount3 @@ -1055,8 +1051,7 @@ votingSpec = -- The proposal deposit comes from the root UTxO cc <- KeyHashObj <$> freshKeyHash curEpochNo <- getsNES nesELL - let - newCommitteMembers = Map.singleton cc $ addEpochInterval curEpochNo (EpochInterval 10) + let newCommitteMembers = Map.singleton cc $ addEpochInterval curEpochNo (EpochInterval 10) addCCGaid <- mkProposalWithRewardAccount (UpdateCommittee SNothing mempty newCommitteMembers (75 %! 100)) @@ -1071,8 +1066,7 @@ votingSpec = getLastEnactedCommittee `shouldReturn` SNothing -- Submit another proposal to bump up the active voting stake of SPO #1 cc' <- KeyHashObj <$> freshKeyHash - let - newCommitteMembers' = Map.singleton cc' $ addEpochInterval curEpochNo (EpochInterval 10) + let newCommitteMembers' = Map.singleton cc' $ addEpochInterval curEpochNo (EpochInterval 10) mkProposalWithRewardAccount (UpdateCommittee SNothing mempty newCommitteMembers' (75 %! 100)) spoRewardAccount @@ -1109,16 +1103,14 @@ votingSpec = -- After this both stakingC1 and stakingC3 are expected to have 1_000_000 ADA of stake, each cc <- KeyHashObj <$> freshKeyHash curEpochNo <- getsNES nesELL - let - newCommitteMembers = Map.singleton cc $ addEpochInterval curEpochNo (EpochInterval 10) + let newCommitteMembers = Map.singleton cc $ addEpochInterval curEpochNo (EpochInterval 10) addCCGaid <- mkProposalWithRewardAccount (UpdateCommittee SNothing mempty newCommitteMembers (75 %! 100)) spoRewardAccount1 >>= submitProposal cc' <- KeyHashObj <$> freshKeyHash - let - newCommitteMembers' = Map.singleton cc' $ addEpochInterval curEpochNo (EpochInterval 10) + let newCommitteMembers' = Map.singleton cc' $ addEpochInterval curEpochNo (EpochInterval 10) mkProposalWithRewardAccount (UpdateCommittee SNothing mempty newCommitteMembers' (75 %! 100)) spoRewardAccount3 @@ -1677,28 +1669,27 @@ committeeMaxTermLengthSpec :: committeeMaxTermLengthSpec = -- Committee-update proposals are disallowed during bootstrap, so we can only run these tests post-bootstrap describe "Committee members can serve full `CommitteeMaxTermLength`" $ do - let - electMembersWithMaxTermLength :: - KeyHash 'StakePool -> - Credential 'DRepRole -> - ImpTestM era [Credential 'ColdCommitteeRole] - electMembersWithMaxTermLength spoC drep = do - m1 <- KeyHashObj <$> freshKeyHash - m2 <- KeyHashObj <$> freshKeyHash - currentEpoch <- getsNES nesELL - maxTermLength <- - getsNES $ - nesEsL . curPParamsEpochStateL . ppCommitteeMaxTermLengthL - let expiry = addEpochInterval (addEpochInterval currentEpoch $ EpochInterval 1) maxTermLength - members = [(m1, expiry), (m2, expiry)] - GovPurposeId gaid <- - submitCommitteeElection - SNothing - drep - Set.empty - members - submitYesVote_ (StakePoolVoter spoC) gaid - pure [m1, m2] + let electMembersWithMaxTermLength :: + KeyHash 'StakePool -> + Credential 'DRepRole -> + ImpTestM era [Credential 'ColdCommitteeRole] + electMembersWithMaxTermLength spoC drep = do + m1 <- KeyHashObj <$> freshKeyHash + m2 <- KeyHashObj <$> freshKeyHash + currentEpoch <- getsNES nesELL + maxTermLength <- + getsNES $ + nesEsL . curPParamsEpochStateL . ppCommitteeMaxTermLengthL + let expiry = addEpochInterval (addEpochInterval currentEpoch $ EpochInterval 1) maxTermLength + members = [(m1, expiry), (m2, expiry)] + GovPurposeId gaid <- + submitCommitteeElection + SNothing + drep + Set.empty + members + submitYesVote_ (StakePoolVoter spoC) gaid + pure [m1, m2] it "maxTermLength = 0" $ whenPostBootstrap $ do -- ======== EPOCH e ======== diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs index f787c2cf734..b77570205e8 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs @@ -238,7 +238,7 @@ conwayModifyPParams f = modifyNES $ \nes -> (snapshot, ratifyState) -> DRComplete snapshot (ratifyState & rsEnactStateL . ensCurPParamsL %~ f) -instance ShelleyEraImp ConwayEra where +instance EraImp ConwayEra where initGenesis = do kh1 <- freshKeyHash kh2 <- freshKeyHash @@ -291,6 +291,7 @@ instance ShelleyEraImp ConwayEra where , cgInitialDReps = mempty } +instance ShelleyEraImp ConwayEra where impSatisfyNativeScript = impAllegraSatisfyNativeScript modifyPParams = conwayModifyPParams diff --git a/eras/dijkstra/cardano-ledger-dijkstra.cabal b/eras/dijkstra/cardano-ledger-dijkstra.cabal index 15715054566..756d03180fe 100644 --- a/eras/dijkstra/cardano-ledger-dijkstra.cabal +++ b/eras/dijkstra/cardano-ledger-dijkstra.cabal @@ -111,6 +111,7 @@ library testlib Test.Cardano.Ledger.Dijkstra.Binary.RoundTrip Test.Cardano.Ledger.Dijkstra.CDDL Test.Cardano.Ledger.Dijkstra.Era + Test.Cardano.Ledger.Dijkstra.Era.Spec Test.Cardano.Ledger.Dijkstra.Examples Test.Cardano.Ledger.Dijkstra.ImpTest Test.Cardano.Ledger.Dijkstra.TreeDiff diff --git a/eras/dijkstra/golden/json/dijkstra-genesis.json b/eras/dijkstra/golden/json/dijkstra-genesis.json new file mode 100644 index 00000000000..c33c6755721 --- /dev/null +++ b/eras/dijkstra/golden/json/dijkstra-genesis.json @@ -0,0 +1,6 @@ +{ + "maxRefScriptSizePerBlock": 1048576, + "maxRefScriptSizePerTx": 204800, + "refScriptCostStride": 25600, + "refScriptCostMultiplier": 1.2 +} diff --git a/eras/dijkstra/test/Main.hs b/eras/dijkstra/test/Main.hs index 192f5213522..0505893eeb8 100644 --- a/eras/dijkstra/test/Main.hs +++ b/eras/dijkstra/test/Main.hs @@ -2,6 +2,7 @@ module Main where +import Test.Cardano.Ledger.Dijkstra.Era.Spec (dijkstraEraSpec) import Cardano.Ledger.Dijkstra (DijkstraEra) import Cardano.Ledger.Dijkstra.Rules () import Test.Cardano.Ledger.Common @@ -15,6 +16,7 @@ import Test.Cardano.Ledger.Shelley.JSON (roundTripJsonShelleyEraSpec) main :: IO () main = ledgerTestMain $ do + dijkstraEraSpec @DijkstraEra describe "Dijkstra" $ do ConwaySpec.spec @DijkstraEra roundTripJsonShelleyEraSpec @DijkstraEra diff --git a/eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/Era.hs b/eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/Era.hs index fbf8349db37..a1ae2c3a303 100644 --- a/eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/Era.hs +++ b/eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/Era.hs @@ -8,6 +8,7 @@ import Cardano.Ledger.Dijkstra (DijkstraEra) import Cardano.Ledger.Dijkstra.State import Cardano.Ledger.Plutus (Language (..)) import Data.Coerce +import Paths_cardano_ledger_dijkstra import Test.Cardano.Ledger.Conway.Era import Test.Cardano.Ledger.Dijkstra.Arbitrary () import Test.Cardano.Ledger.Dijkstra.TreeDiff () @@ -16,6 +17,8 @@ import Test.Cardano.Ledger.Plutus (zeroTestingCostModels) instance EraTest DijkstraEra where zeroCostModels = zeroTestingCostModels [PlutusV1 .. PlutusV4] + getEraDataFileName = getDataFileName + mkTestAccountState _ptr = mkConwayTestAccountState accountsFromAccountsMap = coerce diff --git a/eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/Era/Spec.hs b/eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/Era/Spec.hs new file mode 100644 index 00000000000..5a0a3fc1cab --- /dev/null +++ b/eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/Era/Spec.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Dijkstra.Era.Spec ( + dijkstraEraSpec, +) where + +import Test.Cardano.Ledger.Conway.Era.Spec (conwayEraSpec) +import Test.Cardano.Ledger.Dijkstra.ImpTest +import Test.Cardano.Ledger.Imp.Common + +-- | This spec is applicable to all eras and will be executed for every era starting with Dijkstra. +dijkstraEraSpec :: forall era. ConwayEraImp era => Spec +dijkstraEraSpec = do + conwayEraSpec @era diff --git a/eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/ImpTest.hs b/eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/ImpTest.hs index d86d5b2c9e1..b02579ef264 100644 --- a/eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/ImpTest.hs +++ b/eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/ImpTest.hs @@ -36,9 +36,10 @@ import Lens.Micro ((%~), (&)) import Test.Cardano.Ledger.Conway.ImpTest import Test.Cardano.Ledger.Dijkstra.Era () -instance ShelleyEraImp DijkstraEra where +instance EraImp DijkstraEra where initGenesis = pure exampleDijkstraGenesis +instance ShelleyEraImp DijkstraEra where initNewEpochState = defaultInitNewEpochState $ \nes -> nes & nesEsL . epochStateGovStateL . committeeGovStateL %~ fmap updateCommitteeExpiry diff --git a/eras/mary/impl/cardano-ledger-mary.cabal b/eras/mary/impl/cardano-ledger-mary.cabal index 6d247eb8810..a9d9c16c9bb 100644 --- a/eras/mary/impl/cardano-ledger-mary.cabal +++ b/eras/mary/impl/cardano-ledger-mary.cabal @@ -102,6 +102,7 @@ library testlib Test.Cardano.Ledger.Mary.Binary.Cddl Test.Cardano.Ledger.Mary.CDDL Test.Cardano.Ledger.Mary.Era + Test.Cardano.Ledger.Mary.Era.Spec Test.Cardano.Ledger.Mary.Examples Test.Cardano.Ledger.Mary.Imp Test.Cardano.Ledger.Mary.Imp.UtxoSpec diff --git a/eras/mary/impl/test/Main.hs b/eras/mary/impl/test/Main.hs index 84719ee6b87..39c6af348ac 100644 --- a/eras/mary/impl/test/Main.hs +++ b/eras/mary/impl/test/Main.hs @@ -7,6 +7,7 @@ import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.JSON (roundTripJsonEraSpec) import qualified Test.Cardano.Ledger.Mary.Binary.CddlSpec as CddlSpec import qualified Test.Cardano.Ledger.Mary.BinarySpec as BinarySpec +import Test.Cardano.Ledger.Mary.Era.Spec (maryEraSpec) import qualified Test.Cardano.Ledger.Mary.Imp as Imp import Test.Cardano.Ledger.Mary.ImpTest () import qualified Test.Cardano.Ledger.Mary.ValueSpec as ValueSpec @@ -14,7 +15,8 @@ import Test.Cardano.Ledger.Shelley.JSON (roundTripJsonShelleyEraSpec) main :: IO () main = - ledgerTestMain $ + ledgerTestMain $ do + maryEraSpec @MaryEra describe "Mary" $ do ValueSpec.spec BinarySpec.spec diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Era.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Era.hs index 2772d9f4d54..8476245d595 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Era.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Era.hs @@ -9,6 +9,7 @@ module Test.Cardano.Ledger.Mary.Era ( import Cardano.Ledger.Mary import Cardano.Ledger.Mary.Core import Cardano.Ledger.Plutus (emptyCostModels) +import Paths_cardano_ledger_mary import Test.Cardano.Ledger.Allegra.Era import Test.Cardano.Ledger.Mary.Arbitrary () import Test.Cardano.Ledger.Mary.TreeDiff () @@ -22,6 +23,8 @@ class instance EraTest MaryEra where zeroCostModels = emptyCostModels + getEraDataFileName = getDataFileName + mkTestAccountState = mkShelleyTestAccountState accountsFromAccountsMap = shelleyAccountsFromAccountsMap diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Era/Spec.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Era/Spec.hs new file mode 100644 index 00000000000..d1468e899d0 --- /dev/null +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Era/Spec.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Mary.Era.Spec ( + maryEraSpec, +) where + +import Test.Cardano.Ledger.Mary.ImpTest +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Ledger.Allegra.Era.Spec (allegraEraSpec) + +-- | This spec is applicable to all eras and will be executed for every era starting with Mary. +maryEraSpec :: forall era. MaryEraImp era => Spec +maryEraSpec = do + allegraEraSpec @era diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs index bc322ee1aa7..7b8b4782525 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs @@ -23,6 +23,8 @@ import Test.Cardano.Ledger.Mary.Arbitrary () import Test.Cardano.Ledger.Mary.Era import Test.Cardano.Ledger.Mary.TreeDiff () +instance EraImp MaryEra + instance ShelleyEraImp MaryEra where impSatisfyNativeScript = impAllegraSatisfyNativeScript fixupTx = shelleyFixupTx diff --git a/eras/shelley/impl/cardano-ledger-shelley.cabal b/eras/shelley/impl/cardano-ledger-shelley.cabal index 927d8dda129..b03a05001d3 100644 --- a/eras/shelley/impl/cardano-ledger-shelley.cabal +++ b/eras/shelley/impl/cardano-ledger-shelley.cabal @@ -143,6 +143,7 @@ library testlib Test.Cardano.Ledger.Shelley.CDDL Test.Cardano.Ledger.Shelley.Constants Test.Cardano.Ledger.Shelley.Era + Test.Cardano.Ledger.Shelley.Era.Spec Test.Cardano.Ledger.Shelley.Examples Test.Cardano.Ledger.Shelley.Imp Test.Cardano.Ledger.Shelley.Imp.EpochSpec @@ -191,14 +192,11 @@ library testlib microlens, microlens-mtl, mtl, - prettyprinter, - prettyprinter-ansi-terminal, random, small-steps >=1.1, text, time, transformers, - tree-diff, unliftio, vector-map, diff --git a/eras/shelley/impl/golden/json/shelley-genesis.json b/eras/shelley/impl/golden/json/shelley-genesis.json new file mode 100644 index 00000000000..03cbfa061e1 --- /dev/null +++ b/eras/shelley/impl/golden/json/shelley-genesis.json @@ -0,0 +1,39 @@ +{ + "activeSlotsCoeff": 0.2, + "protocolParams": { + "protocolVersion": { + "minor": 0, + "major": 2 + }, + "decentralisationParam": 1, + "eMax": 18, + "extraEntropy": { + "tag": "NeutralNonce" + }, + "maxTxSize": 16384, + "maxBlockBodySize": 65536, + "maxBlockHeaderSize": 1100, + "minFeeA": 44, + "minFeeB": 155381, + "minUTxOValue": 1000000, + "poolDeposit": 500000000, + "minPoolCost": 340000000, + "keyDeposit": 2000000, + "nOpt": 150, + "rho": 0.003, + "tau": 0.20, + "a0": 0.3 + }, + "genDelegs": {}, + "updateQuorum": 5, + "networkId": "Testnet", + "initialFunds": {}, + "maxLovelaceSupply": 45000000000000000, + "networkMagic": 123456, + "epochLength": 4320, + "systemStart": "2017-09-23T21:44:51Z", + "slotsPerKESPeriod": 129600, + "slotLength": 1, + "maxKESEvolutions": 62, + "securityParam": 108 +} diff --git a/eras/shelley/impl/test/Main.hs b/eras/shelley/impl/test/Main.hs index 11776e7800b..865138d7d8f 100644 --- a/eras/shelley/impl/test/Main.hs +++ b/eras/shelley/impl/test/Main.hs @@ -7,12 +7,14 @@ import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.JSON (roundTripJsonEraSpec) import qualified Test.Cardano.Ledger.Shelley.Binary.CddlSpec as Cddl import qualified Test.Cardano.Ledger.Shelley.BinarySpec as Binary +import Test.Cardano.Ledger.Shelley.Era.Spec (shelleyEraSpec) import qualified Test.Cardano.Ledger.Shelley.Imp as Imp import Test.Cardano.Ledger.Shelley.JSON (roundTripJsonShelleyEraSpec) main :: IO () main = - ledgerTestMain $ + ledgerTestMain $ do + shelleyEraSpec @ShelleyEra describe "Shelley" $ do Binary.spec Cddl.spec diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Era.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Era.hs index fcdcc9d04e1..f01650f9dc9 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Era.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Era.hs @@ -31,6 +31,7 @@ import Data.Default import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Lens.Micro +import Paths_cardano_ledger_shelley (getDataFileName) import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Era import Test.Cardano.Ledger.Shelley.Arbitrary () @@ -54,6 +55,8 @@ class instance EraTest ShelleyEra where zeroCostModels = emptyCostModels + getEraDataFileName = getDataFileName + mkTestAccountState = mkShelleyTestAccountState accountsFromAccountsMap = shelleyAccountsFromAccountsMap diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Era/Spec.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Era/Spec.hs new file mode 100644 index 00000000000..320a060b66e --- /dev/null +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Era/Spec.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Shelley.Era.Spec ( + shelleyEraSpec, +) where + +import Test.Cardano.Ledger.Era.Spec +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Ledger.Shelley.ImpTest + +-- | This spec is applicable to all eras and will be executed for every era starting with Shelley. +shelleyEraSpec :: forall era. ShelleyEraImp era => Spec +shelleyEraSpec = do + everyEraSpec @era diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs index 993f8d0cd1d..86bb41c0dca 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -20,8 +20,10 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Test.Cardano.Ledger.Shelley.ImpTest ( + module Test.Cardano.Ledger.ImpTest, ImpTestM, LedgerSpec, SomeSTSEvent (..), @@ -29,22 +31,12 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( ImpTestEnv (..), ImpException (..), ShelleyEraImp (..), - PlutusArgs, - ScriptTestContext, impWitsVKeyNeeded, modifyPrevPParams, passEpoch, passNEpochs, passNEpochsChecking, passTick, - freshKeyAddr, - freshKeyAddr_, - freshKeyHash, - freshKeyPair, - getKeyPair, - freshByronKeyHash, - freshBootstapAddress, - getByronKeyPair, freshSafeHash, freshKeyHashVRF, submitTx, @@ -60,9 +52,6 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( getsNES, getUTxO, impAddNativeScript, - impAnn, - impAnnDoc, - impLogToExpr, runImpRule, tryRunImpRule, tryRunImpRuleNoAssertions, @@ -103,7 +92,6 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( defaultInitNewEpochState, defaultInitImpTestState, impEraStartEpochNo, - impSetSeed, modifyImpInitProtVer, modifyImpInitPostSubmitTxHook, disableImpInitPostSubmitTxHook, @@ -118,12 +106,6 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( withEachEraVersion, -- * Logging - Doc, - AnsiStyle, - logDoc, - logText, - logString, - logToExpr, logInstantStake, logFeeMismatch, @@ -137,15 +119,9 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( impNESL, impGlobalsL, impLastTickG, - impKeyPairsG, impNativeScriptsG, produceScript, advanceToPointOfNoReturn, - simulateThenRestore, - - -- * ImpSpec re-exports - ImpM, - ImpInit, ) where import qualified Cardano.Chain.Common as Byron @@ -162,11 +138,10 @@ import Cardano.Ledger.Binary (DecCBOR, EncCBOR) import Cardano.Ledger.Block (Block) import Cardano.Ledger.Coin import Cardano.Ledger.Compactible (fromCompact) -import Cardano.Ledger.Credential (Credential (..), Ptr, StakeReference (..), credToText) -import Cardano.Ledger.Genesis (EraGenesis (..), NoGenesis (..)) +import Cardano.Ledger.Credential (Credential (..), StakeReference (..), credToText) +import Cardano.Ledger.Genesis (EraGenesis (..)) import Cardano.Ledger.Keys ( HasKeyRole (..), - asWitness, bootstrapWitKeyHash, makeBootstrapWitness, witVKeyHash, @@ -202,7 +177,6 @@ import Cardano.Ledger.Shelley.Rules ( epochFromSlot, ) import Cardano.Ledger.Shelley.Scripts ( - ShelleyEraScript, pattern RequireAllOf, pattern RequireAnyOf, pattern RequireMOf, @@ -222,7 +196,7 @@ import Cardano.Slotting.Time (mkSlotLength) import Control.Monad (forM) import Control.Monad.IO.Class import Control.Monad.Reader (MonadReader (..), asks) -import Control.Monad.State.Strict (MonadState (..), evalStateT, get, gets, modify, put) +import Control.Monad.State.Strict (MonadState (..), evalStateT, get, gets, modify) import Control.Monad.Trans.Fail.String (errorFail) import Control.Monad.Trans.Reader (ReaderT (..)) import Control.Monad.Writer.Class (MonadWriter (..)) @@ -234,9 +208,7 @@ import Control.State.Transition.Extended ( ValidationPolicy (..), ) import Data.Bifunctor (first) -import Data.Coerce (coerce) import Data.Data (Proxy (..), type (:~:) (..)) -import Data.Default (Default (..)) import Data.Foldable (toList, traverse_) import Data.Functor (($>)) import Data.Functor.Identity (Identity (..)) @@ -250,24 +222,26 @@ import qualified Data.Sequence.Strict as SSeq import qualified Data.Set as Set import qualified Data.Text as T import Data.Time.Format.ISO8601 (iso8601ParseM) -import Data.TreeDiff (ansiWlExpr) import Data.Type.Equality (TestEquality (..)) import Data.Void import GHC.TypeLits (KnownNat, KnownSymbol, Symbol, symbolVal, type (<=)) import Lens.Micro (Lens', SimpleGetter, lens, to, (%~), (&), (.~), (<>~), (^.)) import Lens.Micro.Mtl (use, view, (%=), (+=), (.=)) import Numeric.Natural (Natural) -import Prettyprinter (Doc) -import Prettyprinter.Render.Terminal (AnsiStyle) import qualified System.Random.Stateful as R import Test.Cardano.Ledger.Binary.RoundTrip (roundTripCborRangeFailureExpectation) import Test.Cardano.Ledger.Core.Arbitrary () import Test.Cardano.Ledger.Core.Binary.RoundTrip (roundTripEraExpectation) -import Test.Cardano.Ledger.Core.KeyPair (ByronKeyPair (..), mkStakeRef, mkWitnessesVKey) +import Test.Cardano.Ledger.Core.KeyPair (ByronKeyPair (..), mkWitnessesVKey) import Test.Cardano.Ledger.Core.Rational ((%!)) -import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash, txInAt) +import Test.Cardano.Ledger.Core.Utils ( + mkDummyTxId, + nextMajorProtVer, + nextMinorProtVer, + txInAt, + ) import Test.Cardano.Ledger.Imp.Common -import Test.Cardano.Ledger.Plutus (PlutusArgs, ScriptTestContext) +import Test.Cardano.Ledger.ImpTest import Test.Cardano.Ledger.Shelley.Era import Test.Cardano.Ledger.Shelley.TreeDiff (Expr (..)) import Test.Cardano.Slotting.Numeric () @@ -284,7 +258,7 @@ instance ShelleyEraImp era => ImpSpec (LedgerSpec era) where type ImpSpecState (LedgerSpec era) = ImpTestState era impInitIO qcGen = do ioGen <- R.newIOGenM qcGen - initState <- evalStateT (runReaderT initImpTestState ioGen) (mempty :: ImpPrepState) + initState <- evalStateT (runReaderT initImpTestState ioGen) (mempty :: KeyPairStore) pure $ ImpInit { impInitEnv = @@ -321,45 +295,15 @@ instance ToExpr (SomeSTSEvent era) where data ImpTestState era = ImpTestState { impNES :: !(NewEpochState era) , impRootTxIn :: !TxIn - , impKeyPairs :: !(Map (KeyHash 'Witness) (KeyPair 'Witness)) - , impByronKeyPairs :: !(Map BootstrapAddress ByronKeyPair) + , impKeyPairStore :: !KeyPairStore , impNativeScripts :: !(Map ScriptHash (NativeScript era)) , impLastTick :: !SlotNo , impGlobals :: !Globals , impEvents :: [SomeSTSEvent era] } --- | This is a preliminary state that is used to prepare the actual `ImpTestState` -data ImpPrepState = ImpPrepState - { impPrepKeyPairs :: !(Map (KeyHash 'Witness) (KeyPair 'Witness)) - , impPrepByronKeyPairs :: !(Map BootstrapAddress ByronKeyPair) - } - -instance Semigroup ImpPrepState where - (<>) ips1 ips2 = - ImpPrepState - { impPrepKeyPairs = impPrepKeyPairs ips1 <> impPrepKeyPairs ips2 - , impPrepByronKeyPairs = impPrepByronKeyPairs ips1 <> impPrepByronKeyPairs ips2 - } - -instance Monoid ImpPrepState where - mempty = - ImpPrepState - { impPrepKeyPairs = mempty - , impPrepByronKeyPairs = mempty - } - -class HasKeyPairs t where - keyPairsL :: Lens' t (Map (KeyHash 'Witness) (KeyPair 'Witness)) - keyPairsByronL :: Lens' t (Map BootstrapAddress ByronKeyPair) - -instance Era era => HasKeyPairs (ImpTestState era) where - keyPairsL = lens impKeyPairs (\x y -> x {impKeyPairs = y}) - keyPairsByronL = lens impByronKeyPairs (\x y -> x {impByronKeyPairs = y}) - -instance HasKeyPairs ImpPrepState where - keyPairsL = lens impPrepKeyPairs (\x y -> x {impPrepKeyPairs = y}) - keyPairsByronL = lens impPrepByronKeyPairs (\x y -> x {impPrepByronKeyPairs = y}) +instance HasKeyPairStore (ImpTestState era) where + keyPairStoreL = lens impKeyPairStore (\x y -> x {impKeyPairStore = y}) impGlobalsL :: Lens' (ImpTestState era) Globals impGlobalsL = lens impGlobals (\x y -> x {impGlobals = y}) @@ -376,12 +320,6 @@ impLastTickG = impLastTickL impRootTxInL :: Lens' (ImpTestState era) TxIn impRootTxInL = lens impRootTxIn (\x y -> x {impRootTxIn = y}) -impKeyPairsG :: - SimpleGetter - (ImpTestState era) - (Map (KeyHash 'Witness) (KeyPair 'Witness)) -impKeyPairsG = to impKeyPairs - impNativeScriptsL :: Lens' (ImpTestState era) (Map ScriptHash (NativeScript era)) impNativeScriptsL = lens impNativeScripts (\x y -> x {impNativeScripts = y}) @@ -393,7 +331,8 @@ impEventsL :: Lens' (ImpTestState era) [SomeSTSEvent era] impEventsL = lens impEvents (\x y -> x {impEvents = y}) class - ( ShelleyEraTxCert era + ( EraImp era + , ShelleyEraTxCert era , ShelleyEraTest era , -- For BBODY rule STS (EraRule "BBODY" era) @@ -435,20 +374,11 @@ class ) => ShelleyEraImp era where - initGenesis :: - (HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) => - m (Genesis era) - default initGenesis :: - (Monad m, Genesis era ~ NoGenesis era) => - m (Genesis era) - initGenesis = pure NoGenesis - initNewEpochState :: - (HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) => + (MonadState KeyPairStore m, HasStatefulGen g m, MonadFail m) => m (NewEpochState era) default initNewEpochState :: - ( HasKeyPairs s - , MonadState s m + ( MonadState KeyPairStore m , HasStatefulGen g m , MonadFail m , ShelleyEraImp (PreviousEra era) @@ -460,8 +390,7 @@ class initNewEpochState = defaultInitNewEpochState id initImpTestState :: - ( HasKeyPairs s - , MonadState s m + ( MonadState KeyPairStore m , HasStatefulGen g m , MonadFail m ) => @@ -491,9 +420,8 @@ class expectTxSuccess :: HasCallStack => Tx era -> ImpTestM era () defaultInitNewEpochState :: - forall era g s m. - ( MonadState s m - , HasKeyPairs s + forall era g m. + ( MonadState KeyPairStore m , HasStatefulGen g m , MonadFail m , ShelleyEraImp era @@ -528,11 +456,10 @@ impEraStartEpochNo = EpochNo (getVersion majProtVer * 100) majProtVer = eraProtVerLow @era defaultInitImpTestState :: - forall era s g m. + forall era g m. ( EraGov era , EraTxOut era - , HasKeyPairs s - , MonadState s m + , MonadState KeyPairStore m , HasStatefulGen g m , MonadFail m ) => @@ -562,8 +489,7 @@ defaultInitImpTestState nes = do ImpTestState { impNES = nesWithRoot , impRootTxIn = rootTxIn - , impKeyPairs = prepState ^. keyPairsL - , impByronKeyPairs = prepState ^. keyPairsByronL + , impKeyPairStore = prepState , impNativeScripts = mempty , impLastTick = slotNo , impGlobals = globals @@ -653,12 +579,10 @@ logInstantStake = do logDoc $ "Instant Stake: " <> ansiExpr stakeDistr mkTxId :: Int -> TxId -mkTxId idx = TxId (mkDummySafeHash idx) +mkTxId = mkDummyTxId +{-# DEPRECATED mkTxId "In favor of `mkDummyTxId`" #-} -instance - ShelleyEraScript ShelleyEra => - ShelleyEraImp ShelleyEra - where +instance EraImp ShelleyEra where initGenesis = do let gen = @@ -679,6 +603,7 @@ instance & ppMinFeeAL .~ Coin 44 & ppMinFeeBL .~ Coin 155_381 & ppMaxBBSizeL .~ 65_536 + & ppMaxBHSizeL .~ 1100 & ppMaxTxSizeL .~ 16_384 & ppKeyDepositL .~ Coin 2_000_000 & ppPoolDepositL .~ Coin 500_000_000 @@ -689,7 +614,7 @@ instance & ppTauL .~ (2 %! 10) & ppDL .~ (1 %! 1) & ppExtraEntropyL .~ NeutralNonce - & ppMinUTxOValueL .~ Coin 2_000_000 + & ppMinUTxOValueL .~ Coin 1_000_000 & ppMinPoolCostL .~ Coin 340_000_000 , -- TODO: Add a top level definition and add private keys to ImpState: sgGenDelegs = mempty @@ -700,6 +625,7 @@ instance Right () -> pure gen Left errs -> fail . T.unpack . T.unlines $ map describeValidationErr errs +instance ShelleyEraImp ShelleyEra where initNewEpochState = do shelleyGenesis <- initGenesis @ShelleyEra let transContext = toFromByronTranslationContext shelleyGenesis @@ -707,7 +633,7 @@ instance pure $ translateToShelleyLedgerStateFromUtxo transContext startEpochNo Byron.empty impSatisfyNativeScript providedVKeyHashes _txBody script = do - keyPairs <- gets impKeyPairs + keyPairs <- gets (keyPairStore . impKeyPairStore) let satisfyMOf m Empty | m <= 0 = Just mempty @@ -1306,127 +1232,15 @@ passNEpochsChecking :: passNEpochsChecking n checks = replicateM_ (fromIntegral n) $ passEpoch >> checks --- | Adds a ToExpr to the log, which is only shown if the test fails -logToExpr :: (HasCallStack, ToExpr a) => a -> ImpM t () -logToExpr = logWithCallStack ?callStack . ansiWlExpr . toExpr - --- | Adds the result of an action to the log, which is only shown if the test fails -impLogToExpr :: (HasCallStack, ToExpr a) => ImpTestM era a -> ImpTestM era a -impLogToExpr action = do - e <- action - logWithCallStack ?callStack . ansiWlExpr . toExpr $ e - pure e - -- | Creates a fresh @SafeHash@ freshSafeHash :: ImpTestM era (SafeHash a) -freshSafeHash = arbitrary +freshSafeHash = genSafeHash +{-# DEPRECATED freshSafeHash "In favor of `genSafeHash`" #-} freshKeyHashVRF :: ImpTestM era (VRFVerKeyHash (r :: KeyRoleVRF)) -freshKeyHashVRF = arbitrary - --- | Adds a key pair to the keyhash lookup map -addKeyPair :: - (HasKeyPairs s, MonadState s m) => - KeyPair r -> - m (KeyHash r) -addKeyPair keyPair@(KeyPair vk _) = do - let keyHash = hashKey vk - modify $ keyPairsL %~ Map.insert (coerceKeyRole keyHash) (coerce keyPair) - pure keyHash - --- | Looks up the `KeyPair` corresponding to the `KeyHash`. The `KeyHash` must be --- created with `freshKeyHash` for this to work. -getKeyPair :: - (HasCallStack, HasKeyPairs s, MonadState s m) => - KeyHash r -> - m (KeyPair r) -getKeyPair keyHash = do - keyPairs <- use keyPairsL - case Map.lookup (asWitness keyHash) keyPairs of - Just keyPair -> pure $ coerce keyPair - Nothing -> - error $ - "Could not find a keypair corresponding to: " - ++ show keyHash - ++ "\nAlways use `freshKeyHash` to create key hashes." - --- | Generates a fresh `KeyHash` and stores the corresponding `KeyPair` in the --- ImpTestState. If you also need the `KeyPair` consider using `freshKeyPair` for --- generation or `getKeyPair` to look up the `KeyPair` corresponding to the `KeyHash` -freshKeyHash :: - forall r s g m. - (HasKeyPairs s, MonadState s m, HasStatefulGen g m) => - m (KeyHash r) -freshKeyHash = fst <$> freshKeyPair - --- | Generate a random `KeyPair` and add it to the known keys in the Imp state -freshKeyPair :: - forall r s g m. - (HasKeyPairs s, MonadState s m, HasStatefulGen g m) => - m (KeyHash r, KeyPair r) -freshKeyPair = do - keyPair <- uniformM - keyHash <- addKeyPair keyPair - pure (keyHash, keyPair) - --- | Generate a random `Addr` that uses a `KeyHash`, and add the corresponding `KeyPair` --- to the known keys in the Imp state. -freshKeyAddr_ :: - (HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) => m Addr -freshKeyAddr_ = snd <$> freshKeyAddr - --- | Generate a random `Addr` that uses a `KeyHash`, add the corresponding `KeyPair` --- to the known keys in the Imp state, and return the `KeyHash` as well as the `Addr`. -freshKeyAddr :: - (HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) => - m (KeyHash 'Payment, Addr) -freshKeyAddr = do - paymentKeyHash <- freshKeyHash @'Payment - stakingKeyHash <- - oneof - [Just . mkStakeRef <$> freshKeyHash @'Staking, Just . mkStakeRef @Ptr <$> arbitrary, pure Nothing] - pure (paymentKeyHash, mkAddr paymentKeyHash stakingKeyHash) - --- | Looks up the keypair corresponding to the `BootstrapAddress`. The `BootstrapAddress` --- must be created with `freshBootstrapAddess` for this to work. -getByronKeyPair :: - (HasCallStack, HasKeyPairs s, MonadState s m) => - BootstrapAddress -> - m ByronKeyPair -getByronKeyPair bootAddr = do - keyPairs <- use keyPairsByronL - case Map.lookup bootAddr keyPairs of - Just keyPair -> pure keyPair - Nothing -> - error $ - "Could not find a keypair corresponding to: " - ++ show bootAddr - ++ "\nAlways use `freshByronKeyHash` to create key hashes." - --- | Generates a fresh `KeyHash` and stores the corresponding `ByronKeyPair` in the --- ImpTestState. If you also need the `ByronKeyPair` consider using `freshByronKeyPair` for --- generation or `getByronKeyPair` to look up the `ByronKeyPair` corresponding to the `KeyHash` -freshByronKeyHash :: - (HasKeyPairs s, MonadState s m, HasStatefulGen g m) => - m (KeyHash r) -freshByronKeyHash = coerceKeyRole . bootstrapKeyHash <$> freshBootstapAddress - -freshBootstapAddress :: - (HasKeyPairs s, MonadState s m, HasStatefulGen g m) => - m BootstrapAddress -freshBootstapAddress = do - keyPair@(ByronKeyPair verificationKey _) <- uniformM - hasPayload <- uniformM - payload <- - if hasPayload - then Just . Byron.HDAddressPayload <$> (uniformByteStringM =<< uniformRM (0, 63)) - else pure Nothing - let asd = Byron.VerKeyASD verificationKey - attrs = Byron.AddrAttributes payload (Byron.NetworkTestnet 0) - bootAddr = BootstrapAddress $ Byron.makeAddress asd attrs - modify $ keyPairsByronL %~ Map.insert bootAddr keyPair - pure bootAddr +freshKeyHashVRF = genVRFVerKeyHash +{-# DEPRECATED freshKeyHashVRF "In favor of `genVRFVerKeyHash`" #-} sendCoinTo :: (ShelleyEraImp era, HasCallStack) => Addr -> Coin -> ImpTestM era TxIn sendCoinTo addr = sendValueTo addr . inject @@ -1529,23 +1343,8 @@ freshPoolParams :: RewardAccount -> ImpTestM era PoolParams freshPoolParams khPool rewardAccount = do - vrfHash <- freshKeyHashVRF - pp <- getsNES $ nesEsL . curPParamsEpochStateL - let minCost = pp ^. ppMinPoolCostL - poolCostExtra <- uniformRM (Coin 0, Coin 100_000_000) - pledge <- uniformRM (Coin 0, Coin 100_000_000) - pure - PoolParams - { ppVrf = vrfHash - , ppRewardAccount = rewardAccount - , ppRelays = mempty - , ppPledge = pledge - , ppOwners = mempty - , ppMetadata = SNothing - , ppMargin = def - , ppId = khPool - , ppCost = minCost <> poolCostExtra - } + ppMinCost <- getsNES $ nesEsL . curPParamsEpochStateL . ppMinPoolCostL + genPoolParams ppMinCost khPool rewardAccount registerPool :: ShelleyEraImp era => @@ -1691,13 +1490,13 @@ advanceToPointOfNoReturn = do -- | A legal ProtVer that differs in the minor Version minorFollow :: ProtVer -> ProtVer -minorFollow (ProtVer x y) = ProtVer x (y + 1) +minorFollow = nextMinorProtVer +{-# DEPRECATED minorFollow "In favor of `nextMinorProtVer`" #-} -- | A legal ProtVer that moves to the next major Version -majorFollow :: ProtVer -> ProtVer -majorFollow pv@(ProtVer x _) = case succVersion x of - Just x' -> ProtVer x' 0 - Nothing -> error ("The last major version can't be incremented. " ++ show pv) +majorFollow :: HasCallStack => ProtVer -> ProtVer +majorFollow = nextMajorProtVer +{-# DEPRECATED majorFollow "In favor of `nextMajorProtVer`" #-} -- | An illegal ProtVer that skips 3 minor versions cantFollow :: ProtVer -> ProtVer @@ -1710,7 +1509,8 @@ whenMajorVersion :: , MinVersion <= v , v <= MaxVersion ) => - ImpTestM era () -> ImpTestM era () + ImpTestM era () -> + ImpTestM era () whenMajorVersion a = do pv <- getProtVer when (pvMajor pv == natVersion @v) a @@ -1722,7 +1522,8 @@ whenMajorVersionAtLeast :: , MinVersion <= v , v <= MaxVersion ) => - ImpTestM era () -> ImpTestM era () + ImpTestM era () -> + ImpTestM era () whenMajorVersionAtLeast a = do pv <- getProtVer when (pvMajor pv >= natVersion @v) a @@ -1734,7 +1535,8 @@ whenMajorVersionAtMost :: , MinVersion <= v , v <= MaxVersion ) => - ImpTestM era () -> ImpTestM era () + ImpTestM era () -> + ImpTestM era () whenMajorVersionAtMost a = do pv <- getProtVer when (pvMajor pv <= natVersion @v) a @@ -1746,25 +1548,11 @@ unlessMajorVersion :: , MinVersion <= v , v <= MaxVersion ) => - ImpTestM era () -> ImpTestM era () + ImpTestM era () -> + ImpTestM era () unlessMajorVersion a = do pv <- getProtVer unless (pvMajor pv == natVersion @v) a getsPParams :: EraGov era => Lens' (PParams era) a -> ImpTestM era a getsPParams f = getsNES $ nesEsL . curPParamsEpochStateL . f - --- | Runs a simulation action and then restores the ledger state to what it was --- before the simulation started. --- This is useful for testing or running actions whose effects on the ledger --- state should not persist. The return value of the simulation is preserved, --- but any changes to the internal state (e.g., the UTxO set, protocol parameters, --- etc.) are discarded and replaced with the original snapshot. -simulateThenRestore :: - ImpTestM era a -> - ImpTestM era a -simulateThenRestore sim = do - snapshot <- get - result <- sim - put snapshot - pure result diff --git a/flake.lock b/flake.lock index c09536757f1..231cc75f762 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1749631879, - "narHash": "sha256-H7dxW3fRA8/U4u4GaR+YVnu6aKkev4GPTPgY524V5uM=", + "lastModified": 1755197699, + "narHash": "sha256-Qpmv1zYOfOzYZfU3sB3bsv/sGtI1c6MGTFiyhnYmmRA=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "2d1517e42e1ed5b19deb29c1c4fc9e30d360b961", + "rev": "982aa1c76e28e26e592e26e8fd8b73eea87dbdc2", "type": "github" }, "original": { @@ -275,11 +275,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1749687986, - "narHash": "sha256-cEt2Hhbc0w0SqiadjZg4TJyn2+rKxW/15nmu4an79wo=", + "lastModified": 1755034186, + "narHash": "sha256-07S5E6JWzaWzpkhXGe7wE9fRzY+h5kp8mkwt7NL6d/s=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "0949afe39e6d249b6db126a96646d3f51a4a4c11", + "rev": "32fa0e79c843f1c4b75f30984762aa6d1154406f", "type": "github" }, "original": { diff --git a/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx/AuxData.hs b/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx/AuxData.hs index 9ebe7c4076f..5315473b9c7 100644 --- a/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx/AuxData.hs +++ b/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx/AuxData.hs @@ -4,6 +4,7 @@ module Cardano.Ledger.Api.Tx.AuxData ( metadataTxAuxDataL, hashTxAuxData, validateTxAuxData, + ensureAuxDataHash, -- * Shelley ShelleyTxAuxData (..), @@ -36,3 +37,4 @@ import Cardano.Ledger.Alonzo.TxAuxData ( import Cardano.Ledger.Api.Era (EraApi (..)) import Cardano.Ledger.Core (EraTxAuxData (..), binaryUpgradeTxAuxData, hashTxAuxData) import Cardano.Ledger.Shelley.TxAuxData (Metadatum (..), ShelleyTxAuxData (..)) +import Cardano.Ledger.Tools (ensureAuxDataHash) diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index e97f255aef6..c863cd6b94e 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -180,7 +180,9 @@ library testlib Test.Cardano.Ledger.Core.Rational Test.Cardano.Ledger.Core.Utils Test.Cardano.Ledger.Era + Test.Cardano.Ledger.Era.Spec Test.Cardano.Ledger.Imp.Common + Test.Cardano.Ledger.ImpTest Test.Cardano.Ledger.Plutus Test.Cardano.Ledger.Plutus.Examples Test.Cardano.Ledger.Plutus.Guardrail @@ -215,20 +217,24 @@ library testlib cardano-ledger-binary:{cardano-ledger-binary, testlib} >=1.5, cardano-ledger-byron:{cardano-ledger-byron, testlib}, cardano-ledger-core, - cardano-slotting, + cardano-slotting:{cardano-slotting, testlib}, containers, cuddle >=0.4, data-default, deepseq, + filepath, generic-random, genvalidity, hedgehog-quickcheck, heredoc, hspec, microlens, + microlens-mtl, mtl, nothunks, plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib}, + prettyprinter, + prettyprinter-ansi-terminal, primitive, quickcheck-transformer, random ^>=1.2, diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Genesis.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Genesis.hs index 970843b2dbe..f8b5f255402 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Genesis.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Genesis.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -22,6 +23,7 @@ import Cardano.Ledger.Binary ( ToCBOR (..), ) import Cardano.Ledger.Core.Era (Era) +import Control.DeepSeq (NFData (..), rwhnf) import Control.Monad (unless) import Data.Aeson ( FromJSON (..), @@ -32,7 +34,19 @@ import qualified Data.Aeson.KeyMap as KV import Data.Kind (Type) import Data.Typeable -class Era era => EraGenesis era where +class + ( Era era + , Eq (Genesis era) + , Show (Genesis era) + , Typeable (Genesis era) + , ToCBOR (Genesis era) + , FromCBOR (Genesis era) + , ToJSON (Genesis era) + , FromJSON (Genesis era) + , NFData (Genesis era) + ) => + EraGenesis era + where type Genesis era :: Type type Genesis era = NoGenesis era @@ -40,6 +54,9 @@ data NoGenesis era = NoGenesis deriving (Eq, Show) deriving (ToJSON) via KeyValuePairs (NoGenesis era) +instance NFData (NoGenesis era) where + rnf = rwhnf + instance Era era => ToCBOR (NoGenesis era) where toCBOR _ = toCBOR () diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Tools.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Tools.hs index 562e94ec070..35c657b4d01 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Tools.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Tools.hs @@ -12,6 +12,7 @@ module Cardano.Ledger.Tools ( calcMinFeeTxNativeScriptWits, estimateMinFeeTx, addDummyWitsTx, + ensureAuxDataHash, -- * TxOut setMinCoinTxOut, @@ -27,7 +28,7 @@ module Cardano.Ledger.Tools ( import qualified Cardano.Chain.Common as Byron import Cardano.Crypto.DSIGN.Class (sizeSigDSIGN, sizeVerKeyDSIGN) import Cardano.Ledger.Address (BootstrapAddress (..), bootstrapKeyHash) -import Cardano.Ledger.BaseTypes (ProtVer (..)) +import Cardano.Ledger.BaseTypes (ProtVer (..), StrictMaybe (..)) import Cardano.Ledger.Binary (byronProtVer, decodeFull', serialize') import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Core @@ -223,6 +224,15 @@ estimateMinFeeTx pp tx numKeyWits numByronKeyWits refScriptsSize = , Byron.aaNetworkMagic = Byron.NetworkTestnet maxBound } +-- | Sets an auxiliary data hash to the transaction if auxiliary data present, while the hash of it +-- is not. +ensureAuxDataHash :: EraTx era => Tx era -> Tx era +ensureAuxDataHash tx + | SNothing <- tx ^. bodyTxL . auxDataHashTxBodyL + , SJust auxData <- tx ^. auxDataTxL = + tx & bodyTxL . auxDataHashTxBodyL .~ SJust (TxAuxDataHash (hashAnnotated auxData)) + | otherwise = tx + integralToByteStringN :: (Integral i, Bits i) => Int -> i -> ByteString integralToByteStringN len = fst . BS.unfoldrN len (\n -> Just (fromIntegral n, n `shiftR` 8)) diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/JSON.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/JSON.hs index e8658584d00..5ea64b11166 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/JSON.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/JSON.hs @@ -10,11 +10,15 @@ module Test.Cardano.Ledger.Core.JSON ( roundTripJsonProperty, goldenJsonPParamsSpec, goldenJsonPParamsUpdateSpec, + goldenJsonExpectation, + goldenToJsonExpectation, + goldenFromJsonExpectation, ) where import Cardano.Ledger.Core import Data.Aeson (FromJSON, ToJSON, eitherDecode, eitherDecodeFileStrict, encode) import Data.Aeson.Encode.Pretty (encodePretty) +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Function ((&)) import qualified Data.Text as T @@ -78,7 +82,22 @@ goldenJsonPParamsUpdateSpec :: SpecWith FilePath goldenJsonPParamsUpdateSpec = it "Golden JSON specs for PParamsUpdate" $ \file -> do - let ppu = runGen 100 100 (arbitrary @(PParamsUpdate era)) - let encoded = T.decodeUtf8 (BSL.toStrict (encodePretty ppu)) <> "\n" - fileContent <- T.decodeUtf8 . BSL.toStrict <$> BSL.readFile file - encoded `shouldBe` fileContent + goldenToJsonExpectation file $ runGen 100 100 (arbitrary @(PParamsUpdate era)) + +goldenToJsonExpectation :: (HasCallStack, ToJSON a) => FilePath -> a -> Expectation +goldenToJsonExpectation filePath value = do + let encoded = T.decodeUtf8 (BSL.toStrict (encodePretty value)) <> "\n" + fileContent <- T.decodeUtf8 <$> BS.readFile filePath + fileContent `shouldBe` encoded + +goldenFromJsonExpectation :: + (HasCallStack, FromJSON a, Show a, Eq a) => FilePath -> a -> Expectation +goldenFromJsonExpectation filePath expectedValue = do + decodedValue <- expectRight =<< eitherDecodeFileStrict filePath + decodedValue `shouldBe` expectedValue + +goldenJsonExpectation :: + (HasCallStack, ToJSON a, FromJSON a, Show a, Eq a) => FilePath -> a -> Expectation +goldenJsonExpectation filePath expectedValue = do + decodedValue <- expectRight =<< eitherDecodeFileStrict filePath + decodedValue `shouldBe` expectedValue diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Utils.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Utils.hs index fb54775e974..92a5f7aefdc 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Utils.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Utils.hs @@ -6,21 +6,27 @@ module Test.Cardano.Ledger.Core.Utils ( unsafeBoundRational, testGlobals, mkDummySafeHash, + mkDummyTxId, txInAt, + nextMajorProtVer, + nextMinorProtVer, ) where import Cardano.Ledger.BaseTypes ( EpochSize (..), Globals (..), Network (..), + ProtVer (..), knownNonZeroBounded, mkActiveSlotCoeff, + succVersion, ) import Cardano.Ledger.Core import Cardano.Ledger.Hashes (unsafeMakeSafeHash) -import Cardano.Ledger.TxIn (TxIn, mkTxInPartial) +import Cardano.Ledger.TxIn (TxId (..), TxIn, mkTxInPartial) import Cardano.Slotting.EpochInfo (fixedEpochInfo) import Cardano.Slotting.Time (SystemStart (..), mkSlotLength) +import Control.Monad.Trans.Fail.String (errorFail) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Test.Cardano.Ledger.Binary.Random (mkDummyHash) import Test.Cardano.Ledger.Common @@ -45,7 +51,21 @@ testGlobals = mkDummySafeHash :: forall a. Int -> SafeHash a mkDummySafeHash = unsafeMakeSafeHash . mkDummyHash @HASH +mkDummyTxId :: Int -> TxId +mkDummyTxId idx = TxId (mkDummySafeHash idx) + txInAt :: (HasCallStack, EraTx era) => Int -> Tx era -> TxIn txInAt index tx = let txId = txIdTx tx in mkTxInPartial txId (toInteger index) + +-- | A legal ProtVer that moves to the next major Version. Throws an error when already at the +-- latest possible major version +nextMajorProtVer :: HasCallStack => ProtVer -> ProtVer +nextMajorProtVer (ProtVer majorVersion _) = errorFail $ do + nextMajorVersion <- succVersion majorVersion + pure $ ProtVer nextMajorVersion 0 + +-- | A legal ProtVer that differs in the minor Version +nextMinorProtVer :: ProtVer -> ProtVer +nextMinorProtVer protVer = protVer {pvMinor = pvMinor protVer + 1} diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs index 6d2f24103c2..a647996707c 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs @@ -92,6 +92,11 @@ class where zeroCostModels :: CostModels + -- | Produce the full file path from relative path for the package. This has only one legitimate + -- implementation, namely @getDataFileName@ that is imported from @Paths_cardano_ledger_[era]@ + -- module. + getEraDataFileName :: FilePath -> IO FilePath + -- | This is a helper function that allows for creation of an `AccountState` in era agnostic -- fashion. There is no equivalent function outside of testing since arguments required for -- creation of `AccountState` varies between eras and we can get away with such function in diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era/Spec.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era/Spec.hs new file mode 100644 index 00000000000..fedd61706a0 --- /dev/null +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era/Spec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Era.Spec ( + everyEraSpec, + goldenFilePath, + goldenJsonFilePath, +) where + +import Cardano.Ledger.Core +import Cardano.Ledger.Genesis +import Control.Monad.IO.Class +import Data.Aeson (eitherDecodeFileStrict', encode) +import Data.Char (toLower) +import System.FilePath (()) +import Test.Cardano.Ledger.Era +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Ledger.ImpTest + +goldenFilePath :: FilePath +goldenFilePath = "golden" + +goldenJsonFilePath :: FilePath +goldenJsonFilePath = goldenFilePath "json" + +-- | This spec is applicable to all eras and will be executed for every era starting with Shelley. +everyEraSpec :: forall era. EraImp era => Spec +everyEraSpec = + describe "Spec for every Era" $ do + let eraLowerName = map toLower $ eraName @era + describe "JSON" $ do + describe "Golden" $ do + withImpInit @KeyPairSpec $ do + it "Genesis" $ do + let decodeJsonGenesis = do + eitherGenesis <- + liftIO $ do + genesisFilePath <- + getEraDataFileName @era $ + goldenJsonFilePath eraLowerName <> "-genesis.json" + eitherDecodeFileStrict' genesisFilePath + expectRightDeep eitherGenesis + genesis <- impAnn "Initializing Genesis" $ initGenesis @era + mkGenesisWith @era decodeJsonGenesis `shouldReturn` genesis diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs new file mode 100644 index 00000000000..7b7860d6d42 --- /dev/null +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Test.Cardano.Ledger.ImpTest ( + EraImp (..), + KeyPairSpec, + KeyPairStore (..), + HasKeyPairStore (..), + keyPairsL, + keyPairsByronL, + freshKeyAddr, + freshKeyAddr_, + freshKeyHash, + freshKeyPair, + getKeyPair, + freshByronKeyHash, + freshBootstapAddress, + getByronKeyPair, + impAnn, + impAnnDoc, + impLogToExpr, + impSetSeed, + genSafeHash, + genVRFVerKeyHash, + genPoolParams, + genProtVerCantFollow, + + -- * Logging + Doc, + AnsiStyle, + logDoc, + logText, + logString, + logToExpr, + + -- * Combinators + simulateThenRestore, + + -- * ImpSpec re-exports + ImpM, + ImpInit, + ImpException (..), +) where + +import qualified Cardano.Chain.Common as Byron +import Cardano.Ledger.Address +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Coin +import Cardano.Ledger.Core +import Cardano.Ledger.Credential (Ptr) +import Cardano.Ledger.Genesis (EraGenesis (..), NoGenesis (..)) +import Cardano.Ledger.Keys (HasKeyRole (..), asWitness) +import Cardano.Ledger.State +import Control.Monad.State.Strict (MonadState (..), get, modify, put) +import Data.Coerce (coerce) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Proxy +import Data.TreeDiff (ansiWlExpr) +import Lens.Micro (Lens', lens, (%~)) +import Lens.Micro.Mtl (use) +import Prettyprinter (Doc) +import Prettyprinter.Render.Terminal (AnsiStyle) +import Test.Cardano.Ledger.Core.Arbitrary () +import Test.Cardano.Ledger.Core.KeyPair (ByronKeyPair (..), mkStakeRef) +import Test.Cardano.Ledger.Era (EraTest) +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Slotting.Numeric () +import Test.ImpSpec + +-- | ImpSpec for tests that need access to a KeyPair store. +data KeyPairSpec + +-- | This is a preliminary state that is used to prepare the actual `ImpTestState` +data KeyPairStore = KeyPairStore + { keyPairStore :: !(Map (KeyHash 'Witness) (KeyPair 'Witness)) + , keyPairByronStore :: !(Map BootstrapAddress ByronKeyPair) + } + +instance Semigroup KeyPairStore where + (<>) ips1 ips2 = + KeyPairStore + { keyPairStore = keyPairStore ips1 <> keyPairStore ips2 + , keyPairByronStore = keyPairByronStore ips1 <> keyPairByronStore ips2 + } + +instance Monoid KeyPairStore where + mempty = + KeyPairStore + { keyPairStore = mempty + , keyPairByronStore = mempty + } + +instance ImpSpec KeyPairSpec where + type ImpSpecState KeyPairSpec = KeyPairStore + impInitIO _qcGen = + pure $ + ImpInit + { impInitEnv = Proxy + , impInitState = mempty + } + +class HasKeyPairStore t where + keyPairStoreL :: Lens' t KeyPairStore + +keyPairsL :: HasKeyPairStore t => Lens' t (Map (KeyHash 'Witness) (KeyPair 'Witness)) +keyPairsL = keyPairStoreL . lens keyPairStore (\x y -> x {keyPairStore = y}) + +keyPairsByronL :: HasKeyPairStore t => Lens' t (Map BootstrapAddress ByronKeyPair) +keyPairsByronL = keyPairStoreL . lens keyPairByronStore (\x y -> x {keyPairByronStore = y}) + +instance HasKeyPairStore KeyPairStore where + keyPairStoreL = id + +class EraTest era => EraImp era where + initGenesis :: + (HasKeyPairStore s, MonadState s m, HasStatefulGen g m, MonadFail m) => + m (Genesis era) + default initGenesis :: + (Monad m, Genesis era ~ NoGenesis era) => + m (Genesis era) + initGenesis = pure NoGenesis + +-- | Adds a ToExpr to the log, which is only shown if the test fails +logToExpr :: (HasCallStack, ToExpr a) => a -> ImpM t () +logToExpr = logWithCallStack ?callStack . ansiWlExpr . toExpr + +-- | Adds the result of an action to the log, which is only shown if the test fails +impLogToExpr :: (HasCallStack, ToExpr a) => ImpM t a -> ImpM t a +impLogToExpr action = do + e <- action + logWithCallStack ?callStack . ansiWlExpr $ toExpr e + pure e + +-- | Generates a random @SafeHash@ +genSafeHash :: MonadGen m => m (SafeHash a) +genSafeHash = arbitrary + +-- | Generates a random @VRFVerKeyHash@ +genVRFVerKeyHash :: MonadGen m => m (VRFVerKeyHash (r :: KeyRoleVRF)) +genVRFVerKeyHash = arbitrary + +genPoolParams :: + MonadGen m => + Coin -> + KeyHash 'StakePool -> + RewardAccount -> + m PoolParams +genPoolParams ppMinCost khPool rewardAccount = do + vrfHash <- genVRFVerKeyHash + poolCostExtra <- arbitrary + pledge <- arbitrary + margin <- arbitrary + pure + PoolParams + { ppVrf = vrfHash + , ppRewardAccount = rewardAccount + , ppRelays = mempty + , ppPledge = pledge + , ppOwners = mempty + , ppMetadata = SNothing + , ppMargin = margin + , ppId = khPool + , ppCost = ppMinCost <> poolCostExtra + } + +-- | Adds a key pair to the keyhash lookup map +addKeyPair :: + (HasKeyPairStore s, MonadState s m) => + KeyPair r -> + m (KeyHash r) +addKeyPair keyPair@(KeyPair vk _) = do + let keyHash = hashKey vk + modify $ keyPairsL %~ Map.insert (coerceKeyRole keyHash) (coerce keyPair) + pure keyHash + +-- | Looks up the `KeyPair` corresponding to the `KeyHash`. The `KeyHash` must be +-- created with `freshKeyHash` for this to work. +getKeyPair :: + (HasCallStack, HasKeyPairStore s, MonadState s m) => + KeyHash r -> + m (KeyPair r) +getKeyPair keyHash = do + keyPairs <- use keyPairsL + case Map.lookup (asWitness keyHash) keyPairs of + Just keyPair -> pure $ coerce keyPair + Nothing -> + error $ + "Could not find a keypair corresponding to: " + ++ show keyHash + ++ "\nAlways use `freshKeyHash` to create key hashes." + +-- | Generates a fresh `KeyHash` and stores the corresponding `KeyPair` in the +-- ImpTestState. If you also need the `KeyPair` consider using `freshKeyPair` for +-- generation or `getKeyPair` to look up the `KeyPair` corresponding to the `KeyHash` +freshKeyHash :: + forall r s g m. + (HasKeyPairStore s, MonadState s m, HasStatefulGen g m) => + m (KeyHash r) +freshKeyHash = fst <$> freshKeyPair + +-- | Generate a random `KeyPair` and add it to the known keys in the Imp state +freshKeyPair :: + forall r s g m. + (HasKeyPairStore s, MonadState s m, HasStatefulGen g m) => + m (KeyHash r, KeyPair r) +freshKeyPair = do + keyPair <- uniformM + keyHash <- addKeyPair keyPair + pure (keyHash, keyPair) + +-- | Generate a random `Addr` that uses a `KeyHash`, and add the corresponding `KeyPair` +-- to the known keys in the Imp state. +freshKeyAddr_ :: + (HasKeyPairStore s, MonadState s m, HasStatefulGen g m, MonadGen m) => m Addr +freshKeyAddr_ = snd <$> freshKeyAddr + +-- | Generate a random `Addr` that uses a `KeyHash`, add the corresponding `KeyPair` +-- to the known keys in the Imp state, and return the `KeyHash` as well as the `Addr`. +freshKeyAddr :: + (HasKeyPairStore s, MonadState s m, HasStatefulGen g m, MonadGen m) => + m (KeyHash 'Payment, Addr) +freshKeyAddr = do + paymentKeyHash <- freshKeyHash @'Payment + stakingKeyHash <- + oneof + [Just . mkStakeRef <$> freshKeyHash @'Staking, Just . mkStakeRef @Ptr <$> arbitrary, pure Nothing] + pure (paymentKeyHash, mkAddr paymentKeyHash stakingKeyHash) + +-- | Looks up the keypair corresponding to the `BootstrapAddress`. The `BootstrapAddress` +-- must be created with `freshBootstrapAddess` for this to work. +getByronKeyPair :: + (HasCallStack, HasKeyPairStore s, MonadState s m) => + BootstrapAddress -> + m ByronKeyPair +getByronKeyPair bootAddr = do + keyPairs <- use keyPairsByronL + case Map.lookup bootAddr keyPairs of + Just keyPair -> pure keyPair + Nothing -> + error $ + "Could not find a keypair corresponding to: " + ++ show bootAddr + ++ "\nAlways use `freshByronKeyHash` to create key hashes." + +-- | Generates a fresh `KeyHash` and stores the corresponding `ByronKeyPair` in the +-- ImpTestState. If you also need the `ByronKeyPair` consider using `freshByronKeyPair` for +-- generation or `getByronKeyPair` to look up the `ByronKeyPair` corresponding to the `KeyHash` +freshByronKeyHash :: + (HasKeyPairStore s, MonadState s m, HasStatefulGen g m) => + m (KeyHash r) +freshByronKeyHash = coerceKeyRole . bootstrapKeyHash <$> freshBootstapAddress + +freshBootstapAddress :: + (HasKeyPairStore s, MonadState s m, HasStatefulGen g m) => + m BootstrapAddress +freshBootstapAddress = do + keyPair@(ByronKeyPair verificationKey _) <- uniformM + hasPayload <- uniformM + payload <- + if hasPayload + then Just . Byron.HDAddressPayload <$> (uniformByteStringM =<< uniformRM (0, 63)) + else pure Nothing + let asd = Byron.VerKeyASD verificationKey + attrs = Byron.AddrAttributes payload (Byron.NetworkTestnet 0) + bootAddr = BootstrapAddress $ Byron.makeAddress asd attrs + modify $ keyPairsByronL %~ Map.insert bootAddr keyPair + pure bootAddr + +-- | An illegal ProtVer that skips 3 minor versions +genProtVerCantFollow :: MonadGen m => ProtVer -> m ProtVer +genProtVerCantFollow (ProtVer x y) = + -- TODO Generate at random + pure $ ProtVer x (y + 3) + +-- | Runs a simulation action and then restores the ImpSpec state to what it was before the +-- simulation started. This is useful for testing or running actions whose effects on the state +-- should not persist. The return value of the simulation is preserved, but any changes to the +-- internal state are discarded and replaced with the original snapshot. +simulateThenRestore :: + ImpM t a -> + ImpM t a +simulateThenRestore simulate = do + stateSnapshot <- get + result <- simulate + result <$ put stateSnapshot