From fb69974c1744a6be0730d73a28e7299ef2064ae6 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 12 Aug 2025 16:54:53 -0600 Subject: [PATCH 01/10] Update CHaP and Hackage Update to latest CHaP to get plutus-1.52 --- cabal.project | 4 ++-- flake.lock | 12 ++++++------ 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/cabal.project b/cabal.project index 47494ceaddd..98bc84c9b42 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 == 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": { From 76b9de01f018c6c3438eb09d9d57b8a23a8a4f5c Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Mon, 18 Aug 2025 15:09:51 -0600 Subject: [PATCH 02/10] Workaround a bug in `plutus-core` These are unfortunate changes that we need to add due to confliciting constraints in `plutus-core` in order to bring in newer version. Source of the problem stems from changes to CHaP: https://github.com/IntersectMBO/cardano-haskell-packages/issues/1123 --- cabal.project | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/cabal.project b/cabal.project index 98bc84c9b42..a3b781c28b3 100644 --- a/cabal.project +++ b/cabal.project @@ -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, From 6f2a5343349a8d2265f632e3068f646b74863d08 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 13 Aug 2025 13:50:52 -0600 Subject: [PATCH 03/10] Introduce `getEraDataFileName` --- eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Era.hs | 3 +++ eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Era.hs | 3 +++ eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Era.hs | 4 ++++ eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Era.hs | 3 +++ eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/Era.hs | 3 +++ eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Era.hs | 3 +++ eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Era.hs | 3 +++ libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs | 5 +++++ 8 files changed, 27 insertions(+) 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/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/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/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/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/mary/impl/testlib/Test/Cardano/Ledger/Mary/Era.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Era.hs index 2772d9f4d54..a1606c07df3 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Era.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Era.hs @@ -12,6 +12,7 @@ import Cardano.Ledger.Plutus (emptyCostModels) import Test.Cardano.Ledger.Allegra.Era import Test.Cardano.Ledger.Mary.Arbitrary () import Test.Cardano.Ledger.Mary.TreeDiff () +import Paths_cardano_ledger_mary class ( AllegraEraTest era @@ -22,6 +23,8 @@ class instance EraTest MaryEra where zeroCostModels = emptyCostModels + getEraDataFileName = getDataFileName + mkTestAccountState = mkShelleyTestAccountState accountsFromAccountsMap = shelleyAccountsFromAccountsMap 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..9e7dc3557d9 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Era.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Era.hs @@ -35,6 +35,7 @@ import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Era import Test.Cardano.Ledger.Shelley.Arbitrary () import Test.Cardano.Ledger.Shelley.TreeDiff () +import Paths_cardano_ledger_shelley (getDataFileName) class ( EraTest era @@ -54,6 +55,8 @@ class instance EraTest ShelleyEra where zeroCostModels = emptyCostModels + getEraDataFileName = getDataFileName + mkTestAccountState = mkShelleyTestAccountState accountsFromAccountsMap = shelleyAccountsFromAccountsMap 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 From d4c70db7b20af952f109b2159ac3a40ec2548525 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 13 Aug 2025 14:07:26 -0600 Subject: [PATCH 04/10] Make a copy of ImpTest module from Shelley This will be used to transfer some of the functionality into `cardano-ledger-core` in a subsequent commit in order to preserve git history --- .../testlib/Test/Cardano/Ledger/ImpTest.hs | 1770 +++++++++++++++++ 1 file changed, 1770 insertions(+) create mode 100644 libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs 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..993f8d0cd1d --- /dev/null +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs @@ -0,0 +1,1770 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Test.Cardano.Ledger.Shelley.ImpTest ( + ImpTestM, + LedgerSpec, + SomeSTSEvent (..), + ImpTestState, + ImpTestEnv (..), + ImpException (..), + ShelleyEraImp (..), + PlutusArgs, + ScriptTestContext, + impWitsVKeyNeeded, + modifyPrevPParams, + passEpoch, + passNEpochs, + passNEpochsChecking, + passTick, + freshKeyAddr, + freshKeyAddr_, + freshKeyHash, + freshKeyPair, + getKeyPair, + freshByronKeyHash, + freshBootstapAddress, + getByronKeyPair, + freshSafeHash, + freshKeyHashVRF, + submitTx, + submitTx_, + submitTxAnn, + submitTxAnn_, + submitFailingTx, + submitFailingTxM, + trySubmitTx, + impShelleyExpectTxSuccess, + modifyNES, + getProtVer, + getsNES, + getUTxO, + impAddNativeScript, + impAnn, + impAnnDoc, + impLogToExpr, + runImpRule, + tryRunImpRule, + tryRunImpRuleNoAssertions, + delegateStake, + registerRewardAccount, + registerStakeCredential, + getRewardAccountFor, + getReward, + lookupReward, + freshPoolParams, + registerPool, + registerPoolWithRewardAccount, + registerAndRetirePoolToMakeReward, + getBalance, + lookupBalance, + getAccountBalance, + lookupAccountBalance, + getRewardAccountAmount, + shelleyFixupTx, + getImpRootTxOut, + sendValueTo, + sendValueTo_, + sendCoinTo, + sendCoinTo_, + expectUTxOContent, + expectRegisteredRewardAddress, + expectNotRegisteredRewardAddress, + expectTreasury, + disableTreasuryExpansion, + updateAddrTxWits, + addNativeScriptTxWits, + addRootTxIn, + fixupTxOuts, + fixupFees, + fixupAuxDataHash, + impLookupNativeScript, + impGetUTxO, + defaultInitNewEpochState, + defaultInitImpTestState, + impEraStartEpochNo, + impSetSeed, + modifyImpInitProtVer, + modifyImpInitPostSubmitTxHook, + disableImpInitPostSubmitTxHook, + minorFollow, + majorFollow, + cantFollow, + whenMajorVersion, + whenMajorVersionAtLeast, + whenMajorVersionAtMost, + unlessMajorVersion, + getsPParams, + withEachEraVersion, + + -- * Logging + Doc, + AnsiStyle, + logDoc, + logText, + logString, + logToExpr, + logInstantStake, + logFeeMismatch, + + -- * Combinators + withCustomFixup, + withFixup, + withNoFixup, + withPostFixup, + withPreFixup, + withCborRoundTripFailures, + impNESL, + impGlobalsL, + impLastTickG, + impKeyPairsG, + impNativeScriptsG, + produceScript, + advanceToPointOfNoReturn, + simulateThenRestore, + + -- * ImpSpec re-exports + ImpM, + ImpInit, +) where + +import qualified Cardano.Chain.Common as Byron +import qualified Cardano.Chain.UTxO as Byron (empty) +import Cardano.Ledger.Address ( + Addr (..), + BootstrapAddress (..), + RewardAccount (..), + bootstrapKeyHash, + ) +import Cardano.Ledger.BHeaderView (BHeaderView) +import Cardano.Ledger.BaseTypes +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.Keys ( + HasKeyRole (..), + asWitness, + bootstrapWitKeyHash, + makeBootstrapWitness, + witVKeyHash, + ) +import Cardano.Ledger.Shelley (ShelleyEra) +import Cardano.Ledger.Shelley.API.ByronTranslation (translateToShelleyLedgerStateFromUtxo) +import Cardano.Ledger.Shelley.AdaPots (sumAdaPots, totalAdaPotsES) +import Cardano.Ledger.Shelley.Core +import Cardano.Ledger.Shelley.Genesis ( + ShelleyGenesis (..), + describeValidationErr, + fromNominalDiffTimeMicro, + mkShelleyGlobals, + validateGenesis, + ) +import Cardano.Ledger.Shelley.LedgerState ( + LedgerState (..), + NewEpochState (..), + curPParamsEpochStateL, + esLStateL, + lsCertStateL, + lsUTxOStateL, + nesELL, + nesEsL, + prevPParamsEpochStateL, + produced, + utxosDonationL, + ) +import Cardano.Ledger.Shelley.Rules ( + BbodyEnv (..), + LedgerEnv (..), + ShelleyBbodyState, + epochFromSlot, + ) +import Cardano.Ledger.Shelley.Scripts ( + ShelleyEraScript, + pattern RequireAllOf, + pattern RequireAnyOf, + pattern RequireMOf, + pattern RequireSignature, + ) +import Cardano.Ledger.Shelley.State hiding (balance) +import Cardano.Ledger.Shelley.Translation (toFromByronTranslationContext) +import Cardano.Ledger.Slot (epochInfoFirst, getTheSlotOfNoReturn) +import Cardano.Ledger.Tools ( + calcMinFeeTxNativeScriptWits, + ensureMinCoinTxOut, + ) +import Cardano.Ledger.TxIn (TxId (..), TxIn (..)) +import Cardano.Ledger.Val (Val (..)) +import Cardano.Slotting.EpochInfo (fixedEpochInfo) +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.Trans.Fail.String (errorFail) +import Control.Monad.Trans.Reader (ReaderT (..)) +import Control.Monad.Writer.Class (MonadWriter (..)) +import Control.State.Transition (STS (..), TRC (..), applySTSOptsEither) +import Control.State.Transition.Extended ( + ApplySTSOpts (..), + AssertionPolicy (..), + SingEP (..), + 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 (..)) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, isNothing, mapMaybe) +import Data.Ratio ((%)) +import Data.Sequence.Strict (StrictSeq (..)) +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.Rational ((%!)) +import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash, txInAt) +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Ledger.Plutus (PlutusArgs, ScriptTestContext) +import Test.Cardano.Ledger.Shelley.Era +import Test.Cardano.Ledger.Shelley.TreeDiff (Expr (..)) +import Test.Cardano.Slotting.Numeric () +import Test.ImpSpec +import Type.Reflection (Typeable, typeOf) +import UnliftIO (evaluateDeep) + +type ImpTestM era = ImpM (LedgerSpec era) + +data LedgerSpec era + +instance ShelleyEraImp era => ImpSpec (LedgerSpec era) where + type ImpSpecEnv (LedgerSpec era) = ImpTestEnv era + type ImpSpecState (LedgerSpec era) = ImpTestState era + impInitIO qcGen = do + ioGen <- R.newIOGenM qcGen + initState <- evalStateT (runReaderT initImpTestState ioGen) (mempty :: ImpPrepState) + pure $ + ImpInit + { impInitEnv = + ImpTestEnv + { iteFixup = fixupTx + , iteCborRoundTripFailures = True + , itePostSubmitTxHook = \_ _ _ -> pure () + } + , impInitState = initState + } + + -- There is an important step here of running TICK rule. This is necessary as a final + -- step of `era` initialization, because on the very first TICK of an era the + -- `futurePParams` are applied and the epoch number is updated to the first epoch + -- number of the current era + impPrepAction = passTick + +data SomeSTSEvent era + = forall (rule :: Symbol). + ( Typeable (Event (EraRule rule era)) + , Eq (Event (EraRule rule era)) + , ToExpr (Event (EraRule rule era)) + ) => + SomeSTSEvent (Event (EraRule rule era)) + +instance Eq (SomeSTSEvent era) where + SomeSTSEvent x == SomeSTSEvent y + | Just Refl <- testEquality (typeOf x) (typeOf y) = x == y + | otherwise = False + +instance ToExpr (SomeSTSEvent era) where + toExpr (SomeSTSEvent ev) = App "SomeSTSEvent" [toExpr ev] + +data ImpTestState era = ImpTestState + { impNES :: !(NewEpochState era) + , impRootTxIn :: !TxIn + , impKeyPairs :: !(Map (KeyHash 'Witness) (KeyPair 'Witness)) + , impByronKeyPairs :: !(Map BootstrapAddress ByronKeyPair) + , 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}) + +impGlobalsL :: Lens' (ImpTestState era) Globals +impGlobalsL = lens impGlobals (\x y -> x {impGlobals = y}) + +impNESL :: Lens' (ImpTestState era) (NewEpochState era) +impNESL = lens impNES (\x y -> x {impNES = y}) + +impLastTickL :: Lens' (ImpTestState era) SlotNo +impLastTickL = lens impLastTick (\x y -> x {impLastTick = y}) + +impLastTickG :: SimpleGetter (ImpTestState era) SlotNo +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}) + +impNativeScriptsG :: + SimpleGetter (ImpTestState era) (Map ScriptHash (NativeScript era)) +impNativeScriptsG = impNativeScriptsL + +impEventsL :: Lens' (ImpTestState era) [SomeSTSEvent era] +impEventsL = lens impEvents (\x y -> x {impEvents = y}) + +class + ( ShelleyEraTxCert era + , ShelleyEraTest era + , -- For BBODY rule + STS (EraRule "BBODY" era) + , BaseM (EraRule "BBODY" era) ~ ShelleyBase + , Environment (EraRule "BBODY" era) ~ BbodyEnv era + , State (EraRule "BBODY" era) ~ ShelleyBbodyState era + , Signal (EraRule "BBODY" era) ~ Block BHeaderView era + , State (EraRule "LEDGERS" era) ~ LedgerState era + , -- For the LEDGER rule + STS (EraRule "LEDGER" era) + , BaseM (EraRule "LEDGER" era) ~ ShelleyBase + , Signal (EraRule "LEDGER" era) ~ Tx era + , State (EraRule "LEDGER" era) ~ LedgerState era + , Environment (EraRule "LEDGER" era) ~ LedgerEnv era + , Eq (PredicateFailure (EraRule "LEDGER" era)) + , Show (PredicateFailure (EraRule "LEDGER" era)) + , ToExpr (PredicateFailure (EraRule "LEDGER" era)) + , NFData (PredicateFailure (EraRule "LEDGER" era)) + , EncCBOR (PredicateFailure (EraRule "LEDGER" era)) + , DecCBOR (PredicateFailure (EraRule "LEDGER" era)) + , EraRuleEvent "LEDGER" era ~ Event (EraRule "LEDGER" era) + , Eq (EraRuleEvent "LEDGER" era) + , ToExpr (EraRuleEvent "LEDGER" era) + , NFData (EraRuleEvent "LEDGER" era) + , Typeable (EraRuleEvent "LEDGER" era) + , -- For the TICK rule + STS (EraRule "TICK" era) + , BaseM (EraRule "TICK" era) ~ ShelleyBase + , Signal (EraRule "TICK" era) ~ SlotNo + , State (EraRule "TICK" era) ~ NewEpochState era + , Environment (EraRule "TICK" era) ~ () + , NFData (PredicateFailure (EraRule "TICK" era)) + , EraRuleEvent "TICK" era ~ Event (EraRule "TICK" era) + , Eq (EraRuleEvent "TICK" era) + , ToExpr (EraRuleEvent "TICK" era) + , NFData (EraRuleEvent "TICK" era) + , Typeable (EraRuleEvent "TICK" era) + , ToExpr (PredicateFailure (EraRule "UTXOW" era)) + ) => + 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) => + m (NewEpochState era) + default initNewEpochState :: + ( HasKeyPairs s + , MonadState s m + , HasStatefulGen g m + , MonadFail m + , ShelleyEraImp (PreviousEra era) + , TranslateEra era NewEpochState + , TranslationError era NewEpochState ~ Void + , TranslationContext era ~ Genesis era + ) => + m (NewEpochState era) + initNewEpochState = defaultInitNewEpochState id + + initImpTestState :: + ( HasKeyPairs s + , MonadState s m + , HasStatefulGen g m + , MonadFail m + ) => + m (ImpTestState era) + initImpTestState = initNewEpochState >>= defaultInitImpTestState + + -- | Try to find a sufficient number of KeyPairs that would satisfy a native script. + -- Whenever script can't be satisfied, Nothing is returned + impSatisfyNativeScript :: + -- | Set of Witnesses that have already been satisfied + Set.Set (KeyHash 'Witness) -> + -- | The transaction body that the script will be applied to + TxBody era -> + NativeScript era -> + ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))) + + -- | This modifer should change not only the current PParams, but also the future + -- PParams. If the future PParams are not updated, then they will overwrite the + -- mofication of the current PParams at the next epoch. + modifyPParams :: + (PParams era -> PParams era) -> + ImpTestM era () + modifyPParams f = modifyNES $ nesEsL . curPParamsEpochStateL %~ f + + fixupTx :: HasCallStack => Tx era -> ImpTestM era (Tx era) + + expectTxSuccess :: HasCallStack => Tx era -> ImpTestM era () + +defaultInitNewEpochState :: + forall era g s m. + ( MonadState s m + , HasKeyPairs s + , HasStatefulGen g m + , MonadFail m + , ShelleyEraImp era + , ShelleyEraImp (PreviousEra era) + , TranslateEra era NewEpochState + , TranslationError era NewEpochState ~ Void + , TranslationContext era ~ Genesis era + ) => + (NewEpochState (PreviousEra era) -> NewEpochState (PreviousEra era)) -> + m (NewEpochState era) +defaultInitNewEpochState modifyPrevEraNewEpochState = do + genesis <- initGenesis @era + nes <- initNewEpochState @(PreviousEra era) + let majProtVer = eraProtVerLow @era + -- We need to set the protocol version for the current era and for debugging + -- purposes we start the era at the epoch number that matches the protocol version + -- times a 100. However, because this is the NewEpochState from the previous era, we + -- initialize it with futurePParams preset and epoch number that is one behind the + -- beginning of this era. Note that all imp tests will start with a TICK, in order + -- for theses changes to be applied. + prevEraNewEpochState = + nes + & nesEsL . curPParamsEpochStateL . ppProtocolVersionL .~ ProtVer majProtVer 0 + & nesELL .~ pred (impEraStartEpochNo @era) + pure $ translateEra' genesis $ modifyPrevEraNewEpochState prevEraNewEpochState + +-- | For debugging purposes we start the era at the epoch number that matches the starting +-- protocol version for the era times a 100 +impEraStartEpochNo :: forall era. Era era => EpochNo +impEraStartEpochNo = EpochNo (getVersion majProtVer * 100) + where + majProtVer = eraProtVerLow @era + +defaultInitImpTestState :: + forall era s g m. + ( EraGov era + , EraTxOut era + , HasKeyPairs s + , MonadState s m + , HasStatefulGen g m + , MonadFail m + ) => + NewEpochState era -> + m (ImpTestState era) +defaultInitImpTestState nes = do + shelleyGenesis <- initGenesis @ShelleyEra + rootKeyHash <- freshKeyHash @'Payment + let + rootAddr :: Addr + rootAddr = mkAddr rootKeyHash StakeRefNull + rootTxOut :: TxOut era + rootTxOut = mkBasicTxOut rootAddr $ inject rootCoin + rootCoin = Coin (toInteger (sgMaxLovelaceSupply shelleyGenesis)) + rootTxIn :: TxIn + rootTxIn = TxIn (mkTxId 0) minBound + nesWithRoot = nes & utxoL <>~ UTxO (Map.singleton rootTxIn rootTxOut) + prepState <- get + let epochInfoE = + fixedEpochInfo + (sgEpochLength shelleyGenesis) + (mkSlotLength . fromNominalDiffTimeMicro $ sgSlotLength shelleyGenesis) + globals = mkShelleyGlobals shelleyGenesis epochInfoE + epochNo = nesWithRoot ^. nesELL + slotNo = epochInfoFirst (epochInfoPure globals) epochNo + pure $ + ImpTestState + { impNES = nesWithRoot + , impRootTxIn = rootTxIn + , impKeyPairs = prepState ^. keyPairsL + , impByronKeyPairs = prepState ^. keyPairsByronL + , impNativeScripts = mempty + , impLastTick = slotNo + , impGlobals = globals + , impEvents = mempty + } + +withEachEraVersion :: + forall era. + ShelleyEraImp era => + SpecWith (ImpInit (LedgerSpec era)) -> + Spec +withEachEraVersion specWith = + withImpInit @(LedgerSpec era) $ do + forM_ (eraProtVersions @era) $ \protVer -> + describe (show protVer) $ + modifyImpInitProtVer protVer specWith + +modifyImpInitProtVer :: + forall era. + ShelleyEraImp era => + Version -> + SpecWith (ImpInit (LedgerSpec era)) -> + SpecWith (ImpInit (LedgerSpec era)) +modifyImpInitProtVer ver = + modifyImpInit $ \impInit -> + impInit + { impInitState = + impInitState impInit + & impNESL + . nesEsL + . curPParamsEpochStateL + . ppProtocolVersionL + .~ ProtVer ver 0 + } + +modifyImpInitPostSubmitTxHook :: + forall era. + ( forall t. + Globals -> + TRC (EraRule "LEDGER" era) -> + Either + (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) + (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) -> + ImpM t () + ) -> + SpecWith (ImpInit (LedgerSpec era)) -> + SpecWith (ImpInit (LedgerSpec era)) +modifyImpInitPostSubmitTxHook f = + modifyImpInit $ \impInit -> + impInit + { impInitEnv = + impInitEnv impInit + & itePostSubmitTxHookL .~ f + } + +disableImpInitPostSubmitTxHook :: + SpecWith (ImpInit (LedgerSpec era)) -> + SpecWith (ImpInit (LedgerSpec era)) +disableImpInitPostSubmitTxHook = + modifyImpInitPostSubmitTxHook $ \_ _ _ -> pure () + +impLedgerEnv :: EraGov era => NewEpochState era -> ImpTestM era (LedgerEnv era) +impLedgerEnv nes = do + slotNo <- gets impLastTick + epochNo <- runShelleyBase $ epochFromSlot slotNo + pure + LedgerEnv + { ledgerSlotNo = slotNo + , ledgerEpochNo = Just epochNo + , ledgerPp = nes ^. nesEsL . curPParamsEpochStateL + , ledgerIx = TxIx 0 + , ledgerAccount = nes ^. chainAccountStateL + } + +-- | Modify the previous PParams in the current state with the given function. For current +-- and future PParams, use `modifyPParams` +modifyPrevPParams :: + EraGov era => + (PParams era -> PParams era) -> + ImpTestM era () +modifyPrevPParams f = modifyNES $ nesEsL . prevPParamsEpochStateL %~ f + +-- | Logs the current stake distribution +logInstantStake :: ToExpr (InstantStake era) => HasCallStack => ImpTestM era () +logInstantStake = do + stakeDistr <- getsNES instantStakeG + logDoc $ "Instant Stake: " <> ansiExpr stakeDistr + +mkTxId :: Int -> TxId +mkTxId idx = TxId (mkDummySafeHash idx) + +instance + ShelleyEraScript ShelleyEra => + ShelleyEraImp ShelleyEra + where + initGenesis = do + let + gen = + ShelleyGenesis + { sgSystemStart = errorFail $ iso8601ParseM "2017-09-23T21:44:51Z" + , sgNetworkMagic = 123_456 -- Mainnet value: 764824073 + , sgNetworkId = Testnet + , sgActiveSlotsCoeff = 20 %! 100 -- Mainnet value: 5 %! 100 + , sgSecurityParam = knownNonZeroBounded @108 -- Mainnet value: 2160 + , sgEpochLength = 4320 -- Mainnet value: 432000 + , sgSlotsPerKESPeriod = 129_600 + , sgMaxKESEvolutions = 62 + , sgSlotLength = 1 + , sgUpdateQuorum = 5 + , sgMaxLovelaceSupply = 45_000_000_000_000_000 + , sgProtocolParams = + emptyPParams + & ppMinFeeAL .~ Coin 44 + & ppMinFeeBL .~ Coin 155_381 + & ppMaxBBSizeL .~ 65_536 + & ppMaxTxSizeL .~ 16_384 + & ppKeyDepositL .~ Coin 2_000_000 + & ppPoolDepositL .~ Coin 500_000_000 + & ppEMaxL .~ EpochInterval 18 + & ppNOptL .~ 150 + & ppA0L .~ (3 %! 10) + & ppRhoL .~ (3 %! 1000) + & ppTauL .~ (2 %! 10) + & ppDL .~ (1 %! 1) + & ppExtraEntropyL .~ NeutralNonce + & ppMinUTxOValueL .~ Coin 2_000_000 + & ppMinPoolCostL .~ Coin 340_000_000 + , -- TODO: Add a top level definition and add private keys to ImpState: + sgGenDelegs = mempty + , sgInitialFunds = mempty + , sgStaking = mempty + } + case validateGenesis gen of + Right () -> pure gen + Left errs -> fail . T.unpack . T.unlines $ map describeValidationErr errs + + initNewEpochState = do + shelleyGenesis <- initGenesis @ShelleyEra + let transContext = toFromByronTranslationContext shelleyGenesis + startEpochNo = impEraStartEpochNo @ShelleyEra + pure $ translateToShelleyLedgerStateFromUtxo transContext startEpochNo Byron.empty + + impSatisfyNativeScript providedVKeyHashes _txBody script = do + keyPairs <- gets impKeyPairs + let + satisfyMOf m Empty + | m <= 0 = Just mempty + | otherwise = Nothing + satisfyMOf m (x :<| xs) = + case satisfyScript x of + Nothing -> satisfyMOf m xs + Just kps -> do + kps' <- satisfyMOf (m - 1) xs + Just $ kps <> kps' + satisfyScript = \case + RequireSignature keyHash + | keyHash `Set.member` providedVKeyHashes -> Just mempty + | otherwise -> do + keyPair <- Map.lookup keyHash keyPairs + Just $ Map.singleton keyHash keyPair + RequireAllOf ss -> satisfyMOf (length ss) ss + RequireAnyOf ss -> satisfyMOf 1 ss + RequireMOf m ss -> satisfyMOf m ss + _ -> error "Impossible: All NativeScripts should have been accounted for" + + pure $ satisfyScript script + + fixupTx = shelleyFixupTx + expectTxSuccess = impShelleyExpectTxSuccess + +-- | Figure out all the Byron Addresses that need witnesses as well as all of the +-- KeyHashes for Shelley Key witnesses that are required. +impWitsVKeyNeeded :: + EraUTxO era => + TxBody era -> + ImpTestM + era + ( Set.Set BootstrapAddress -- Byron Based Addresses + , Set.Set (KeyHash 'Witness) -- Shelley Based KeyHashes + ) +impWitsVKeyNeeded txBody = do + ls <- getsNES (nesEsL . esLStateL) + utxo <- getUTxO + let toBootAddr txIn = do + txOut <- txinLookup txIn utxo + txOut ^. bootAddrTxOutF + bootAddrs = Set.fromList $ mapMaybe toBootAddr $ Set.toList (txBody ^. spendableInputsTxBodyF) + bootKeyHashes = Set.map (coerceKeyRole . bootstrapKeyHash) bootAddrs + allKeyHashes = + getWitsVKeyNeeded (ls ^. lsCertStateL) (ls ^. utxoL) txBody + pure (bootAddrs, allKeyHashes Set.\\ bootKeyHashes) + +data ImpTestEnv era = ImpTestEnv + { iteFixup :: Tx era -> ImpTestM era (Tx era) + , itePostSubmitTxHook :: + forall t. + Globals -> + TRC (EraRule "LEDGER" era) -> + Either + (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) + (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) -> + ImpM t () + , iteCborRoundTripFailures :: Bool + -- ^ Expect failures in CBOR round trip serialization tests for predicate failures + } + +iteFixupL :: Lens' (ImpTestEnv era) (Tx era -> ImpTestM era (Tx era)) +iteFixupL = lens iteFixup (\x y -> x {iteFixup = y}) + +itePostSubmitTxHookL :: + forall era. + Lens' + (ImpTestEnv era) + ( forall t. + Globals -> + TRC (EraRule "LEDGER" era) -> + Either + (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) + (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) -> + ImpM t () + ) +itePostSubmitTxHookL = lens itePostSubmitTxHook (\x y -> x {itePostSubmitTxHook = y}) + +iteCborRoundTripFailuresL :: Lens' (ImpTestEnv era) Bool +iteCborRoundTripFailuresL = lens iteCborRoundTripFailures (\x y -> x {iteCborRoundTripFailures = y}) + +instance MonadWriter [SomeSTSEvent era] (ImpTestM era) where + writer (x, evs) = (impEventsL %= (<> evs)) $> x + listen act = do + oldEvs <- use impEventsL + impEventsL .= mempty + res <- act + newEvs <- use impEventsL + impEventsL .= oldEvs + pure (res, newEvs) + pass act = do + ((a, f), evs) <- listen act + writer (a, f evs) + +runShelleyBase :: ShelleyBase a -> ImpTestM era a +runShelleyBase act = do + globals <- use impGlobalsL + pure $ runIdentity $ runReaderT act globals + +getRewardAccountAmount :: (HasCallStack, EraCertState era) => RewardAccount -> ImpTestM era Coin +getRewardAccountAmount = getAccountBalance +{-# DEPRECATED getRewardAccountAmount "In favor of `getAccountBalance`" #-} + +lookupBalance :: EraCertState era => Credential 'Staking -> ImpTestM era (Maybe Coin) +lookupBalance cred = do + accountsMap <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL . accountsMapL + pure $ + (\accountState -> fromCompact (accountState ^. balanceAccountStateL)) + <$> Map.lookup cred accountsMap + +lookupAccountBalance :: + (HasCallStack, EraCertState era) => RewardAccount -> ImpTestM era (Maybe Coin) +lookupAccountBalance ra@RewardAccount {raNetwork, raCredential} = do + networkId <- use (impGlobalsL . to networkId) + when (raNetwork /= networkId) $ + error $ + "Reward Account with an unexpected NetworkId: " ++ show ra + lookupBalance raCredential + +getBalance :: (HasCallStack, EraCertState era) => Credential 'Staking -> ImpTestM era Coin +getBalance cred = + lookupBalance cred >>= \case + Nothing -> + assertFailure $ + "Expected a registered account: " + ++ show cred + ++ ". Use `registerRewardAccount` to register a new account in ImpSpec" + Just balance -> pure balance + +getAccountBalance :: (HasCallStack, EraCertState era) => RewardAccount -> ImpTestM era Coin +getAccountBalance ra = + lookupAccountBalance ra >>= \case + Nothing -> + assertFailure $ + "Expected a registered account: " + ++ show ra + ++ ". Use `registerRewardAccount` to register a new account in ImpSpec" + Just balance -> pure balance + +getImpRootTxOut :: ImpTestM era (TxIn, TxOut era) +getImpRootTxOut = do + ImpTestState {impRootTxIn} <- get + utxo <- getUTxO + case txinLookup impRootTxIn utxo of + Nothing -> error "Root txId no longer points to an existing unspent output" + Just rootTxOut -> pure (impRootTxIn, rootTxOut) + +impAddNativeScript :: + forall era. + EraScript era => + NativeScript era -> + ImpTestM era ScriptHash +impAddNativeScript nativeScript = do + let script = fromNativeScript nativeScript + scriptHash = hashScript @era script + impNativeScriptsL %= Map.insert scriptHash nativeScript + pure scriptHash + +impNativeScriptsRequired :: + EraUTxO era => + Tx era -> + ImpTestM era (Map ScriptHash (NativeScript era)) +impNativeScriptsRequired tx = do + utxo <- getUTxO + ImpTestState {impNativeScripts} <- get + let needed = getScriptsNeeded utxo (tx ^. bodyTxL) + hashesNeeded = getScriptsHashesNeeded needed + pure $ impNativeScripts `Map.restrictKeys` hashesNeeded + +-- | Modifies transaction by adding necessary scripts +addNativeScriptTxWits :: + ShelleyEraImp era => + Tx era -> + ImpTestM era (Tx era) +addNativeScriptTxWits tx = impAnn "addNativeScriptTxWits" $ do + scriptsRequired <- impNativeScriptsRequired tx + utxo <- getUTxO + let ScriptsProvided provided = getScriptsProvided utxo tx + scriptsToAdd = scriptsRequired Map.\\ provided + pure $ + tx + & witsTxL . scriptTxWitsL <>~ fmap fromNativeScript scriptsToAdd + +-- | Adds @TxWits@ that will satisfy all of the required key witnesses +updateAddrTxWits :: + ( HasCallStack + , ShelleyEraImp era + ) => + Tx era -> + ImpTestM era (Tx era) +updateAddrTxWits tx = impAnn "updateAddrTxWits" $ do + let txBody = tx ^. bodyTxL + txBodyHash = hashAnnotated txBody + (bootAddrs, witsVKeyNeeded) <- impWitsVKeyNeeded txBody + -- Shelley Based Addr Witnesses + let curAddrWitHashes = Set.map witVKeyHash $ tx ^. witsTxL . addrTxWitsL + extraKeyPairs <- mapM getKeyPair $ Set.toList (witsVKeyNeeded Set.\\ curAddrWitHashes) + let extraAddrVKeyWits = mkWitnessesVKey txBodyHash extraKeyPairs + addrWitHashes = curAddrWitHashes <> Set.map witVKeyHash extraAddrVKeyWits + -- Shelley Based Native Script Witnesses + scriptsRequired <- impNativeScriptsRequired tx + nativeScriptsKeyPairs <- + mapM (impSatisfyNativeScript addrWitHashes txBody) (Map.elems scriptsRequired) + let extraNativeScriptVKeyWits = + mkWitnessesVKey txBodyHash $ Map.elems (mconcat (catMaybes nativeScriptsKeyPairs)) + -- Byron Based Witessed + let curBootAddrWitHashes = Set.map bootstrapWitKeyHash $ tx ^. witsTxL . bootAddrTxWitsL + bootAddrWitsNeeded = + [ bootAddr + | bootAddr <- Set.toList bootAddrs + , not (coerceKeyRole (bootstrapKeyHash bootAddr) `Set.member` curBootAddrWitHashes) + ] + extraBootAddrWits <- forM bootAddrWitsNeeded $ \bootAddr@(BootstrapAddress byronAddr) -> do + ByronKeyPair _ signingKey <- getByronKeyPair bootAddr + let attrs = Byron.addrAttributes byronAddr + pure $ makeBootstrapWitness (extractHash txBodyHash) signingKey attrs + pure $ + tx + & witsTxL . addrTxWitsL <>~ extraAddrVKeyWits <> extraNativeScriptVKeyWits + & witsTxL . bootAddrTxWitsL <>~ Set.fromList extraBootAddrWits + +-- | This fixup step ensures that there are enough funds in the transaction. +addRootTxIn :: + ShelleyEraImp era => + Tx era -> + ImpTestM era (Tx era) +addRootTxIn tx = impAnn "addRootTxIn" $ do + rootTxIn <- fst <$> getImpRootTxOut + pure $ + tx + & bodyTxL . inputsTxBodyL %~ Set.insert rootTxIn + +impNativeScriptKeyPairs :: + ShelleyEraImp era => + Tx era -> + ImpTestM + era + (Map (KeyHash 'Witness) (KeyPair 'Witness)) +impNativeScriptKeyPairs tx = do + scriptsRequired <- impNativeScriptsRequired tx + let nativeScripts = Map.elems scriptsRequired + curAddrWits = Set.map witVKeyHash $ tx ^. witsTxL . addrTxWitsL + keyPairs <- mapM (impSatisfyNativeScript curAddrWits $ tx ^. bodyTxL) nativeScripts + pure . mconcat $ catMaybes keyPairs + +fixupTxOuts :: (ShelleyEraImp era, HasCallStack) => Tx era -> ImpTestM era (Tx era) +fixupTxOuts tx = do + pp <- getsNES $ nesEsL . curPParamsEpochStateL + let + txOuts = tx ^. bodyTxL . outputsTxBodyL + fixedUpTxOuts <- forM txOuts $ \txOut -> do + if txOut ^. coinTxOutL == zero + then do + amount <- arbitrary + let txOut' = ensureMinCoinTxOut pp (txOut & coinTxOutL .~ amount) + logDoc $ + "Fixed up the amount in the TxOut to " <> ansiExpr (txOut' ^. coinTxOutL) + pure txOut' + else do + pure txOut + pure $ tx & bodyTxL . outputsTxBodyL .~ fixedUpTxOuts + +fixupFees :: + (ShelleyEraImp era, HasCallStack) => + Tx era -> + ImpTestM era (Tx era) +fixupFees txOriginal = impAnn "fixupFees" $ do + -- Fee will be overwritten later on, unless it wasn't set to zero to begin with: + let tx = txOriginal & bodyTxL . feeTxBodyL .~ zero + pp <- getsNES $ nesEsL . curPParamsEpochStateL + utxo <- getUTxO + certState <- getsNES $ nesEsL . esLStateL . lsCertStateL + addr <- freshKeyAddr_ + nativeScriptKeyPairs <- impNativeScriptKeyPairs tx + let + nativeScriptKeyWits = Map.keysSet nativeScriptKeyPairs + consumedValue = consumed pp certState utxo (tx ^. bodyTxL) + producedValue = produced pp certState (tx ^. bodyTxL) + ensureNonNegativeCoin v + | pointwise (<=) zero v = pure v + | otherwise = do + logDoc $ "Failed to validate coin: " <> ansiExpr v + pure zero + logString "Validating changeBeforeFee" + changeBeforeFee <- ensureNonNegativeCoin $ coin consumedValue <-> coin producedValue + logToExpr changeBeforeFee + let + changeBeforeFeeTxOut = mkBasicTxOut addr (inject changeBeforeFee) + txNoWits = tx & bodyTxL . outputsTxBodyL %~ (:|> changeBeforeFeeTxOut) + outsBeforeFee = tx ^. bodyTxL . outputsTxBodyL + suppliedFee = txOriginal ^. bodyTxL . feeTxBodyL + fee0 + | suppliedFee == zero = calcMinFeeTxNativeScriptWits utxo pp txNoWits nativeScriptKeyWits + | otherwise = suppliedFee + fee = rationalToCoinViaCeiling $ coinToRational fee0 * (11 % 10) + logString "Validating change" + change <- ensureNonNegativeCoin $ changeBeforeFeeTxOut ^. coinTxOutL <-> fee + logToExpr change + let + changeTxOut = changeBeforeFeeTxOut & coinTxOutL .~ change + -- If the remainder is sufficently big we add it to outputs, otherwise we add the + -- extraneous coin to the fee and discard the remainder TxOut + txWithFee + | change >= getMinCoinTxOut pp changeTxOut = + txNoWits + & bodyTxL . outputsTxBodyL .~ (outsBeforeFee :|> changeTxOut) + & bodyTxL . feeTxBodyL .~ fee + | otherwise = + txNoWits + & bodyTxL . outputsTxBodyL .~ outsBeforeFee + & bodyTxL . feeTxBodyL .~ (fee <> change) + pure txWithFee + +-- | Adds an auxiliary data hash if auxiliary data present, while the hash of it is not. +fixupAuxDataHash :: (EraTx era, Applicative m) => Tx era -> m (Tx era) +fixupAuxDataHash tx + | SNothing <- tx ^. bodyTxL . auxDataHashTxBodyL + , SJust auxData <- tx ^. auxDataTxL = + pure (tx & bodyTxL . auxDataHashTxBodyL .~ SJust (TxAuxDataHash (hashAnnotated auxData))) + | otherwise = pure tx + +shelleyFixupTx :: + forall era. + (ShelleyEraImp era, HasCallStack) => + Tx era -> + ImpTestM era (Tx era) +shelleyFixupTx = + addNativeScriptTxWits + >=> fixupAuxDataHash + >=> addRootTxIn + >=> fixupTxOuts + >=> fixupFees + >=> updateAddrTxWits + >=> (\tx -> logFeeMismatch tx $> tx) + +impShelleyExpectTxSuccess :: + forall era. + (ShelleyEraImp era, HasCallStack) => + Tx era -> + ImpTestM era () +impShelleyExpectTxSuccess tx = do + utxo <- getsNES utxoL + let inputs = tx ^. bodyTxL . inputsTxBodyL + outputs = Map.toList . unUTxO . txouts $ tx ^. bodyTxL + impAnn "Inputs should be gone from UTxO" $ + expectUTxOContent utxo [(txIn, isNothing) | txIn <- Set.toList inputs] + impAnn "Outputs should be in UTxO" $ + expectUTxOContent utxo [(txIn, (== Just txOut)) | (txIn, txOut) <- outputs] + +logFeeMismatch :: (EraGov era, EraUTxO era, HasCallStack) => Tx era -> ImpTestM era () +logFeeMismatch tx = do + pp <- getsNES $ nesEsL . curPParamsEpochStateL + utxo <- getsNES utxoL + let Coin feeUsed = tx ^. bodyTxL . feeTxBodyL + Coin feeMin = getMinFeeTxUtxo pp tx utxo + when (feeUsed /= feeMin) $ do + logDoc $ + "Estimated fee " <> ansiExpr feeUsed <> " while required fee is " <> ansiExpr feeMin + +submitTx_ :: (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era () +submitTx_ = void . submitTx + +submitTx :: (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era (Tx era) +submitTx tx = trySubmitTx tx >>= expectRightDeepExpr . first fst + +trySubmitTx :: + forall era. + ( ShelleyEraImp era + , HasCallStack + ) => + Tx era -> + ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era) (Tx era)) +trySubmitTx tx = do + txFixed <- asks iteFixup >>= ($ tx) + logToExpr txFixed + st <- gets impNES + lEnv <- impLedgerEnv st + ImpTestState {impRootTxIn} <- get + res <- tryRunImpRule @"LEDGER" lEnv (st ^. nesEsL . esLStateL) txFixed + roundTripCheck <- asks iteCborRoundTripFailures + globals <- use impGlobalsL + let trc = TRC (lEnv, st ^. nesEsL . esLStateL, txFixed) + + -- Check for conformance + asks itePostSubmitTxHook >>= (\f -> f globals trc res) + + case res of + Left predFailures -> do + -- Verify that produced predicate failures are ready for the node-to-client protocol + if roundTripCheck + then liftIO $ forM_ predFailures $ roundTripEraExpectation @era + else + liftIO $ + roundTripCborRangeFailureExpectation + (eraProtVerLow @era) + (eraProtVerHigh @era) + predFailures + pure $ Left (predFailures, txFixed) + Right (st', events) -> do + let txId = TxId . hashAnnotated $ txFixed ^. bodyTxL + outsSize = SSeq.length $ txFixed ^. bodyTxL . outputsTxBodyL + rootIndex + | outsSize > 0 = outsSize - 1 + | otherwise = error ("Expected at least 1 output after submitting tx: " <> show txId) + tell $ fmap (SomeSTSEvent @era @"LEDGER") events + modify $ impNESL . nesEsL . esLStateL .~ st' + UTxO utxo <- getUTxO + -- This TxIn is in the utxo, and thus can be the new root, only if the transaction + -- was phase2-valid. Otherwise, no utxo with this id would have been created, and + -- so we need to set the new root to what it was before the submission. + let assumedNewRoot = TxIn txId (mkTxIxPartial (fromIntegral rootIndex)) + let newRoot + | Map.member assumedNewRoot utxo = assumedNewRoot + | Map.member impRootTxIn utxo = impRootTxIn + | otherwise = error "Root not found in UTxO" + impRootTxInL .= newRoot + expectTxSuccess txFixed + pure $ Right txFixed + +-- | Submit a transaction that is expected to be rejected with the given predicate failures. +-- The inputs and outputs are automatically balanced. +submitFailingTx :: + ( HasCallStack + , ShelleyEraImp era + ) => + Tx era -> + NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> + ImpTestM era () +submitFailingTx tx = submitFailingTxM tx . const . pure + +-- | Submit a transaction that is expected to be rejected, and compute +-- the expected predicate failures from the fixed-up tx using the supplied action. +-- The inputs and outputs are automatically balanced. +submitFailingTxM :: + ( HasCallStack + , ShelleyEraImp era + ) => + Tx era -> + (Tx era -> ImpTestM era (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))) -> + ImpTestM era () +submitFailingTxM tx mkExpectedFailures = do + (predFailures, fixedUpTx) <- expectLeftDeepExpr =<< trySubmitTx tx + expectedFailures <- mkExpectedFailures fixedUpTx + predFailures `shouldBeExpr` expectedFailures + +tryRunImpRule :: + forall rule era. + (STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) => + Environment (EraRule rule era) -> + State (EraRule rule era) -> + Signal (EraRule rule era) -> + ImpTestM + era + ( Either + (NonEmpty (PredicateFailure (EraRule rule era))) + (State (EraRule rule era), [Event (EraRule rule era)]) + ) +tryRunImpRule = tryRunImpRule' @rule AssertionsAll + +tryRunImpRuleNoAssertions :: + forall rule era. + ( STS (EraRule rule era) + , BaseM (EraRule rule era) ~ ShelleyBase + ) => + Environment (EraRule rule era) -> + State (EraRule rule era) -> + Signal (EraRule rule era) -> + ImpTestM + era + ( Either + (NonEmpty (PredicateFailure (EraRule rule era))) + (State (EraRule rule era), [Event (EraRule rule era)]) + ) +tryRunImpRuleNoAssertions = tryRunImpRule' @rule AssertionsOff + +tryRunImpRule' :: + forall rule era. + (STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) => + AssertionPolicy -> + Environment (EraRule rule era) -> + State (EraRule rule era) -> + Signal (EraRule rule era) -> + ImpTestM + era + ( Either + (NonEmpty (PredicateFailure (EraRule rule era))) + (State (EraRule rule era), [Event (EraRule rule era)]) + ) +tryRunImpRule' assertionPolicy stsEnv stsState stsSignal = do + let trc = TRC (stsEnv, stsState, stsSignal) + let + stsOpts = + ApplySTSOpts + { asoValidation = ValidateAll + , asoEvents = EPReturn + , asoAssertions = assertionPolicy + } + runShelleyBase (applySTSOptsEither @(EraRule rule era) stsOpts trc) + +runImpRule :: + forall rule era. + ( HasCallStack + , KnownSymbol rule + , STS (EraRule rule era) + , BaseM (EraRule rule era) ~ ShelleyBase + , NFData (State (EraRule rule era)) + , NFData (Event (EraRule rule era)) + , ToExpr (Event (EraRule rule era)) + , Eq (Event (EraRule rule era)) + , Typeable (Event (EraRule rule era)) + ) => + Environment (EraRule rule era) -> + State (EraRule rule era) -> + Signal (EraRule rule era) -> + ImpTestM era (State (EraRule rule era)) +runImpRule env st sig = do + let ruleName = symbolVal (Proxy @rule) + (res, ev) <- + tryRunImpRule @rule env st sig >>= \case + Left fs -> + assertFailure $ + unlines $ + ("Failed to run " <> ruleName <> ":") : map show (toList fs) + Right res -> evaluateDeep res + tell $ fmap (SomeSTSEvent @era @rule) ev + pure res + +-- | Runs the TICK rule once +passTick :: + forall era. + ( HasCallStack + , ShelleyEraImp era + ) => + ImpTestM era () +passTick = do + impLastTick <- gets impLastTick + curNES <- getsNES id + nes <- runImpRule @"TICK" () curNES impLastTick + impLastTickL += 1 + impNESL .= nes + +-- | Runs the TICK rule until the next epoch is reached +passEpoch :: + forall era. + (ShelleyEraImp era, HasCallStack) => + ImpTestM era () +passEpoch = do + let + tickUntilNewEpoch curEpochNo = do + passTick @era + newEpochNo <- getsNES nesELL + unless (newEpochNo > curEpochNo) $ tickUntilNewEpoch curEpochNo + preNES <- gets impNES + let startEpoch = preNES ^. nesELL + logDoc $ "Entering " <> ansiExpr (succ startEpoch) + tickUntilNewEpoch startEpoch + gets impNES >>= epochBoundaryCheck preNES + +epochBoundaryCheck :: + (EraTxOut era, EraGov era, HasCallStack, EraCertState era) => + NewEpochState era -> + NewEpochState era -> + ImpTestM era () +epochBoundaryCheck preNES postNES = do + impAnn "Checking ADA preservation at the epoch boundary" $ do + let preSum = tot preNES + postSum = tot postNES + logDoc $ diffExpr preSum postSum + unless (preSum == postSum) . expectationFailure $ + "Total ADA in the epoch state is not preserved\n\tpost - pre = " + <> show (postSum <-> preSum) + where + tot nes = + (<+>) + (sumAdaPots (totalAdaPotsES (nes ^. nesEsL))) + (nes ^. nesEsL . esLStateL . lsUTxOStateL . utxosDonationL) + +-- | Runs the TICK rule until the `n` epochs are passed +passNEpochs :: + forall era. + ShelleyEraImp era => + Natural -> + ImpTestM era () +passNEpochs n = + replicateM_ (fromIntegral n) passEpoch + +-- | Runs the TICK rule until the `n` epochs are passed, running the `checks` +-- each time. +passNEpochsChecking :: + forall era. + ShelleyEraImp era => + Natural -> + ImpTestM era () -> + ImpTestM era () +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 + +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 + +sendCoinTo :: (ShelleyEraImp era, HasCallStack) => Addr -> Coin -> ImpTestM era TxIn +sendCoinTo addr = sendValueTo addr . inject + +sendCoinTo_ :: (ShelleyEraImp era, HasCallStack) => Addr -> Coin -> ImpTestM era () +sendCoinTo_ addr = void . sendCoinTo addr + +sendValueTo :: (ShelleyEraImp era, HasCallStack) => Addr -> Value era -> ImpTestM era TxIn +sendValueTo addr amount = do + tx <- + submitTxAnn + ("Giving " <> show amount <> " to " <> show addr) + $ mkBasicTx mkBasicTxBody + & bodyTxL . outputsTxBodyL .~ SSeq.singleton (mkBasicTxOut addr amount) + pure $ txInAt 0 tx + +sendValueTo_ :: (ShelleyEraImp era, HasCallStack) => Addr -> Value era -> ImpTestM era () +sendValueTo_ addr = void . sendValueTo addr + +-- | Modify the current new epoch state with a function +modifyNES :: (NewEpochState era -> NewEpochState era) -> ImpTestM era () +modifyNES = (impNESL %=) + +-- | Get a value from the current new epoch state using the lens +getsNES :: SimpleGetter (NewEpochState era) a -> ImpTestM era a +getsNES l = gets . view $ impNESL . l + +getUTxO :: ImpTestM era (UTxO era) +getUTxO = getsNES utxoL + +getProtVer :: EraGov era => ImpTestM era ProtVer +getProtVer = getsNES $ nesEsL . curPParamsEpochStateL . ppProtocolVersionL + +submitTxAnn :: + (HasCallStack, ShelleyEraImp era) => + String -> + Tx era -> + ImpTestM era (Tx era) +submitTxAnn msg tx = impAnn msg (trySubmitTx tx >>= expectRightDeepExpr) + +submitTxAnn_ :: + (HasCallStack, ShelleyEraImp era) => String -> Tx era -> ImpTestM era () +submitTxAnn_ msg = void . submitTxAnn msg + +getRewardAccountFor :: + Credential 'Staking -> + ImpTestM era RewardAccount +getRewardAccountFor stakingC = do + networkId <- use (impGlobalsL . to networkId) + pure $ RewardAccount networkId stakingC + +registerStakeCredential :: + forall era. + ( HasCallStack + , ShelleyEraImp era + ) => + Credential 'Staking -> + ImpTestM era RewardAccount +registerStakeCredential cred = do + submitTxAnn_ ("Register Reward Account: " <> T.unpack (credToText cred)) $ + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL + .~ SSeq.fromList [RegTxCert cred] + networkId <- use (impGlobalsL . to networkId) + pure $ RewardAccount networkId cred + +delegateStake :: + ShelleyEraImp era => + Credential 'Staking -> + KeyHash 'StakePool -> + ImpTestM era () +delegateStake cred poolKH = do + submitTxAnn_ ("Delegate Staking Credential: " <> T.unpack (credToText cred)) $ + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL + .~ SSeq.fromList + [DelegStakeTxCert cred poolKH] + +registerRewardAccount :: + forall era. + ( HasCallStack + , ShelleyEraImp era + ) => + ImpTestM era RewardAccount +registerRewardAccount = do + khDelegator <- freshKeyHash + registerStakeCredential (KeyHashObj khDelegator) + +lookupReward :: EraCertState era => Credential 'Staking -> ImpTestM era (Maybe Coin) +lookupReward = lookupBalance +{-# DEPRECATED lookupReward "In favor of `lookupBalance`" #-} + +getReward :: (HasCallStack, EraCertState era) => Credential 'Staking -> ImpTestM era Coin +getReward = getBalance +{-# DEPRECATED getReward "In favor of `getBalance`" #-} + +freshPoolParams :: + ShelleyEraImp era => + KeyHash 'StakePool -> + 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 + } + +registerPool :: + ShelleyEraImp era => + KeyHash 'StakePool -> + ImpTestM era () +registerPool khPool = registerRewardAccount >>= registerPoolWithRewardAccount khPool + +registerPoolWithRewardAccount :: + ShelleyEraImp era => + KeyHash 'StakePool -> + RewardAccount -> + ImpTestM era () +registerPoolWithRewardAccount khPool rewardAccount = do + pps <- freshPoolParams khPool rewardAccount + submitTxAnn_ "Registering a new stake pool" $ + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL .~ SSeq.singleton (RegPoolTxCert pps) + +registerAndRetirePoolToMakeReward :: + ShelleyEraImp era => + Credential 'Staking -> + ImpTestM era () +registerAndRetirePoolToMakeReward stakingCred = do + poolId <- freshKeyHash + registerPoolWithRewardAccount poolId =<< getRewardAccountFor stakingCred + passEpoch + curEpochNo <- getsNES nesELL + let poolLifetime = 2 + poolExpiry = addEpochInterval curEpochNo $ EpochInterval poolLifetime + submitTxAnn_ "Retiring the temporary stake pool" $ + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL .~ SSeq.singleton (RetirePoolTxCert poolId poolExpiry) + passNEpochs $ fromIntegral poolLifetime + +withCborRoundTripFailures :: ImpTestM era a -> ImpTestM era a +withCborRoundTripFailures = local $ iteCborRoundTripFailuresL .~ False + +-- | Compose given function with the configured fixup +withCustomFixup :: + ((Tx era -> ImpTestM era (Tx era)) -> Tx era -> ImpTestM era (Tx era)) -> + ImpTestM era a -> + ImpTestM era a +withCustomFixup f = local $ iteFixupL %~ f + +-- | Replace all fixup with the given function +withFixup :: + (Tx era -> ImpTestM era (Tx era)) -> + ImpTestM era a -> + ImpTestM era a +withFixup f = withCustomFixup (const f) + +-- | Performs the action without running the fix-up function on any transactions +withNoFixup :: ImpTestM era a -> ImpTestM era a +withNoFixup = withFixup pure + +-- | Apply given fixup function before the configured fixup +withPreFixup :: + (Tx era -> ImpTestM era (Tx era)) -> + ImpTestM era a -> + ImpTestM era a +withPreFixup f = withCustomFixup (f >=>) + +-- | Apply given fixup function after the configured fixup +withPostFixup :: + (Tx era -> ImpTestM era (Tx era)) -> + ImpTestM era a -> + ImpTestM era a +withPostFixup f = withCustomFixup (>=> f) + +expectUTxOContent :: + (HasCallStack, ToExpr (TxOut era)) => + UTxO era -> + [(TxIn, Maybe (TxOut era) -> Bool)] -> + ImpTestM era () +expectUTxOContent utxo = traverse_ $ \(txIn, test) -> do + let result = txIn `Map.lookup` unUTxO utxo + unless (test result) $ + expectationFailure $ + "UTxO content failed predicate:\n" <> ansiExprString txIn <> " -> " <> ansiExprString result + +expectRegisteredRewardAddress :: + (HasCallStack, EraCertState era) => RewardAccount -> ImpTestM era () +expectRegisteredRewardAddress ra@RewardAccount {raNetwork, raCredential} = do + networkId <- use (impGlobalsL . to networkId) + unless (raNetwork == networkId) $ + assertFailure $ + "Reward Account with an unexpected NetworkId: " ++ show ra + accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL + unless (isAccountRegistered raCredential accounts) $ + assertFailure $ + "Expected account " + ++ show ra + ++ " to be registered, but it is not." + +expectNotRegisteredRewardAddress :: + (HasCallStack, EraCertState era) => RewardAccount -> ImpTestM era () +expectNotRegisteredRewardAddress ra@RewardAccount {raNetwork, raCredential} = do + accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL + networkId <- use (impGlobalsL . to networkId) + when (raNetwork == networkId && isAccountRegistered raCredential accounts) $ + assertFailure $ + "Expected account " + ++ show ra + ++ " to not be registered, but it is." + +expectTreasury :: HasCallStack => Coin -> ImpTestM era () +expectTreasury c = + impAnn "Checking treasury amount" $ do + treasuryAmount <- getsNES treasuryL + c `shouldBe` treasuryAmount + +-- Ensure no fees reach the treasury since that complicates withdrawal checks +disableTreasuryExpansion :: ShelleyEraImp era => ImpTestM era () +disableTreasuryExpansion = modifyPParams $ ppTauL .~ (0 %! 1) + +impLookupNativeScript :: ScriptHash -> ImpTestM era (Maybe (NativeScript era)) +impLookupNativeScript sh = Map.lookup sh <$> gets impNativeScripts + +impGetUTxO :: ShelleyEraImp era => TxIn -> ImpTestM era (TxOut era) +impGetUTxO txIn = impAnn "Looking up TxOut" $ do + utxo <- getUTxO + case txinLookup txIn utxo of + Just txOut -> pure txOut + Nothing -> error $ "Failed to get TxOut for " <> show txIn + +produceScript :: + (ShelleyEraImp era, HasCallStack) => + ScriptHash -> + ImpTestM era TxIn +produceScript scriptHash = do + let addr = mkAddr scriptHash StakeRefNull + let tx = + mkBasicTx mkBasicTxBody + & bodyTxL . outputsTxBodyL .~ SSeq.singleton (mkBasicTxOut addr mempty) + logString $ "Produced script: " <> show scriptHash + txInAt 0 <$> submitTx tx + +advanceToPointOfNoReturn :: ImpTestM era () +advanceToPointOfNoReturn = do + impLastTick <- gets impLastTick + (_, slotOfNoReturn, _) <- runShelleyBase $ getTheSlotOfNoReturn impLastTick + impLastTickL .= slotOfNoReturn + +-- | A legal ProtVer that differs in the minor Version +minorFollow :: ProtVer -> ProtVer +minorFollow (ProtVer x y) = ProtVer x (y + 1) + +-- | 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) + +-- | An illegal ProtVer that skips 3 minor versions +cantFollow :: ProtVer -> ProtVer +cantFollow (ProtVer x y) = ProtVer x (y + 3) + +whenMajorVersion :: + forall (v :: Natural) era. + ( EraGov era + , KnownNat v + , MinVersion <= v + , v <= MaxVersion + ) => + ImpTestM era () -> ImpTestM era () +whenMajorVersion a = do + pv <- getProtVer + when (pvMajor pv == natVersion @v) a + +whenMajorVersionAtLeast :: + forall (v :: Natural) era. + ( EraGov era + , KnownNat v + , MinVersion <= v + , v <= MaxVersion + ) => + ImpTestM era () -> ImpTestM era () +whenMajorVersionAtLeast a = do + pv <- getProtVer + when (pvMajor pv >= natVersion @v) a + +whenMajorVersionAtMost :: + forall (v :: Natural) era. + ( EraGov era + , KnownNat v + , MinVersion <= v + , v <= MaxVersion + ) => + ImpTestM era () -> ImpTestM era () +whenMajorVersionAtMost a = do + pv <- getProtVer + when (pvMajor pv <= natVersion @v) a + +unlessMajorVersion :: + forall (v :: Natural) era. + ( EraGov era + , KnownNat v + , MinVersion <= v + , v <= MaxVersion + ) => + 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 From cc5d58495eedfd263da48f79f512caf11d4dc4a3 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 13 Aug 2025 15:23:09 -0600 Subject: [PATCH 05/10] WIP restructure --- .../Test/Cardano/Ledger/Allegra/ImpTest.hs | 2 + .../Test/Cardano/Ledger/Alonzo/ImpTest.hs | 74 +- .../Test/Cardano/Ledger/Babbage/ImpTest.hs | 5 +- .../Cardano/Ledger/Conway/Imp/DelegSpec.hs | 7 +- .../Test/Cardano/Ledger/Conway/Imp/GovSpec.hs | 15 +- .../Cardano/Ledger/Conway/Imp/RatifySpec.hs | 93 +- .../Test/Cardano/Ledger/Conway/ImpTest.hs | 3 +- .../Test/Cardano/Ledger/Dijkstra/ImpTest.hs | 3 +- .../testlib/Test/Cardano/Ledger/Mary/Era.hs | 2 +- .../Test/Cardano/Ledger/Mary/ImpTest.hs | 2 + .../shelley/impl/cardano-ledger-shelley.cabal | 3 - .../Test/Cardano/Ledger/Shelley/Era.hs | 2 +- .../Test/Cardano/Ledger/Shelley/ImpTest.hs | 275 +-- .../src/Cardano/Ledger/Api/Tx/AuxData.hs | 2 + .../cardano-ledger-core.cabal | 6 +- .../src/Cardano/Ledger/Tools.hs | 12 +- .../testlib/Test/Cardano/Ledger/Core/Utils.hs | 22 +- .../testlib/Test/Cardano/Ledger/ImpTest.hs | 1618 +---------------- 18 files changed, 250 insertions(+), 1896 deletions(-) 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..081b36a5d5f 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 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/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/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/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/testlib/Test/Cardano/Ledger/Mary/Era.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Era.hs index a1606c07df3..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,10 +9,10 @@ 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 () -import Paths_cardano_ledger_mary class ( AllegraEraTest 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..120020dcf32 100644 --- a/eras/shelley/impl/cardano-ledger-shelley.cabal +++ b/eras/shelley/impl/cardano-ledger-shelley.cabal @@ -191,14 +191,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/testlib/Test/Cardano/Ledger/Shelley/Era.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Era.hs index 9e7dc3557d9..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,11 +31,11 @@ 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 () import Test.Cardano.Ledger.Shelley.TreeDiff () -import Paths_cardano_ledger_shelley (getDataFileName) class ( EraTest 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..f48025c07f2 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, @@ -141,11 +123,6 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( impNativeScriptsG, produceScript, advanceToPointOfNoReturn, - simulateThenRestore, - - -- * ImpSpec re-exports - ImpM, - ImpInit, ) where import qualified Cardano.Chain.Common as Byron @@ -162,11 +139,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 +178,6 @@ import Cardano.Ledger.Shelley.Rules ( epochFromSlot, ) import Cardano.Ledger.Shelley.Scripts ( - ShelleyEraScript, pattern RequireAllOf, pattern RequireAnyOf, pattern RequireMOf, @@ -222,7 +197,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 +209,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 +223,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 () @@ -329,38 +304,10 @@ data ImpTestState era = ImpTestState , 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}) - impGlobalsL :: Lens' (ImpTestState era) Globals impGlobalsL = lens impGlobals (\x y -> x {impGlobals = y}) @@ -393,7 +340,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,14 +383,6 @@ 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) => m (NewEpochState era) @@ -653,12 +593,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 = @@ -700,6 +638,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 @@ -1306,127 +1245,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 +1356,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 +1503,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 +1522,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 +1535,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 +1548,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 +1561,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/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..9aaf350145f 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -181,6 +181,7 @@ library testlib Test.Cardano.Ledger.Core.Utils Test.Cardano.Ledger.Era Test.Cardano.Ledger.Imp.Common + Test.Cardano.Ledger.ImpTest Test.Cardano.Ledger.Plutus Test.Cardano.Ledger.Plutus.Examples Test.Cardano.Ledger.Plutus.Guardrail @@ -215,7 +216,7 @@ 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, @@ -226,9 +227,12 @@ library testlib 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/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/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/ImpTest.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs index 993f8d0cd1d..26b193900db 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs @@ -21,22 +21,10 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} -module Test.Cardano.Ledger.Shelley.ImpTest ( - ImpTestM, - LedgerSpec, - SomeSTSEvent (..), - ImpTestState, - ImpTestEnv (..), - ImpException (..), - ShelleyEraImp (..), - PlutusArgs, - ScriptTestContext, - impWitsVKeyNeeded, - modifyPrevPParams, - passEpoch, - passNEpochs, - passNEpochsChecking, - passTick, +module Test.Cardano.Ledger.ImpTest ( + EraImp (..), + HasKeyPairs (..), + ImpPrepState (..), freshKeyAddr, freshKeyAddr_, freshKeyHash, @@ -45,77 +33,14 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( freshByronKeyHash, freshBootstapAddress, getByronKeyPair, - freshSafeHash, - freshKeyHashVRF, - submitTx, - submitTx_, - submitTxAnn, - submitTxAnn_, - submitFailingTx, - submitFailingTxM, - trySubmitTx, - impShelleyExpectTxSuccess, - modifyNES, - getProtVer, - getsNES, - getUTxO, - impAddNativeScript, impAnn, impAnnDoc, impLogToExpr, - runImpRule, - tryRunImpRule, - tryRunImpRuleNoAssertions, - delegateStake, - registerRewardAccount, - registerStakeCredential, - getRewardAccountFor, - getReward, - lookupReward, - freshPoolParams, - registerPool, - registerPoolWithRewardAccount, - registerAndRetirePoolToMakeReward, - getBalance, - lookupBalance, - getAccountBalance, - lookupAccountBalance, - getRewardAccountAmount, - shelleyFixupTx, - getImpRootTxOut, - sendValueTo, - sendValueTo_, - sendCoinTo, - sendCoinTo_, - expectUTxOContent, - expectRegisteredRewardAddress, - expectNotRegisteredRewardAddress, - expectTreasury, - disableTreasuryExpansion, - updateAddrTxWits, - addNativeScriptTxWits, - addRootTxIn, - fixupTxOuts, - fixupFees, - fixupAuxDataHash, - impLookupNativeScript, - impGetUTxO, - defaultInitNewEpochState, - defaultInitImpTestState, - impEraStartEpochNo, impSetSeed, - modifyImpInitProtVer, - modifyImpInitPostSubmitTxHook, - disableImpInitPostSubmitTxHook, - minorFollow, - majorFollow, - cantFollow, - whenMajorVersion, - whenMajorVersionAtLeast, - whenMajorVersionAtMost, - unlessMajorVersion, - getsPParams, - withEachEraVersion, + genSafeHash, + genVRFVerKeyHash, + genPoolParams, + genProtVerCantFollow, -- * Logging Doc, @@ -124,210 +49,40 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( logText, logString, logToExpr, - logInstantStake, - logFeeMismatch, -- * Combinators - withCustomFixup, - withFixup, - withNoFixup, - withPostFixup, - withPreFixup, - withCborRoundTripFailures, - impNESL, - impGlobalsL, - impLastTickG, - impKeyPairsG, - impNativeScriptsG, - produceScript, - advanceToPointOfNoReturn, simulateThenRestore, -- * ImpSpec re-exports ImpM, ImpInit, + ImpException (..), ) where import qualified Cardano.Chain.Common as Byron -import qualified Cardano.Chain.UTxO as Byron (empty) -import Cardano.Ledger.Address ( - Addr (..), - BootstrapAddress (..), - RewardAccount (..), - bootstrapKeyHash, - ) -import Cardano.Ledger.BHeaderView (BHeaderView) +import Cardano.Ledger.Address import Cardano.Ledger.BaseTypes -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.Core +import Cardano.Ledger.Credential (Ptr) import Cardano.Ledger.Genesis (EraGenesis (..), NoGenesis (..)) -import Cardano.Ledger.Keys ( - HasKeyRole (..), - asWitness, - bootstrapWitKeyHash, - makeBootstrapWitness, - witVKeyHash, - ) -import Cardano.Ledger.Shelley (ShelleyEra) -import Cardano.Ledger.Shelley.API.ByronTranslation (translateToShelleyLedgerStateFromUtxo) -import Cardano.Ledger.Shelley.AdaPots (sumAdaPots, totalAdaPotsES) -import Cardano.Ledger.Shelley.Core -import Cardano.Ledger.Shelley.Genesis ( - ShelleyGenesis (..), - describeValidationErr, - fromNominalDiffTimeMicro, - mkShelleyGlobals, - validateGenesis, - ) -import Cardano.Ledger.Shelley.LedgerState ( - LedgerState (..), - NewEpochState (..), - curPParamsEpochStateL, - esLStateL, - lsCertStateL, - lsUTxOStateL, - nesELL, - nesEsL, - prevPParamsEpochStateL, - produced, - utxosDonationL, - ) -import Cardano.Ledger.Shelley.Rules ( - BbodyEnv (..), - LedgerEnv (..), - ShelleyBbodyState, - epochFromSlot, - ) -import Cardano.Ledger.Shelley.Scripts ( - ShelleyEraScript, - pattern RequireAllOf, - pattern RequireAnyOf, - pattern RequireMOf, - pattern RequireSignature, - ) -import Cardano.Ledger.Shelley.State hiding (balance) -import Cardano.Ledger.Shelley.Translation (toFromByronTranslationContext) -import Cardano.Ledger.Slot (epochInfoFirst, getTheSlotOfNoReturn) -import Cardano.Ledger.Tools ( - calcMinFeeTxNativeScriptWits, - ensureMinCoinTxOut, - ) -import Cardano.Ledger.TxIn (TxId (..), TxIn (..)) -import Cardano.Ledger.Val (Val (..)) -import Cardano.Slotting.EpochInfo (fixedEpochInfo) -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.Trans.Fail.String (errorFail) -import Control.Monad.Trans.Reader (ReaderT (..)) -import Control.Monad.Writer.Class (MonadWriter (..)) -import Control.State.Transition (STS (..), TRC (..), applySTSOptsEither) -import Control.State.Transition.Extended ( - ApplySTSOpts (..), - AssertionPolicy (..), - SingEP (..), - ValidationPolicy (..), - ) -import Data.Bifunctor (first) +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.Data (Proxy (..), type (:~:) (..)) -import Data.Default (Default (..)) -import Data.Foldable (toList, traverse_) -import Data.Functor (($>)) -import Data.Functor.Identity (Identity (..)) -import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, isNothing, mapMaybe) -import Data.Ratio ((%)) -import Data.Sequence.Strict (StrictSeq (..)) -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 Lens.Micro (Lens', lens, (%~)) +import Lens.Micro.Mtl (use) 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.Rational ((%!)) -import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash, txInAt) +import Test.Cardano.Ledger.Core.KeyPair (ByronKeyPair (..), mkStakeRef) +import Test.Cardano.Ledger.Era (EraTest) import Test.Cardano.Ledger.Imp.Common -import Test.Cardano.Ledger.Plutus (PlutusArgs, ScriptTestContext) -import Test.Cardano.Ledger.Shelley.Era -import Test.Cardano.Ledger.Shelley.TreeDiff (Expr (..)) import Test.Cardano.Slotting.Numeric () import Test.ImpSpec -import Type.Reflection (Typeable, typeOf) -import UnliftIO (evaluateDeep) - -type ImpTestM era = ImpM (LedgerSpec era) - -data LedgerSpec era - -instance ShelleyEraImp era => ImpSpec (LedgerSpec era) where - type ImpSpecEnv (LedgerSpec era) = ImpTestEnv era - type ImpSpecState (LedgerSpec era) = ImpTestState era - impInitIO qcGen = do - ioGen <- R.newIOGenM qcGen - initState <- evalStateT (runReaderT initImpTestState ioGen) (mempty :: ImpPrepState) - pure $ - ImpInit - { impInitEnv = - ImpTestEnv - { iteFixup = fixupTx - , iteCborRoundTripFailures = True - , itePostSubmitTxHook = \_ _ _ -> pure () - } - , impInitState = initState - } - - -- There is an important step here of running TICK rule. This is necessary as a final - -- step of `era` initialization, because on the very first TICK of an era the - -- `futurePParams` are applied and the epoch number is updated to the first epoch - -- number of the current era - impPrepAction = passTick - -data SomeSTSEvent era - = forall (rule :: Symbol). - ( Typeable (Event (EraRule rule era)) - , Eq (Event (EraRule rule era)) - , ToExpr (Event (EraRule rule era)) - ) => - SomeSTSEvent (Event (EraRule rule era)) - -instance Eq (SomeSTSEvent era) where - SomeSTSEvent x == SomeSTSEvent y - | Just Refl <- testEquality (typeOf x) (typeOf y) = x == y - | otherwise = False - -instance ToExpr (SomeSTSEvent era) where - toExpr (SomeSTSEvent ev) = App "SomeSTSEvent" [toExpr ev] - -data ImpTestState era = ImpTestState - { impNES :: !(NewEpochState era) - , impRootTxIn :: !TxIn - , impKeyPairs :: !(Map (KeyHash 'Witness) (KeyPair 'Witness)) - , impByronKeyPairs :: !(Map BootstrapAddress ByronKeyPair) - , 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 @@ -353,88 +108,11 @@ 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}) -impGlobalsL :: Lens' (ImpTestState era) Globals -impGlobalsL = lens impGlobals (\x y -> x {impGlobals = y}) - -impNESL :: Lens' (ImpTestState era) (NewEpochState era) -impNESL = lens impNES (\x y -> x {impNES = y}) - -impLastTickL :: Lens' (ImpTestState era) SlotNo -impLastTickL = lens impLastTick (\x y -> x {impLastTick = y}) - -impLastTickG :: SimpleGetter (ImpTestState era) SlotNo -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}) - -impNativeScriptsG :: - SimpleGetter (ImpTestState era) (Map ScriptHash (NativeScript era)) -impNativeScriptsG = impNativeScriptsL - -impEventsL :: Lens' (ImpTestState era) [SomeSTSEvent era] -impEventsL = lens impEvents (\x y -> x {impEvents = y}) - -class - ( ShelleyEraTxCert era - , ShelleyEraTest era - , -- For BBODY rule - STS (EraRule "BBODY" era) - , BaseM (EraRule "BBODY" era) ~ ShelleyBase - , Environment (EraRule "BBODY" era) ~ BbodyEnv era - , State (EraRule "BBODY" era) ~ ShelleyBbodyState era - , Signal (EraRule "BBODY" era) ~ Block BHeaderView era - , State (EraRule "LEDGERS" era) ~ LedgerState era - , -- For the LEDGER rule - STS (EraRule "LEDGER" era) - , BaseM (EraRule "LEDGER" era) ~ ShelleyBase - , Signal (EraRule "LEDGER" era) ~ Tx era - , State (EraRule "LEDGER" era) ~ LedgerState era - , Environment (EraRule "LEDGER" era) ~ LedgerEnv era - , Eq (PredicateFailure (EraRule "LEDGER" era)) - , Show (PredicateFailure (EraRule "LEDGER" era)) - , ToExpr (PredicateFailure (EraRule "LEDGER" era)) - , NFData (PredicateFailure (EraRule "LEDGER" era)) - , EncCBOR (PredicateFailure (EraRule "LEDGER" era)) - , DecCBOR (PredicateFailure (EraRule "LEDGER" era)) - , EraRuleEvent "LEDGER" era ~ Event (EraRule "LEDGER" era) - , Eq (EraRuleEvent "LEDGER" era) - , ToExpr (EraRuleEvent "LEDGER" era) - , NFData (EraRuleEvent "LEDGER" era) - , Typeable (EraRuleEvent "LEDGER" era) - , -- For the TICK rule - STS (EraRule "TICK" era) - , BaseM (EraRule "TICK" era) ~ ShelleyBase - , Signal (EraRule "TICK" era) ~ SlotNo - , State (EraRule "TICK" era) ~ NewEpochState era - , Environment (EraRule "TICK" era) ~ () - , NFData (PredicateFailure (EraRule "TICK" era)) - , EraRuleEvent "TICK" era ~ Event (EraRule "TICK" era) - , Eq (EraRuleEvent "TICK" era) - , ToExpr (EraRuleEvent "TICK" era) - , NFData (EraRuleEvent "TICK" era) - , Typeable (EraRuleEvent "TICK" era) - , ToExpr (PredicateFailure (EraRule "UTXOW" era)) - ) => - ShelleyEraImp era - where +class EraTest era => EraImp era where initGenesis :: (HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) => m (Genesis era) @@ -443,887 +121,48 @@ class m (Genesis era) initGenesis = pure NoGenesis - initNewEpochState :: - (HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) => - m (NewEpochState era) - default initNewEpochState :: - ( HasKeyPairs s - , MonadState s m - , HasStatefulGen g m - , MonadFail m - , ShelleyEraImp (PreviousEra era) - , TranslateEra era NewEpochState - , TranslationError era NewEpochState ~ Void - , TranslationContext era ~ Genesis era - ) => - m (NewEpochState era) - initNewEpochState = defaultInitNewEpochState id - - initImpTestState :: - ( HasKeyPairs s - , MonadState s m - , HasStatefulGen g m - , MonadFail m - ) => - m (ImpTestState era) - initImpTestState = initNewEpochState >>= defaultInitImpTestState - - -- | Try to find a sufficient number of KeyPairs that would satisfy a native script. - -- Whenever script can't be satisfied, Nothing is returned - impSatisfyNativeScript :: - -- | Set of Witnesses that have already been satisfied - Set.Set (KeyHash 'Witness) -> - -- | The transaction body that the script will be applied to - TxBody era -> - NativeScript era -> - ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness))) - - -- | This modifer should change not only the current PParams, but also the future - -- PParams. If the future PParams are not updated, then they will overwrite the - -- mofication of the current PParams at the next epoch. - modifyPParams :: - (PParams era -> PParams era) -> - ImpTestM era () - modifyPParams f = modifyNES $ nesEsL . curPParamsEpochStateL %~ f - - fixupTx :: HasCallStack => Tx era -> ImpTestM era (Tx era) - - expectTxSuccess :: HasCallStack => Tx era -> ImpTestM era () - -defaultInitNewEpochState :: - forall era g s m. - ( MonadState s m - , HasKeyPairs s - , HasStatefulGen g m - , MonadFail m - , ShelleyEraImp era - , ShelleyEraImp (PreviousEra era) - , TranslateEra era NewEpochState - , TranslationError era NewEpochState ~ Void - , TranslationContext era ~ Genesis era - ) => - (NewEpochState (PreviousEra era) -> NewEpochState (PreviousEra era)) -> - m (NewEpochState era) -defaultInitNewEpochState modifyPrevEraNewEpochState = do - genesis <- initGenesis @era - nes <- initNewEpochState @(PreviousEra era) - let majProtVer = eraProtVerLow @era - -- We need to set the protocol version for the current era and for debugging - -- purposes we start the era at the epoch number that matches the protocol version - -- times a 100. However, because this is the NewEpochState from the previous era, we - -- initialize it with futurePParams preset and epoch number that is one behind the - -- beginning of this era. Note that all imp tests will start with a TICK, in order - -- for theses changes to be applied. - prevEraNewEpochState = - nes - & nesEsL . curPParamsEpochStateL . ppProtocolVersionL .~ ProtVer majProtVer 0 - & nesELL .~ pred (impEraStartEpochNo @era) - pure $ translateEra' genesis $ modifyPrevEraNewEpochState prevEraNewEpochState - --- | For debugging purposes we start the era at the epoch number that matches the starting --- protocol version for the era times a 100 -impEraStartEpochNo :: forall era. Era era => EpochNo -impEraStartEpochNo = EpochNo (getVersion majProtVer * 100) - where - majProtVer = eraProtVerLow @era - -defaultInitImpTestState :: - forall era s g m. - ( EraGov era - , EraTxOut era - , HasKeyPairs s - , MonadState s m - , HasStatefulGen g m - , MonadFail m - ) => - NewEpochState era -> - m (ImpTestState era) -defaultInitImpTestState nes = do - shelleyGenesis <- initGenesis @ShelleyEra - rootKeyHash <- freshKeyHash @'Payment - let - rootAddr :: Addr - rootAddr = mkAddr rootKeyHash StakeRefNull - rootTxOut :: TxOut era - rootTxOut = mkBasicTxOut rootAddr $ inject rootCoin - rootCoin = Coin (toInteger (sgMaxLovelaceSupply shelleyGenesis)) - rootTxIn :: TxIn - rootTxIn = TxIn (mkTxId 0) minBound - nesWithRoot = nes & utxoL <>~ UTxO (Map.singleton rootTxIn rootTxOut) - prepState <- get - let epochInfoE = - fixedEpochInfo - (sgEpochLength shelleyGenesis) - (mkSlotLength . fromNominalDiffTimeMicro $ sgSlotLength shelleyGenesis) - globals = mkShelleyGlobals shelleyGenesis epochInfoE - epochNo = nesWithRoot ^. nesELL - slotNo = epochInfoFirst (epochInfoPure globals) epochNo - pure $ - ImpTestState - { impNES = nesWithRoot - , impRootTxIn = rootTxIn - , impKeyPairs = prepState ^. keyPairsL - , impByronKeyPairs = prepState ^. keyPairsByronL - , impNativeScripts = mempty - , impLastTick = slotNo - , impGlobals = globals - , impEvents = mempty - } - -withEachEraVersion :: - forall era. - ShelleyEraImp era => - SpecWith (ImpInit (LedgerSpec era)) -> - Spec -withEachEraVersion specWith = - withImpInit @(LedgerSpec era) $ do - forM_ (eraProtVersions @era) $ \protVer -> - describe (show protVer) $ - modifyImpInitProtVer protVer specWith - -modifyImpInitProtVer :: - forall era. - ShelleyEraImp era => - Version -> - SpecWith (ImpInit (LedgerSpec era)) -> - SpecWith (ImpInit (LedgerSpec era)) -modifyImpInitProtVer ver = - modifyImpInit $ \impInit -> - impInit - { impInitState = - impInitState impInit - & impNESL - . nesEsL - . curPParamsEpochStateL - . ppProtocolVersionL - .~ ProtVer ver 0 - } - -modifyImpInitPostSubmitTxHook :: - forall era. - ( forall t. - Globals -> - TRC (EraRule "LEDGER" era) -> - Either - (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) - (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) -> - ImpM t () - ) -> - SpecWith (ImpInit (LedgerSpec era)) -> - SpecWith (ImpInit (LedgerSpec era)) -modifyImpInitPostSubmitTxHook f = - modifyImpInit $ \impInit -> - impInit - { impInitEnv = - impInitEnv impInit - & itePostSubmitTxHookL .~ f - } - -disableImpInitPostSubmitTxHook :: - SpecWith (ImpInit (LedgerSpec era)) -> - SpecWith (ImpInit (LedgerSpec era)) -disableImpInitPostSubmitTxHook = - modifyImpInitPostSubmitTxHook $ \_ _ _ -> pure () - -impLedgerEnv :: EraGov era => NewEpochState era -> ImpTestM era (LedgerEnv era) -impLedgerEnv nes = do - slotNo <- gets impLastTick - epochNo <- runShelleyBase $ epochFromSlot slotNo - pure - LedgerEnv - { ledgerSlotNo = slotNo - , ledgerEpochNo = Just epochNo - , ledgerPp = nes ^. nesEsL . curPParamsEpochStateL - , ledgerIx = TxIx 0 - , ledgerAccount = nes ^. chainAccountStateL - } - --- | Modify the previous PParams in the current state with the given function. For current --- and future PParams, use `modifyPParams` -modifyPrevPParams :: - EraGov era => - (PParams era -> PParams era) -> - ImpTestM era () -modifyPrevPParams f = modifyNES $ nesEsL . prevPParamsEpochStateL %~ f - --- | Logs the current stake distribution -logInstantStake :: ToExpr (InstantStake era) => HasCallStack => ImpTestM era () -logInstantStake = do - stakeDistr <- getsNES instantStakeG - logDoc $ "Instant Stake: " <> ansiExpr stakeDistr - -mkTxId :: Int -> TxId -mkTxId idx = TxId (mkDummySafeHash idx) - -instance - ShelleyEraScript ShelleyEra => - ShelleyEraImp ShelleyEra - where - initGenesis = do - let - gen = - ShelleyGenesis - { sgSystemStart = errorFail $ iso8601ParseM "2017-09-23T21:44:51Z" - , sgNetworkMagic = 123_456 -- Mainnet value: 764824073 - , sgNetworkId = Testnet - , sgActiveSlotsCoeff = 20 %! 100 -- Mainnet value: 5 %! 100 - , sgSecurityParam = knownNonZeroBounded @108 -- Mainnet value: 2160 - , sgEpochLength = 4320 -- Mainnet value: 432000 - , sgSlotsPerKESPeriod = 129_600 - , sgMaxKESEvolutions = 62 - , sgSlotLength = 1 - , sgUpdateQuorum = 5 - , sgMaxLovelaceSupply = 45_000_000_000_000_000 - , sgProtocolParams = - emptyPParams - & ppMinFeeAL .~ Coin 44 - & ppMinFeeBL .~ Coin 155_381 - & ppMaxBBSizeL .~ 65_536 - & ppMaxTxSizeL .~ 16_384 - & ppKeyDepositL .~ Coin 2_000_000 - & ppPoolDepositL .~ Coin 500_000_000 - & ppEMaxL .~ EpochInterval 18 - & ppNOptL .~ 150 - & ppA0L .~ (3 %! 10) - & ppRhoL .~ (3 %! 1000) - & ppTauL .~ (2 %! 10) - & ppDL .~ (1 %! 1) - & ppExtraEntropyL .~ NeutralNonce - & ppMinUTxOValueL .~ Coin 2_000_000 - & ppMinPoolCostL .~ Coin 340_000_000 - , -- TODO: Add a top level definition and add private keys to ImpState: - sgGenDelegs = mempty - , sgInitialFunds = mempty - , sgStaking = mempty - } - case validateGenesis gen of - Right () -> pure gen - Left errs -> fail . T.unpack . T.unlines $ map describeValidationErr errs - - initNewEpochState = do - shelleyGenesis <- initGenesis @ShelleyEra - let transContext = toFromByronTranslationContext shelleyGenesis - startEpochNo = impEraStartEpochNo @ShelleyEra - pure $ translateToShelleyLedgerStateFromUtxo transContext startEpochNo Byron.empty - - impSatisfyNativeScript providedVKeyHashes _txBody script = do - keyPairs <- gets impKeyPairs - let - satisfyMOf m Empty - | m <= 0 = Just mempty - | otherwise = Nothing - satisfyMOf m (x :<| xs) = - case satisfyScript x of - Nothing -> satisfyMOf m xs - Just kps -> do - kps' <- satisfyMOf (m - 1) xs - Just $ kps <> kps' - satisfyScript = \case - RequireSignature keyHash - | keyHash `Set.member` providedVKeyHashes -> Just mempty - | otherwise -> do - keyPair <- Map.lookup keyHash keyPairs - Just $ Map.singleton keyHash keyPair - RequireAllOf ss -> satisfyMOf (length ss) ss - RequireAnyOf ss -> satisfyMOf 1 ss - RequireMOf m ss -> satisfyMOf m ss - _ -> error "Impossible: All NativeScripts should have been accounted for" - - pure $ satisfyScript script - - fixupTx = shelleyFixupTx - expectTxSuccess = impShelleyExpectTxSuccess - --- | Figure out all the Byron Addresses that need witnesses as well as all of the --- KeyHashes for Shelley Key witnesses that are required. -impWitsVKeyNeeded :: - EraUTxO era => - TxBody era -> - ImpTestM - era - ( Set.Set BootstrapAddress -- Byron Based Addresses - , Set.Set (KeyHash 'Witness) -- Shelley Based KeyHashes - ) -impWitsVKeyNeeded txBody = do - ls <- getsNES (nesEsL . esLStateL) - utxo <- getUTxO - let toBootAddr txIn = do - txOut <- txinLookup txIn utxo - txOut ^. bootAddrTxOutF - bootAddrs = Set.fromList $ mapMaybe toBootAddr $ Set.toList (txBody ^. spendableInputsTxBodyF) - bootKeyHashes = Set.map (coerceKeyRole . bootstrapKeyHash) bootAddrs - allKeyHashes = - getWitsVKeyNeeded (ls ^. lsCertStateL) (ls ^. utxoL) txBody - pure (bootAddrs, allKeyHashes Set.\\ bootKeyHashes) - -data ImpTestEnv era = ImpTestEnv - { iteFixup :: Tx era -> ImpTestM era (Tx era) - , itePostSubmitTxHook :: - forall t. - Globals -> - TRC (EraRule "LEDGER" era) -> - Either - (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) - (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) -> - ImpM t () - , iteCborRoundTripFailures :: Bool - -- ^ Expect failures in CBOR round trip serialization tests for predicate failures - } - -iteFixupL :: Lens' (ImpTestEnv era) (Tx era -> ImpTestM era (Tx era)) -iteFixupL = lens iteFixup (\x y -> x {iteFixup = y}) - -itePostSubmitTxHookL :: - forall era. - Lens' - (ImpTestEnv era) - ( forall t. - Globals -> - TRC (EraRule "LEDGER" era) -> - Either - (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) - (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) -> - ImpM t () - ) -itePostSubmitTxHookL = lens itePostSubmitTxHook (\x y -> x {itePostSubmitTxHook = y}) - -iteCborRoundTripFailuresL :: Lens' (ImpTestEnv era) Bool -iteCborRoundTripFailuresL = lens iteCborRoundTripFailures (\x y -> x {iteCborRoundTripFailures = y}) - -instance MonadWriter [SomeSTSEvent era] (ImpTestM era) where - writer (x, evs) = (impEventsL %= (<> evs)) $> x - listen act = do - oldEvs <- use impEventsL - impEventsL .= mempty - res <- act - newEvs <- use impEventsL - impEventsL .= oldEvs - pure (res, newEvs) - pass act = do - ((a, f), evs) <- listen act - writer (a, f evs) - -runShelleyBase :: ShelleyBase a -> ImpTestM era a -runShelleyBase act = do - globals <- use impGlobalsL - pure $ runIdentity $ runReaderT act globals - -getRewardAccountAmount :: (HasCallStack, EraCertState era) => RewardAccount -> ImpTestM era Coin -getRewardAccountAmount = getAccountBalance -{-# DEPRECATED getRewardAccountAmount "In favor of `getAccountBalance`" #-} - -lookupBalance :: EraCertState era => Credential 'Staking -> ImpTestM era (Maybe Coin) -lookupBalance cred = do - accountsMap <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL . accountsMapL - pure $ - (\accountState -> fromCompact (accountState ^. balanceAccountStateL)) - <$> Map.lookup cred accountsMap - -lookupAccountBalance :: - (HasCallStack, EraCertState era) => RewardAccount -> ImpTestM era (Maybe Coin) -lookupAccountBalance ra@RewardAccount {raNetwork, raCredential} = do - networkId <- use (impGlobalsL . to networkId) - when (raNetwork /= networkId) $ - error $ - "Reward Account with an unexpected NetworkId: " ++ show ra - lookupBalance raCredential - -getBalance :: (HasCallStack, EraCertState era) => Credential 'Staking -> ImpTestM era Coin -getBalance cred = - lookupBalance cred >>= \case - Nothing -> - assertFailure $ - "Expected a registered account: " - ++ show cred - ++ ". Use `registerRewardAccount` to register a new account in ImpSpec" - Just balance -> pure balance - -getAccountBalance :: (HasCallStack, EraCertState era) => RewardAccount -> ImpTestM era Coin -getAccountBalance ra = - lookupAccountBalance ra >>= \case - Nothing -> - assertFailure $ - "Expected a registered account: " - ++ show ra - ++ ". Use `registerRewardAccount` to register a new account in ImpSpec" - Just balance -> pure balance - -getImpRootTxOut :: ImpTestM era (TxIn, TxOut era) -getImpRootTxOut = do - ImpTestState {impRootTxIn} <- get - utxo <- getUTxO - case txinLookup impRootTxIn utxo of - Nothing -> error "Root txId no longer points to an existing unspent output" - Just rootTxOut -> pure (impRootTxIn, rootTxOut) - -impAddNativeScript :: - forall era. - EraScript era => - NativeScript era -> - ImpTestM era ScriptHash -impAddNativeScript nativeScript = do - let script = fromNativeScript nativeScript - scriptHash = hashScript @era script - impNativeScriptsL %= Map.insert scriptHash nativeScript - pure scriptHash - -impNativeScriptsRequired :: - EraUTxO era => - Tx era -> - ImpTestM era (Map ScriptHash (NativeScript era)) -impNativeScriptsRequired tx = do - utxo <- getUTxO - ImpTestState {impNativeScripts} <- get - let needed = getScriptsNeeded utxo (tx ^. bodyTxL) - hashesNeeded = getScriptsHashesNeeded needed - pure $ impNativeScripts `Map.restrictKeys` hashesNeeded - --- | Modifies transaction by adding necessary scripts -addNativeScriptTxWits :: - ShelleyEraImp era => - Tx era -> - ImpTestM era (Tx era) -addNativeScriptTxWits tx = impAnn "addNativeScriptTxWits" $ do - scriptsRequired <- impNativeScriptsRequired tx - utxo <- getUTxO - let ScriptsProvided provided = getScriptsProvided utxo tx - scriptsToAdd = scriptsRequired Map.\\ provided - pure $ - tx - & witsTxL . scriptTxWitsL <>~ fmap fromNativeScript scriptsToAdd - --- | Adds @TxWits@ that will satisfy all of the required key witnesses -updateAddrTxWits :: - ( HasCallStack - , ShelleyEraImp era - ) => - Tx era -> - ImpTestM era (Tx era) -updateAddrTxWits tx = impAnn "updateAddrTxWits" $ do - let txBody = tx ^. bodyTxL - txBodyHash = hashAnnotated txBody - (bootAddrs, witsVKeyNeeded) <- impWitsVKeyNeeded txBody - -- Shelley Based Addr Witnesses - let curAddrWitHashes = Set.map witVKeyHash $ tx ^. witsTxL . addrTxWitsL - extraKeyPairs <- mapM getKeyPair $ Set.toList (witsVKeyNeeded Set.\\ curAddrWitHashes) - let extraAddrVKeyWits = mkWitnessesVKey txBodyHash extraKeyPairs - addrWitHashes = curAddrWitHashes <> Set.map witVKeyHash extraAddrVKeyWits - -- Shelley Based Native Script Witnesses - scriptsRequired <- impNativeScriptsRequired tx - nativeScriptsKeyPairs <- - mapM (impSatisfyNativeScript addrWitHashes txBody) (Map.elems scriptsRequired) - let extraNativeScriptVKeyWits = - mkWitnessesVKey txBodyHash $ Map.elems (mconcat (catMaybes nativeScriptsKeyPairs)) - -- Byron Based Witessed - let curBootAddrWitHashes = Set.map bootstrapWitKeyHash $ tx ^. witsTxL . bootAddrTxWitsL - bootAddrWitsNeeded = - [ bootAddr - | bootAddr <- Set.toList bootAddrs - , not (coerceKeyRole (bootstrapKeyHash bootAddr) `Set.member` curBootAddrWitHashes) - ] - extraBootAddrWits <- forM bootAddrWitsNeeded $ \bootAddr@(BootstrapAddress byronAddr) -> do - ByronKeyPair _ signingKey <- getByronKeyPair bootAddr - let attrs = Byron.addrAttributes byronAddr - pure $ makeBootstrapWitness (extractHash txBodyHash) signingKey attrs - pure $ - tx - & witsTxL . addrTxWitsL <>~ extraAddrVKeyWits <> extraNativeScriptVKeyWits - & witsTxL . bootAddrTxWitsL <>~ Set.fromList extraBootAddrWits - --- | This fixup step ensures that there are enough funds in the transaction. -addRootTxIn :: - ShelleyEraImp era => - Tx era -> - ImpTestM era (Tx era) -addRootTxIn tx = impAnn "addRootTxIn" $ do - rootTxIn <- fst <$> getImpRootTxOut - pure $ - tx - & bodyTxL . inputsTxBodyL %~ Set.insert rootTxIn - -impNativeScriptKeyPairs :: - ShelleyEraImp era => - Tx era -> - ImpTestM - era - (Map (KeyHash 'Witness) (KeyPair 'Witness)) -impNativeScriptKeyPairs tx = do - scriptsRequired <- impNativeScriptsRequired tx - let nativeScripts = Map.elems scriptsRequired - curAddrWits = Set.map witVKeyHash $ tx ^. witsTxL . addrTxWitsL - keyPairs <- mapM (impSatisfyNativeScript curAddrWits $ tx ^. bodyTxL) nativeScripts - pure . mconcat $ catMaybes keyPairs - -fixupTxOuts :: (ShelleyEraImp era, HasCallStack) => Tx era -> ImpTestM era (Tx era) -fixupTxOuts tx = do - pp <- getsNES $ nesEsL . curPParamsEpochStateL - let - txOuts = tx ^. bodyTxL . outputsTxBodyL - fixedUpTxOuts <- forM txOuts $ \txOut -> do - if txOut ^. coinTxOutL == zero - then do - amount <- arbitrary - let txOut' = ensureMinCoinTxOut pp (txOut & coinTxOutL .~ amount) - logDoc $ - "Fixed up the amount in the TxOut to " <> ansiExpr (txOut' ^. coinTxOutL) - pure txOut' - else do - pure txOut - pure $ tx & bodyTxL . outputsTxBodyL .~ fixedUpTxOuts - -fixupFees :: - (ShelleyEraImp era, HasCallStack) => - Tx era -> - ImpTestM era (Tx era) -fixupFees txOriginal = impAnn "fixupFees" $ do - -- Fee will be overwritten later on, unless it wasn't set to zero to begin with: - let tx = txOriginal & bodyTxL . feeTxBodyL .~ zero - pp <- getsNES $ nesEsL . curPParamsEpochStateL - utxo <- getUTxO - certState <- getsNES $ nesEsL . esLStateL . lsCertStateL - addr <- freshKeyAddr_ - nativeScriptKeyPairs <- impNativeScriptKeyPairs tx - let - nativeScriptKeyWits = Map.keysSet nativeScriptKeyPairs - consumedValue = consumed pp certState utxo (tx ^. bodyTxL) - producedValue = produced pp certState (tx ^. bodyTxL) - ensureNonNegativeCoin v - | pointwise (<=) zero v = pure v - | otherwise = do - logDoc $ "Failed to validate coin: " <> ansiExpr v - pure zero - logString "Validating changeBeforeFee" - changeBeforeFee <- ensureNonNegativeCoin $ coin consumedValue <-> coin producedValue - logToExpr changeBeforeFee - let - changeBeforeFeeTxOut = mkBasicTxOut addr (inject changeBeforeFee) - txNoWits = tx & bodyTxL . outputsTxBodyL %~ (:|> changeBeforeFeeTxOut) - outsBeforeFee = tx ^. bodyTxL . outputsTxBodyL - suppliedFee = txOriginal ^. bodyTxL . feeTxBodyL - fee0 - | suppliedFee == zero = calcMinFeeTxNativeScriptWits utxo pp txNoWits nativeScriptKeyWits - | otherwise = suppliedFee - fee = rationalToCoinViaCeiling $ coinToRational fee0 * (11 % 10) - logString "Validating change" - change <- ensureNonNegativeCoin $ changeBeforeFeeTxOut ^. coinTxOutL <-> fee - logToExpr change - let - changeTxOut = changeBeforeFeeTxOut & coinTxOutL .~ change - -- If the remainder is sufficently big we add it to outputs, otherwise we add the - -- extraneous coin to the fee and discard the remainder TxOut - txWithFee - | change >= getMinCoinTxOut pp changeTxOut = - txNoWits - & bodyTxL . outputsTxBodyL .~ (outsBeforeFee :|> changeTxOut) - & bodyTxL . feeTxBodyL .~ fee - | otherwise = - txNoWits - & bodyTxL . outputsTxBodyL .~ outsBeforeFee - & bodyTxL . feeTxBodyL .~ (fee <> change) - pure txWithFee - --- | Adds an auxiliary data hash if auxiliary data present, while the hash of it is not. -fixupAuxDataHash :: (EraTx era, Applicative m) => Tx era -> m (Tx era) -fixupAuxDataHash tx - | SNothing <- tx ^. bodyTxL . auxDataHashTxBodyL - , SJust auxData <- tx ^. auxDataTxL = - pure (tx & bodyTxL . auxDataHashTxBodyL .~ SJust (TxAuxDataHash (hashAnnotated auxData))) - | otherwise = pure tx - -shelleyFixupTx :: - forall era. - (ShelleyEraImp era, HasCallStack) => - Tx era -> - ImpTestM era (Tx era) -shelleyFixupTx = - addNativeScriptTxWits - >=> fixupAuxDataHash - >=> addRootTxIn - >=> fixupTxOuts - >=> fixupFees - >=> updateAddrTxWits - >=> (\tx -> logFeeMismatch tx $> tx) - -impShelleyExpectTxSuccess :: - forall era. - (ShelleyEraImp era, HasCallStack) => - Tx era -> - ImpTestM era () -impShelleyExpectTxSuccess tx = do - utxo <- getsNES utxoL - let inputs = tx ^. bodyTxL . inputsTxBodyL - outputs = Map.toList . unUTxO . txouts $ tx ^. bodyTxL - impAnn "Inputs should be gone from UTxO" $ - expectUTxOContent utxo [(txIn, isNothing) | txIn <- Set.toList inputs] - impAnn "Outputs should be in UTxO" $ - expectUTxOContent utxo [(txIn, (== Just txOut)) | (txIn, txOut) <- outputs] - -logFeeMismatch :: (EraGov era, EraUTxO era, HasCallStack) => Tx era -> ImpTestM era () -logFeeMismatch tx = do - pp <- getsNES $ nesEsL . curPParamsEpochStateL - utxo <- getsNES utxoL - let Coin feeUsed = tx ^. bodyTxL . feeTxBodyL - Coin feeMin = getMinFeeTxUtxo pp tx utxo - when (feeUsed /= feeMin) $ do - logDoc $ - "Estimated fee " <> ansiExpr feeUsed <> " while required fee is " <> ansiExpr feeMin - -submitTx_ :: (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era () -submitTx_ = void . submitTx - -submitTx :: (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era (Tx era) -submitTx tx = trySubmitTx tx >>= expectRightDeepExpr . first fst - -trySubmitTx :: - forall era. - ( ShelleyEraImp era - , HasCallStack - ) => - Tx era -> - ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era) (Tx era)) -trySubmitTx tx = do - txFixed <- asks iteFixup >>= ($ tx) - logToExpr txFixed - st <- gets impNES - lEnv <- impLedgerEnv st - ImpTestState {impRootTxIn} <- get - res <- tryRunImpRule @"LEDGER" lEnv (st ^. nesEsL . esLStateL) txFixed - roundTripCheck <- asks iteCborRoundTripFailures - globals <- use impGlobalsL - let trc = TRC (lEnv, st ^. nesEsL . esLStateL, txFixed) - - -- Check for conformance - asks itePostSubmitTxHook >>= (\f -> f globals trc res) - - case res of - Left predFailures -> do - -- Verify that produced predicate failures are ready for the node-to-client protocol - if roundTripCheck - then liftIO $ forM_ predFailures $ roundTripEraExpectation @era - else - liftIO $ - roundTripCborRangeFailureExpectation - (eraProtVerLow @era) - (eraProtVerHigh @era) - predFailures - pure $ Left (predFailures, txFixed) - Right (st', events) -> do - let txId = TxId . hashAnnotated $ txFixed ^. bodyTxL - outsSize = SSeq.length $ txFixed ^. bodyTxL . outputsTxBodyL - rootIndex - | outsSize > 0 = outsSize - 1 - | otherwise = error ("Expected at least 1 output after submitting tx: " <> show txId) - tell $ fmap (SomeSTSEvent @era @"LEDGER") events - modify $ impNESL . nesEsL . esLStateL .~ st' - UTxO utxo <- getUTxO - -- This TxIn is in the utxo, and thus can be the new root, only if the transaction - -- was phase2-valid. Otherwise, no utxo with this id would have been created, and - -- so we need to set the new root to what it was before the submission. - let assumedNewRoot = TxIn txId (mkTxIxPartial (fromIntegral rootIndex)) - let newRoot - | Map.member assumedNewRoot utxo = assumedNewRoot - | Map.member impRootTxIn utxo = impRootTxIn - | otherwise = error "Root not found in UTxO" - impRootTxInL .= newRoot - expectTxSuccess txFixed - pure $ Right txFixed - --- | Submit a transaction that is expected to be rejected with the given predicate failures. --- The inputs and outputs are automatically balanced. -submitFailingTx :: - ( HasCallStack - , ShelleyEraImp era - ) => - Tx era -> - NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> - ImpTestM era () -submitFailingTx tx = submitFailingTxM tx . const . pure - --- | Submit a transaction that is expected to be rejected, and compute --- the expected predicate failures from the fixed-up tx using the supplied action. --- The inputs and outputs are automatically balanced. -submitFailingTxM :: - ( HasCallStack - , ShelleyEraImp era - ) => - Tx era -> - (Tx era -> ImpTestM era (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))) -> - ImpTestM era () -submitFailingTxM tx mkExpectedFailures = do - (predFailures, fixedUpTx) <- expectLeftDeepExpr =<< trySubmitTx tx - expectedFailures <- mkExpectedFailures fixedUpTx - predFailures `shouldBeExpr` expectedFailures - -tryRunImpRule :: - forall rule era. - (STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) => - Environment (EraRule rule era) -> - State (EraRule rule era) -> - Signal (EraRule rule era) -> - ImpTestM - era - ( Either - (NonEmpty (PredicateFailure (EraRule rule era))) - (State (EraRule rule era), [Event (EraRule rule era)]) - ) -tryRunImpRule = tryRunImpRule' @rule AssertionsAll - -tryRunImpRuleNoAssertions :: - forall rule era. - ( STS (EraRule rule era) - , BaseM (EraRule rule era) ~ ShelleyBase - ) => - Environment (EraRule rule era) -> - State (EraRule rule era) -> - Signal (EraRule rule era) -> - ImpTestM - era - ( Either - (NonEmpty (PredicateFailure (EraRule rule era))) - (State (EraRule rule era), [Event (EraRule rule era)]) - ) -tryRunImpRuleNoAssertions = tryRunImpRule' @rule AssertionsOff - -tryRunImpRule' :: - forall rule era. - (STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) => - AssertionPolicy -> - Environment (EraRule rule era) -> - State (EraRule rule era) -> - Signal (EraRule rule era) -> - ImpTestM - era - ( Either - (NonEmpty (PredicateFailure (EraRule rule era))) - (State (EraRule rule era), [Event (EraRule rule era)]) - ) -tryRunImpRule' assertionPolicy stsEnv stsState stsSignal = do - let trc = TRC (stsEnv, stsState, stsSignal) - let - stsOpts = - ApplySTSOpts - { asoValidation = ValidateAll - , asoEvents = EPReturn - , asoAssertions = assertionPolicy - } - runShelleyBase (applySTSOptsEither @(EraRule rule era) stsOpts trc) - -runImpRule :: - forall rule era. - ( HasCallStack - , KnownSymbol rule - , STS (EraRule rule era) - , BaseM (EraRule rule era) ~ ShelleyBase - , NFData (State (EraRule rule era)) - , NFData (Event (EraRule rule era)) - , ToExpr (Event (EraRule rule era)) - , Eq (Event (EraRule rule era)) - , Typeable (Event (EraRule rule era)) - ) => - Environment (EraRule rule era) -> - State (EraRule rule era) -> - Signal (EraRule rule era) -> - ImpTestM era (State (EraRule rule era)) -runImpRule env st sig = do - let ruleName = symbolVal (Proxy @rule) - (res, ev) <- - tryRunImpRule @rule env st sig >>= \case - Left fs -> - assertFailure $ - unlines $ - ("Failed to run " <> ruleName <> ":") : map show (toList fs) - Right res -> evaluateDeep res - tell $ fmap (SomeSTSEvent @era @rule) ev - pure res - --- | Runs the TICK rule once -passTick :: - forall era. - ( HasCallStack - , ShelleyEraImp era - ) => - ImpTestM era () -passTick = do - impLastTick <- gets impLastTick - curNES <- getsNES id - nes <- runImpRule @"TICK" () curNES impLastTick - impLastTickL += 1 - impNESL .= nes - --- | Runs the TICK rule until the next epoch is reached -passEpoch :: - forall era. - (ShelleyEraImp era, HasCallStack) => - ImpTestM era () -passEpoch = do - let - tickUntilNewEpoch curEpochNo = do - passTick @era - newEpochNo <- getsNES nesELL - unless (newEpochNo > curEpochNo) $ tickUntilNewEpoch curEpochNo - preNES <- gets impNES - let startEpoch = preNES ^. nesELL - logDoc $ "Entering " <> ansiExpr (succ startEpoch) - tickUntilNewEpoch startEpoch - gets impNES >>= epochBoundaryCheck preNES - -epochBoundaryCheck :: - (EraTxOut era, EraGov era, HasCallStack, EraCertState era) => - NewEpochState era -> - NewEpochState era -> - ImpTestM era () -epochBoundaryCheck preNES postNES = do - impAnn "Checking ADA preservation at the epoch boundary" $ do - let preSum = tot preNES - postSum = tot postNES - logDoc $ diffExpr preSum postSum - unless (preSum == postSum) . expectationFailure $ - "Total ADA in the epoch state is not preserved\n\tpost - pre = " - <> show (postSum <-> preSum) - where - tot nes = - (<+>) - (sumAdaPots (totalAdaPotsES (nes ^. nesEsL))) - (nes ^. nesEsL . esLStateL . lsUTxOStateL . utxosDonationL) - --- | Runs the TICK rule until the `n` epochs are passed -passNEpochs :: - forall era. - ShelleyEraImp era => - Natural -> - ImpTestM era () -passNEpochs n = - replicateM_ (fromIntegral n) passEpoch - --- | Runs the TICK rule until the `n` epochs are passed, running the `checks` --- each time. -passNEpochsChecking :: - forall era. - ShelleyEraImp era => - Natural -> - ImpTestM era () -> - ImpTestM era () -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 :: (HasCallStack, ToExpr a) => ImpM t a -> ImpM t a impLogToExpr action = do e <- action - logWithCallStack ?callStack . ansiWlExpr . toExpr $ e + logWithCallStack ?callStack . ansiWlExpr $ toExpr e pure e --- | Creates a fresh @SafeHash@ -freshSafeHash :: ImpTestM era (SafeHash a) -freshSafeHash = arbitrary +-- | Generates a random @SafeHash@ +genSafeHash :: MonadGen m => m (SafeHash a) +genSafeHash = arbitrary -freshKeyHashVRF :: - ImpTestM era (VRFVerKeyHash (r :: KeyRoleVRF)) -freshKeyHashVRF = 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 :: @@ -1428,343 +267,20 @@ freshBootstapAddress = do modify $ keyPairsByronL %~ Map.insert bootAddr keyPair pure bootAddr -sendCoinTo :: (ShelleyEraImp era, HasCallStack) => Addr -> Coin -> ImpTestM era TxIn -sendCoinTo addr = sendValueTo addr . inject - -sendCoinTo_ :: (ShelleyEraImp era, HasCallStack) => Addr -> Coin -> ImpTestM era () -sendCoinTo_ addr = void . sendCoinTo addr - -sendValueTo :: (ShelleyEraImp era, HasCallStack) => Addr -> Value era -> ImpTestM era TxIn -sendValueTo addr amount = do - tx <- - submitTxAnn - ("Giving " <> show amount <> " to " <> show addr) - $ mkBasicTx mkBasicTxBody - & bodyTxL . outputsTxBodyL .~ SSeq.singleton (mkBasicTxOut addr amount) - pure $ txInAt 0 tx - -sendValueTo_ :: (ShelleyEraImp era, HasCallStack) => Addr -> Value era -> ImpTestM era () -sendValueTo_ addr = void . sendValueTo addr - --- | Modify the current new epoch state with a function -modifyNES :: (NewEpochState era -> NewEpochState era) -> ImpTestM era () -modifyNES = (impNESL %=) - --- | Get a value from the current new epoch state using the lens -getsNES :: SimpleGetter (NewEpochState era) a -> ImpTestM era a -getsNES l = gets . view $ impNESL . l - -getUTxO :: ImpTestM era (UTxO era) -getUTxO = getsNES utxoL - -getProtVer :: EraGov era => ImpTestM era ProtVer -getProtVer = getsNES $ nesEsL . curPParamsEpochStateL . ppProtocolVersionL - -submitTxAnn :: - (HasCallStack, ShelleyEraImp era) => - String -> - Tx era -> - ImpTestM era (Tx era) -submitTxAnn msg tx = impAnn msg (trySubmitTx tx >>= expectRightDeepExpr) - -submitTxAnn_ :: - (HasCallStack, ShelleyEraImp era) => String -> Tx era -> ImpTestM era () -submitTxAnn_ msg = void . submitTxAnn msg - -getRewardAccountFor :: - Credential 'Staking -> - ImpTestM era RewardAccount -getRewardAccountFor stakingC = do - networkId <- use (impGlobalsL . to networkId) - pure $ RewardAccount networkId stakingC - -registerStakeCredential :: - forall era. - ( HasCallStack - , ShelleyEraImp era - ) => - Credential 'Staking -> - ImpTestM era RewardAccount -registerStakeCredential cred = do - submitTxAnn_ ("Register Reward Account: " <> T.unpack (credToText cred)) $ - mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL - .~ SSeq.fromList [RegTxCert cred] - networkId <- use (impGlobalsL . to networkId) - pure $ RewardAccount networkId cred - -delegateStake :: - ShelleyEraImp era => - Credential 'Staking -> - KeyHash 'StakePool -> - ImpTestM era () -delegateStake cred poolKH = do - submitTxAnn_ ("Delegate Staking Credential: " <> T.unpack (credToText cred)) $ - mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL - .~ SSeq.fromList - [DelegStakeTxCert cred poolKH] - -registerRewardAccount :: - forall era. - ( HasCallStack - , ShelleyEraImp era - ) => - ImpTestM era RewardAccount -registerRewardAccount = do - khDelegator <- freshKeyHash - registerStakeCredential (KeyHashObj khDelegator) - -lookupReward :: EraCertState era => Credential 'Staking -> ImpTestM era (Maybe Coin) -lookupReward = lookupBalance -{-# DEPRECATED lookupReward "In favor of `lookupBalance`" #-} - -getReward :: (HasCallStack, EraCertState era) => Credential 'Staking -> ImpTestM era Coin -getReward = getBalance -{-# DEPRECATED getReward "In favor of `getBalance`" #-} - -freshPoolParams :: - ShelleyEraImp era => - KeyHash 'StakePool -> - 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 - } - -registerPool :: - ShelleyEraImp era => - KeyHash 'StakePool -> - ImpTestM era () -registerPool khPool = registerRewardAccount >>= registerPoolWithRewardAccount khPool - -registerPoolWithRewardAccount :: - ShelleyEraImp era => - KeyHash 'StakePool -> - RewardAccount -> - ImpTestM era () -registerPoolWithRewardAccount khPool rewardAccount = do - pps <- freshPoolParams khPool rewardAccount - submitTxAnn_ "Registering a new stake pool" $ - mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL .~ SSeq.singleton (RegPoolTxCert pps) - -registerAndRetirePoolToMakeReward :: - ShelleyEraImp era => - Credential 'Staking -> - ImpTestM era () -registerAndRetirePoolToMakeReward stakingCred = do - poolId <- freshKeyHash - registerPoolWithRewardAccount poolId =<< getRewardAccountFor stakingCred - passEpoch - curEpochNo <- getsNES nesELL - let poolLifetime = 2 - poolExpiry = addEpochInterval curEpochNo $ EpochInterval poolLifetime - submitTxAnn_ "Retiring the temporary stake pool" $ - mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL .~ SSeq.singleton (RetirePoolTxCert poolId poolExpiry) - passNEpochs $ fromIntegral poolLifetime - -withCborRoundTripFailures :: ImpTestM era a -> ImpTestM era a -withCborRoundTripFailures = local $ iteCborRoundTripFailuresL .~ False - --- | Compose given function with the configured fixup -withCustomFixup :: - ((Tx era -> ImpTestM era (Tx era)) -> Tx era -> ImpTestM era (Tx era)) -> - ImpTestM era a -> - ImpTestM era a -withCustomFixup f = local $ iteFixupL %~ f - --- | Replace all fixup with the given function -withFixup :: - (Tx era -> ImpTestM era (Tx era)) -> - ImpTestM era a -> - ImpTestM era a -withFixup f = withCustomFixup (const f) - --- | Performs the action without running the fix-up function on any transactions -withNoFixup :: ImpTestM era a -> ImpTestM era a -withNoFixup = withFixup pure - --- | Apply given fixup function before the configured fixup -withPreFixup :: - (Tx era -> ImpTestM era (Tx era)) -> - ImpTestM era a -> - ImpTestM era a -withPreFixup f = withCustomFixup (f >=>) - --- | Apply given fixup function after the configured fixup -withPostFixup :: - (Tx era -> ImpTestM era (Tx era)) -> - ImpTestM era a -> - ImpTestM era a -withPostFixup f = withCustomFixup (>=> f) - -expectUTxOContent :: - (HasCallStack, ToExpr (TxOut era)) => - UTxO era -> - [(TxIn, Maybe (TxOut era) -> Bool)] -> - ImpTestM era () -expectUTxOContent utxo = traverse_ $ \(txIn, test) -> do - let result = txIn `Map.lookup` unUTxO utxo - unless (test result) $ - expectationFailure $ - "UTxO content failed predicate:\n" <> ansiExprString txIn <> " -> " <> ansiExprString result - -expectRegisteredRewardAddress :: - (HasCallStack, EraCertState era) => RewardAccount -> ImpTestM era () -expectRegisteredRewardAddress ra@RewardAccount {raNetwork, raCredential} = do - networkId <- use (impGlobalsL . to networkId) - unless (raNetwork == networkId) $ - assertFailure $ - "Reward Account with an unexpected NetworkId: " ++ show ra - accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL - unless (isAccountRegistered raCredential accounts) $ - assertFailure $ - "Expected account " - ++ show ra - ++ " to be registered, but it is not." - -expectNotRegisteredRewardAddress :: - (HasCallStack, EraCertState era) => RewardAccount -> ImpTestM era () -expectNotRegisteredRewardAddress ra@RewardAccount {raNetwork, raCredential} = do - accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL - networkId <- use (impGlobalsL . to networkId) - when (raNetwork == networkId && isAccountRegistered raCredential accounts) $ - assertFailure $ - "Expected account " - ++ show ra - ++ " to not be registered, but it is." - -expectTreasury :: HasCallStack => Coin -> ImpTestM era () -expectTreasury c = - impAnn "Checking treasury amount" $ do - treasuryAmount <- getsNES treasuryL - c `shouldBe` treasuryAmount - --- Ensure no fees reach the treasury since that complicates withdrawal checks -disableTreasuryExpansion :: ShelleyEraImp era => ImpTestM era () -disableTreasuryExpansion = modifyPParams $ ppTauL .~ (0 %! 1) - -impLookupNativeScript :: ScriptHash -> ImpTestM era (Maybe (NativeScript era)) -impLookupNativeScript sh = Map.lookup sh <$> gets impNativeScripts - -impGetUTxO :: ShelleyEraImp era => TxIn -> ImpTestM era (TxOut era) -impGetUTxO txIn = impAnn "Looking up TxOut" $ do - utxo <- getUTxO - case txinLookup txIn utxo of - Just txOut -> pure txOut - Nothing -> error $ "Failed to get TxOut for " <> show txIn - -produceScript :: - (ShelleyEraImp era, HasCallStack) => - ScriptHash -> - ImpTestM era TxIn -produceScript scriptHash = do - let addr = mkAddr scriptHash StakeRefNull - let tx = - mkBasicTx mkBasicTxBody - & bodyTxL . outputsTxBodyL .~ SSeq.singleton (mkBasicTxOut addr mempty) - logString $ "Produced script: " <> show scriptHash - txInAt 0 <$> submitTx tx - -advanceToPointOfNoReturn :: ImpTestM era () -advanceToPointOfNoReturn = do - impLastTick <- gets impLastTick - (_, slotOfNoReturn, _) <- runShelleyBase $ getTheSlotOfNoReturn impLastTick - impLastTickL .= slotOfNoReturn - --- | A legal ProtVer that differs in the minor Version -minorFollow :: ProtVer -> ProtVer -minorFollow (ProtVer x y) = ProtVer x (y + 1) - --- | 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) - -- | An illegal ProtVer that skips 3 minor versions -cantFollow :: ProtVer -> ProtVer -cantFollow (ProtVer x y) = ProtVer x (y + 3) - -whenMajorVersion :: - forall (v :: Natural) era. - ( EraGov era - , KnownNat v - , MinVersion <= v - , v <= MaxVersion - ) => - ImpTestM era () -> ImpTestM era () -whenMajorVersion a = do - pv <- getProtVer - when (pvMajor pv == natVersion @v) a - -whenMajorVersionAtLeast :: - forall (v :: Natural) era. - ( EraGov era - , KnownNat v - , MinVersion <= v - , v <= MaxVersion - ) => - ImpTestM era () -> ImpTestM era () -whenMajorVersionAtLeast a = do - pv <- getProtVer - when (pvMajor pv >= natVersion @v) a - -whenMajorVersionAtMost :: - forall (v :: Natural) era. - ( EraGov era - , KnownNat v - , MinVersion <= v - , v <= MaxVersion - ) => - ImpTestM era () -> ImpTestM era () -whenMajorVersionAtMost a = do - pv <- getProtVer - when (pvMajor pv <= natVersion @v) a - -unlessMajorVersion :: - forall (v :: Natural) era. - ( EraGov era - , KnownNat v - , MinVersion <= v - , v <= MaxVersion - ) => - 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. +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 :: - ImpTestM era a -> - ImpTestM era a -simulateThenRestore sim = do - snapshot <- get - result <- sim - put snapshot - pure result + ImpM t a -> + ImpM t a +simulateThenRestore simulate = do + stateSnapshot <- get + result <- simulate + result <$ put stateSnapshot From bc57b9b69999bbc8b67f1941bd8e34a606758c4a Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 13 Aug 2025 22:18:28 -0600 Subject: [PATCH 06/10] Rename KeyPairStore --- .../Test/Cardano/Ledger/Shelley/ImpTest.hs | 2 +- .../testlib/Test/Cardano/Ledger/ImpTest.hs | 42 +++++++------------ 2 files changed, 17 insertions(+), 27 deletions(-) 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 f48025c07f2..57ab4037b96 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -259,7 +259,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 = diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs index 26b193900db..72579c67f01 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs @@ -1,22 +1,12 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} @@ -24,7 +14,7 @@ module Test.Cardano.Ledger.ImpTest ( EraImp (..), HasKeyPairs (..), - ImpPrepState (..), + KeyPairStore (..), freshKeyAddr, freshKeyAddr_, freshKeyHash, @@ -85,32 +75,32 @@ import Test.Cardano.Slotting.Numeric () import Test.ImpSpec -- | 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) +data KeyPairStore = KeyPairStore + { keyPairStore :: !(Map (KeyHash 'Witness) (KeyPair 'Witness)) + , keyPairByronStore :: !(Map BootstrapAddress ByronKeyPair) } -instance Semigroup ImpPrepState where +instance Semigroup KeyPairStore where (<>) ips1 ips2 = - ImpPrepState - { impPrepKeyPairs = impPrepKeyPairs ips1 <> impPrepKeyPairs ips2 - , impPrepByronKeyPairs = impPrepByronKeyPairs ips1 <> impPrepByronKeyPairs ips2 + KeyPairStore + { keyPairStore = keyPairStore ips1 <> keyPairStore ips2 + , keyPairByronStore = keyPairByronStore ips1 <> keyPairByronStore ips2 } -instance Monoid ImpPrepState where +instance Monoid KeyPairStore where mempty = - ImpPrepState - { impPrepKeyPairs = mempty - , impPrepByronKeyPairs = mempty + KeyPairStore + { keyPairStore = mempty + , keyPairByronStore = mempty } class HasKeyPairs t where keyPairsL :: Lens' t (Map (KeyHash 'Witness) (KeyPair 'Witness)) keyPairsByronL :: Lens' t (Map BootstrapAddress ByronKeyPair) -instance HasKeyPairs ImpPrepState where - keyPairsL = lens impPrepKeyPairs (\x y -> x {impPrepKeyPairs = y}) - keyPairsByronL = lens impPrepByronKeyPairs (\x y -> x {impPrepByronKeyPairs = y}) +instance HasKeyPairs KeyPairStore where + keyPairsL = lens keyPairStore (\x y -> x {keyPairStore = y}) + keyPairsByronL = lens keyPairByronStore (\x y -> x {keyPairByronStore = y}) class EraTest era => EraImp era where initGenesis :: From 47a9882043fd5e72df8217e4c88aeefe1d8efc60 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 13 Aug 2025 22:33:20 -0600 Subject: [PATCH 07/10] Rename KeyPairs to KeyPairStore --- .../Test/Cardano/Ledger/Allegra/ImpTest.hs | 2 +- .../Test/Cardano/Ledger/Shelley/ImpTest.hs | 38 ++++++----------- .../testlib/Test/Cardano/Ledger/ImpTest.hs | 42 +++++++++++-------- 3 files changed, 37 insertions(+), 45 deletions(-) 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 081b36a5d5f..79bc7ade6d6 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs @@ -57,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/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs index 57ab4037b96..f0db75370c9 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -119,7 +119,6 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( impNESL, impGlobalsL, impLastTickG, - impKeyPairsG, impNativeScriptsG, produceScript, advanceToPointOfNoReturn, @@ -296,17 +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] } -instance Era era => HasKeyPairs (ImpTestState era) where - keyPairsL = lens impKeyPairs (\x y -> x {impKeyPairs = y}) - keyPairsByronL = lens impByronKeyPairs (\x y -> x {impByronKeyPairs = 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}) @@ -323,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}) @@ -384,11 +375,10 @@ class ShelleyEraImp era where 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) @@ -400,8 +390,7 @@ class initNewEpochState = defaultInitNewEpochState id initImpTestState :: - ( HasKeyPairs s - , MonadState s m + ( MonadState KeyPairStore m , HasStatefulGen g m , MonadFail m ) => @@ -431,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 @@ -468,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 ) => @@ -502,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 @@ -646,7 +632,7 @@ instance ShelleyEraImp ShelleyEra where 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 diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs index 72579c67f01..e03a1092a62 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs @@ -4,16 +4,18 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} module Test.Cardano.Ledger.ImpTest ( EraImp (..), - HasKeyPairs (..), + HasKeyPairStore (..), + keyPairsL, + keyPairsByronL, KeyPairStore (..), freshKeyAddr, freshKeyAddr_, @@ -94,17 +96,21 @@ instance Monoid KeyPairStore where , keyPairByronStore = mempty } -class HasKeyPairs t where - keyPairsL :: Lens' t (Map (KeyHash 'Witness) (KeyPair 'Witness)) - keyPairsByronL :: Lens' t (Map BootstrapAddress ByronKeyPair) +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 HasKeyPairs KeyPairStore where - keyPairsL = lens keyPairStore (\x y -> x {keyPairStore = y}) - keyPairsByronL = lens keyPairByronStore (\x y -> x {keyPairByronStore = y}) +instance HasKeyPairStore KeyPairStore where + keyPairStoreL = id class EraTest era => EraImp era where initGenesis :: - (HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) => + (HasKeyPairStore s, MonadState s m, HasStatefulGen g m, MonadFail m) => m (Genesis era) default initGenesis :: (Monad m, Genesis era ~ NoGenesis era) => @@ -156,7 +162,7 @@ genPoolParams ppMinCost khPool rewardAccount = do -- | Adds a key pair to the keyhash lookup map addKeyPair :: - (HasKeyPairs s, MonadState s m) => + (HasKeyPairStore s, MonadState s m) => KeyPair r -> m (KeyHash r) addKeyPair keyPair@(KeyPair vk _) = do @@ -167,7 +173,7 @@ addKeyPair keyPair@(KeyPair vk _) = do -- | 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) => + (HasCallStack, HasKeyPairStore s, MonadState s m) => KeyHash r -> m (KeyPair r) getKeyPair keyHash = do @@ -185,14 +191,14 @@ getKeyPair keyHash = do -- 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) => + (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. - (HasKeyPairs s, MonadState s m, HasStatefulGen g m) => + (HasKeyPairStore s, MonadState s m, HasStatefulGen g m) => m (KeyHash r, KeyPair r) freshKeyPair = do keyPair <- uniformM @@ -202,13 +208,13 @@ freshKeyPair = do -- | 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 + (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 :: - (HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) => + (HasKeyPairStore s, MonadState s m, HasStatefulGen g m, MonadGen m) => m (KeyHash 'Payment, Addr) freshKeyAddr = do paymentKeyHash <- freshKeyHash @'Payment @@ -220,7 +226,7 @@ freshKeyAddr = do -- | 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) => + (HasCallStack, HasKeyPairStore s, MonadState s m) => BootstrapAddress -> m ByronKeyPair getByronKeyPair bootAddr = do @@ -237,12 +243,12 @@ getByronKeyPair bootAddr = do -- 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) => + (HasKeyPairStore s, MonadState s m, HasStatefulGen g m) => m (KeyHash r) freshByronKeyHash = coerceKeyRole . bootstrapKeyHash <$> freshBootstapAddress freshBootstapAddress :: - (HasKeyPairs s, MonadState s m, HasStatefulGen g m) => + (HasKeyPairStore s, MonadState s m, HasStatefulGen g m) => m BootstrapAddress freshBootstapAddress = do keyPair@(ByronKeyPair verificationKey _) <- uniformM From c1806be5ac816f9ddaf3ea51cd76b3c4b8e15aa2 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 14 Aug 2025 16:04:30 -0600 Subject: [PATCH 08/10] Add `KeyPairSpec` with `ImpSpec` instance --- .../testlib/Test/Cardano/Ledger/ImpTest.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs index e03a1092a62..7b7860d6d42 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/ImpTest.hs @@ -7,16 +7,18 @@ {-# 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, - KeyPairStore (..), freshKeyAddr, freshKeyAddr_, freshKeyHash, @@ -64,6 +66,7 @@ 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) @@ -76,6 +79,9 @@ 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)) @@ -96,6 +102,15 @@ instance Monoid KeyPairStore where , 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 From 251ed05f0ab655199636beaaf43e89f8bc56a3d7 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Mon, 18 Aug 2025 21:06:24 -0600 Subject: [PATCH 09/10] Add golden test for all eras --- .../allegra/impl/cardano-ledger-allegra.cabal | 1 + eras/allegra/impl/test/Main.hs | 4 ++- eras/alonzo/impl/cardano-ledger-alonzo.cabal | 1 + eras/alonzo/impl/test/Main.hs | 4 ++- .../babbage/impl/cardano-ledger-babbage.cabal | 1 + eras/babbage/impl/test/Main.hs | 4 ++- eras/conway/impl/cardano-ledger-conway.cabal | 1 + eras/conway/impl/test/Main.hs | 2 ++ eras/dijkstra/cardano-ledger-dijkstra.cabal | 1 + eras/dijkstra/test/Main.hs | 2 ++ eras/mary/impl/cardano-ledger-mary.cabal | 1 + eras/mary/impl/test/Main.hs | 4 ++- .../shelley/impl/cardano-ledger-shelley.cabal | 1 + eras/shelley/impl/test/Main.hs | 4 ++- .../Test/Cardano/Ledger/Shelley/ImpTest.hs | 3 ++- .../cardano-ledger-core.cabal | 2 ++ .../src/Cardano/Ledger/Genesis.hs | 19 ++++++++++++- .../testlib/Test/Cardano/Ledger/Core/JSON.hs | 27 ++++++++++++++++--- 18 files changed, 71 insertions(+), 11 deletions(-) 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/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/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/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/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/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/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/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/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/shelley/impl/cardano-ledger-shelley.cabal b/eras/shelley/impl/cardano-ledger-shelley.cabal index 120020dcf32..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 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/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs index f0db75370c9..86bb41c0dca 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -603,6 +603,7 @@ instance EraImp ShelleyEra where & 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 @@ -613,7 +614,7 @@ instance EraImp ShelleyEra where & 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 diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index 9aaf350145f..c863cd6b94e 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -180,6 +180,7 @@ 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 @@ -221,6 +222,7 @@ library testlib cuddle >=0.4, data-default, deepseq, + filepath, generic-random, genvalidity, hedgehog-quickcheck, 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/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 From 23567d5dcf5abf6c731a0a3984ddc05e964a8a6f Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Mon, 18 Aug 2025 21:07:54 -0600 Subject: [PATCH 10/10] Add Genesis test --- .../Test/Cardano/Ledger/Allegra/Era/Spec.hs | 16 + .../impl/golden/json/alonzo-genesis.json | 196 +++++++++++ .../Test/Cardano/Ledger/Alonzo/Era/Spec.hs | 16 + .../Test/Cardano/Ledger/Babbage/Era/Spec.hs | 16 + .../impl/golden/json/conway-genesis.json | 303 ++++++++++++++++++ .../Test/Cardano/Ledger/Conway/Era/Spec.hs | 16 + .../golden/json/dijkstra-genesis.json | 6 + .../Test/Cardano/Ledger/Dijkstra/Era/Spec.hs | 16 + .../Test/Cardano/Ledger/Mary/Era/Spec.hs | 16 + .../impl/golden/json/shelley-genesis.json | 39 +++ .../Test/Cardano/Ledger/Shelley/Era/Spec.hs | 16 + .../testlib/Test/Cardano/Ledger/Era/Spec.hs | 45 +++ 12 files changed, 701 insertions(+) create mode 100644 eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Era/Spec.hs create mode 100644 eras/alonzo/impl/golden/json/alonzo-genesis.json create mode 100644 eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Era/Spec.hs create mode 100644 eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Era/Spec.hs create mode 100644 eras/conway/impl/golden/json/conway-genesis.json create mode 100644 eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Era/Spec.hs create mode 100644 eras/dijkstra/golden/json/dijkstra-genesis.json create mode 100644 eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/Era/Spec.hs create mode 100644 eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Era/Spec.hs create mode 100644 eras/shelley/impl/golden/json/shelley-genesis.json create mode 100644 eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Era/Spec.hs create mode 100644 libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era/Spec.hs 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/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/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/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/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/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/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/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/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/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/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/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