From 2a65a30f8182d39f9da0dc41bd6820137276f616 Mon Sep 17 00:00:00 2001 From: Neil Mayhew Date: Mon, 3 Nov 2025 17:55:24 -0700 Subject: [PATCH 1/9] Improve protocol version description message in Imp tests --- .../shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 0e3ecca723f..5b79156e391 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -654,7 +654,7 @@ withEachEraVersion :: withEachEraVersion specWith = withImpInit @(LedgerSpec era) $ do forM_ (eraProtVersions @era) $ \protVer -> - describe (show protVer) $ + describe ("Protocol " <> show protVer) $ modifyImpInitProtVer protVer specWith shelleyModifyImpInitProtVer :: From 4a61305099425eedf3235f943aa782685e1ccee5 Mon Sep 17 00:00:00 2001 From: Neil Mayhew Date: Mon, 24 Nov 2025 17:16:13 -0700 Subject: [PATCH 2/9] Optimize MonadWriter ImpTestM instance by using a Seq instead of a list Also abstract the interface for obtaining events from ImpTestM actions --- .../Cardano/Ledger/Conway/Imp/EnactSpec.hs | 21 +++++++++---------- .../Cardano/Ledger/Conway/Imp/EpochSpec.hs | 5 ++--- eras/shelley/impl/CHANGELOG.md | 2 ++ .../Test/Cardano/Ledger/Shelley/ImpTest.hs | 18 +++++++++++----- 4 files changed, 27 insertions(+), 19 deletions(-) diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs index a588fef0ac8..8773da6c3f1 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs @@ -23,7 +23,6 @@ import Cardano.Ledger.Shelley.LedgerState import Cardano.Ledger.Shelley.Rules (Event, ShelleyTickEvent (..)) import Cardano.Ledger.Val (zero, (<->)) import Control.Monad (forM) -import Control.Monad.Writer (listen) import Data.Default (def) import Data.Foldable as F (foldl', traverse_) import Data.List.NonEmpty (NonEmpty (..)) @@ -214,18 +213,18 @@ hardForkInitiationSpec = submitYesVote_ (DRepVoter dRep1) govActionId submitYesVote_ (StakePoolVoter stakePoolId1) govActionId passNEpochs 2 - & listen - >>= expectHardForkEvents . snd <*> pure [] + & impEventsFrom + >>= expectHardForkEvents <*> pure [] getProtVer `shouldReturn` curProtVer submitYesVote_ (DRepVoter dRep2) govActionId passNEpochs 2 - & listen - >>= expectHardForkEvents . snd <*> pure [] + & impEventsFrom + >>= expectHardForkEvents <*> pure [] getProtVer `shouldReturn` curProtVer submitYesVote_ (StakePoolVoter stakePoolId2) govActionId passNEpochs 2 - & listen - >>= expectHardForkEvents . snd + & impEventsFrom + >>= expectHardForkEvents <*> pure [ SomeSTSEvent @era @"TICK" . injectEvent $ ConwayHardForkEvent nextProtVer ] @@ -255,13 +254,13 @@ hardForkInitiationNoDRepsSpec = submitYesVoteCCs_ committeeMembers' govActionId submitYesVote_ (StakePoolVoter stakePoolId1) govActionId passNEpochs 2 - & listen - >>= expectHardForkEvents . snd <*> pure [] + & impEventsFrom + >>= expectHardForkEvents <*> pure [] getProtVer `shouldReturn` curProtVer submitYesVote_ (StakePoolVoter stakePoolId2) govActionId passNEpochs 2 - & listen - >>= expectHardForkEvents . snd + & impEventsFrom + >>= expectHardForkEvents <*> pure [ SomeSTSEvent @era @"TICK" . injectEvent $ ConwayHardForkEvent nextProtVer ] diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs index 831e8f4a1b8..d7602c8ee43 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs @@ -25,7 +25,6 @@ import Cardano.Ledger.Conway.State import Cardano.Ledger.Shelley.LedgerState import Cardano.Ledger.Shelley.Rules (Event, ShelleyTickEvent (..)) import Cardano.Ledger.Val -import Control.Monad.Writer (listen) import Data.Default (Default (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map @@ -528,7 +527,7 @@ eventsSpec = describe "Events" $ do | Just (TickNewEpochEvent (EpochEvent (GovInfoEvent {})) :: ShelleyTickEvent era) <- cast ev = True isGovInfoEvent _ = False passEpochWithNoDroppedActions = do - (_, evs) <- listen passEpoch + evs <- impEventsFrom passEpoch filter isGovInfoEvent evs `shouldBeExpr` [ SomeSTSEvent @era @"TICK" . injectEvent $ GovInfoEvent mempty mempty mempty mempty @@ -545,7 +544,7 @@ eventsSpec = describe "Events" $ do & bodyTxL . certsTxBodyL .~ SSeq.singleton (UnRegDepositTxCert rewardCred keyDeposit) passEpochWithNoDroppedActions - (_, evs) <- listen passEpoch + evs <- impEventsFrom passEpoch checkProposedParameterA let filteredEvs = filter isGovInfoEvent evs diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 2026cce3d3e..cea95816ded 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -49,6 +49,8 @@ ### `testlib` +* Add `impEventsFrom` +* Change type of `ImpTestState.impEvents` field from `[]` to `Seq` * Renamed `impLastTick` to `impCurSlotNo` and `impLastTickG` to `impCurSlotNoG` * Add CDDL certificate definitions: `account_registration_cert`, `account_unregistration_cert`, `delegation_to_stake_pool_cert` * Add CDDL pool certificate definitions via `mkPoolRules`: `pool_registration_cert`, `pool_retirement_cert` 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 5b79156e391..2165ddf575c 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -147,6 +147,7 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( withNoFixup, withPostFixup, withPreFixup, + impEventsFrom, impNESL, impGlobalsL, impCurSlotNoG, @@ -262,6 +263,8 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, isNothing, mapMaybe) import Data.Ratio (denominator, numerator, (%)) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq import Data.Sequence.Strict (StrictSeq (..)) import qualified Data.Sequence.Strict as SSeq import qualified Data.Set as Set @@ -346,7 +349,7 @@ data ImpTestState era = ImpTestState , impNativeScripts :: !(Map ScriptHash (NativeScript era)) , impCurSlotNo :: !SlotNo , impGlobals :: !Globals - , impEvents :: [SomeSTSEvent era] + , impEvents :: Seq (SomeSTSEvent era) } -- | This is a preliminary state that is used to prepare the actual `ImpTestState` @@ -409,7 +412,7 @@ impNativeScriptsG :: SimpleGetter (ImpTestState era) (Map ScriptHash (NativeScript era)) impNativeScriptsG = impNativeScriptsL -impEventsL :: Lens' (ImpTestState era) [SomeSTSEvent era] +impEventsL :: Lens' (ImpTestState era) (Seq (SomeSTSEvent era)) impEventsL = lens impEvents (\x y -> x {impEvents = y}) class @@ -897,7 +900,7 @@ itePostEpochBoundaryHookL :: ) itePostEpochBoundaryHookL = lens itePostEpochBoundaryHook (\x y -> x {itePostEpochBoundaryHook = y}) -instance MonadWriter [SomeSTSEvent era] (ImpTestM era) where +instance MonadWriter (Seq (SomeSTSEvent era)) (ImpTestM era) where writer (x, evs) = (impEventsL %= (<> evs)) $> x listen act = do oldEvs <- use impEventsL @@ -910,6 +913,11 @@ instance MonadWriter [SomeSTSEvent era] (ImpTestM era) where ((a, f), evs) <- listen act writer (a, f evs) +impEventsFrom :: + ImpTestM era () -> + ImpTestM era [SomeSTSEvent era] +impEventsFrom = fmap (toList . snd) . listen + runShelleyBase :: ShelleyBase a -> ImpTestM era a runShelleyBase act = do globals <- use impGlobalsL @@ -1208,7 +1216,7 @@ trySubmitTx tx = do rootIndex | outsSize > 0 = outsSize - 1 | otherwise = error ("Expected at least 1 output after submitting tx: " <> show txId) - tell $ fmap (SomeSTSEvent @era @"LEDGER") events + tell . Seq.fromList $ 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 @@ -1328,7 +1336,7 @@ runImpRule env st sig = do unlines $ ("Failed to run " <> ruleName <> ":") : map show (toList fs) Right res -> evaluateDeep res - tell $ fmap (SomeSTSEvent @era @rule) ev + tell . Seq.fromList $ SomeSTSEvent @era @rule <$> ev pure res -- | Runs the TICK rule once From ded7f148e0105bef07473a322b99759e22f4d560 Mon Sep 17 00:00:00 2001 From: Neil Mayhew Date: Fri, 21 Nov 2025 17:00:15 -0700 Subject: [PATCH 3/9] Add NFData and ToExpr instances for block-related types --- .../src/Cardano/Ledger/Alonzo/BlockBody/Internal.hs | 3 +++ .../impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs | 3 +++ .../testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs | 3 +++ .../impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs | 5 +++++ .../Cardano/Ledger/Dijkstra/BlockBody/Internal.hs | 3 +++ .../impl/src/Cardano/Ledger/Dijkstra/Rules/Bbody.hs | 3 +++ .../Test/Cardano/Ledger/Dijkstra/TreeDiff.hs | 13 ++++++++++++- eras/shelley/impl/CHANGELOG.md | 9 +++++++++ .../Cardano/Ledger/Shelley/BlockBody/Internal.hs | 3 +++ .../impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs | 3 +++ .../testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs | 4 ++++ .../testlib/Test/Cardano/Ledger/Shelley/TreeDiff.hs | 4 ++++ .../src/Cardano/Ledger/BHeaderView.hs | 6 ++++++ .../src/Cardano/Ledger/BaseTypes.hs | 2 ++ .../cardano-ledger-core/src/Cardano/Ledger/Block.hs | 3 +++ .../testlib/Test/Cardano/Ledger/TreeDiff.hs | 6 ++++++ 16 files changed, 72 insertions(+), 1 deletion(-) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody/Internal.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody/Internal.hs index 0bbd6028fd7..f173aadd890 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody/Internal.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody/Internal.hs @@ -47,6 +47,7 @@ import Cardano.Ledger.Binary ( ) import Cardano.Ledger.Core import Cardano.Ledger.Shelley.BlockBody (auxDataSeqDecoder) +import Control.DeepSeq (NFData) import Control.Monad (unless) import Data.ByteString (ByteString) import Data.ByteString.Builder (Builder, shortByteString, toLazyByteString) @@ -88,6 +89,8 @@ data AlonzoBlockBody era = AlonzoBlockBodyInternal } deriving (Generic) +instance NFData (Tx TopTx era) => NFData (AlonzoBlockBody era) + instance EraBlockBody AlonzoEra where type BlockBody AlonzoEra = AlonzoBlockBody AlonzoEra mkBasicBlockBody = mkBasicBlockBodyAlonzo diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs index e58b26cc818..1da008f2e4a 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs @@ -55,6 +55,7 @@ import Cardano.Ledger.Shelley.Rules ( ShelleyUtxowPredFailure, ) import Cardano.Ledger.Slot (epochInfoEpoch, epochInfoFirst) +import Control.DeepSeq (NFData) import Control.Monad.Trans.Reader (asks) import Control.State.Transition ( Embed (..), @@ -80,6 +81,8 @@ data AlonzoBbodyPredFailure era | TooManyExUnits (Mismatch RelLTEQ ExUnits) deriving (Generic) +instance NFData (PredicateFailure (EraRule "LEDGERS" era)) => NFData (AlonzoBbodyPredFailure era) + newtype AlonzoBbodyEvent era = ShelleyInAlonzoEvent (ShelleyBbodyEvent era) deriving (Generic) diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs index cae010e5ab4..88ce1885f69 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs @@ -14,6 +14,7 @@ module Test.Cardano.Ledger.Alonzo.TreeDiff ( ) where import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.BlockBody import Cardano.Ledger.Alonzo.Core import Cardano.Ledger.Alonzo.PParams import Cardano.Ledger.Alonzo.Plutus.Context @@ -122,6 +123,8 @@ instance ToExpr (AlonzoTxBodyRaw TopTx AlonzoEra) where instance ToExpr (TxBody TopTx AlonzoEra) +instance ToExpr (Tx TopTx era) => ToExpr (AlonzoBlockBody era) + -- Tx instance ToExpr IsValid diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs index 90b21af1b12..651e207c72f 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs @@ -82,6 +82,7 @@ import Cardano.Ledger.Shelley.Rules ( ) import qualified Cardano.Ledger.Shelley.Rules as Shelley (ShelleyBbodyPredFailure (..)) import Cardano.Ledger.Shelley.UTxO (UTxO (..), txouts, unUTxO) +import Control.DeepSeq (NFData) import Control.State.Transition ( Embed (..), STS (..), @@ -119,6 +120,10 @@ deriving instance (Era era, Eq (PredicateFailure (EraRule "LEDGERS" era))) => Eq (ConwayBbodyPredFailure era) +deriving anyclass instance + (Era era, NFData (PredicateFailure (EraRule "LEDGERS" era))) => + NFData (ConwayBbodyPredFailure era) + deriving anyclass instance (Era era, NoThunks (PredicateFailure (EraRule "LEDGERS" era))) => NoThunks (ConwayBbodyPredFailure era) diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/BlockBody/Internal.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/BlockBody/Internal.hs index 1a56c9befe4..f763d9ba02d 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/BlockBody/Internal.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/BlockBody/Internal.hs @@ -51,6 +51,7 @@ import Cardano.Ledger.Core import Cardano.Ledger.Dijkstra.Era import Cardano.Ledger.Dijkstra.Tx () import Cardano.Ledger.Shelley.BlockBody (auxDataSeqDecoder) +import Control.DeepSeq (NFData) import Control.Monad (unless) import Data.Bifunctor (Bifunctor (..)) import Data.ByteString (ByteString) @@ -102,6 +103,8 @@ data DijkstraBlockBody era = DijkstraBlockBodyInternal } deriving (Generic) +instance (NFData (Tx TopTx era), NFData PerasCert) => NFData (DijkstraBlockBody era) + instance EraBlockBody DijkstraEra where type BlockBody DijkstraEra = DijkstraBlockBody DijkstraEra mkBasicBlockBody = mkBasicBlockBodyDijkstra diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Bbody.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Bbody.hs index 127f51998b3..d9128235045 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Bbody.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Bbody.hs @@ -79,6 +79,7 @@ import Cardano.Ledger.Shelley.Rules ( ShelleyUtxowPredFailure, ) import qualified Cardano.Ledger.Shelley.Rules as Shelley +import Control.DeepSeq (NFData) import Control.State.Transition ( Embed (..), STS (..), @@ -96,6 +97,8 @@ data DijkstraBbodyPredFailure era | BodyRefScriptsSizeTooBig (Mismatch RelLTEQ Int) deriving (Generic) +instance NFData (PredicateFailure (EraRule "LEDGERS" era)) => NFData (DijkstraBbodyPredFailure era) + deriving instance (Era era, Show (PredicateFailure (EraRule "LEDGERS" era))) => Show (DijkstraBbodyPredFailure era) diff --git a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs index 05613707948..c8ed3b556ff 100644 --- a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs @@ -16,12 +16,13 @@ module Test.Cardano.Ledger.Dijkstra.TreeDiff ( module Test.Cardano.Ledger.Conway.TreeDiff, ) where -import Cardano.Ledger.BaseTypes (StrictMaybe) +import Cardano.Ledger.BaseTypes (PerasCert, StrictMaybe) import Cardano.Ledger.Dijkstra (DijkstraEra) import Cardano.Ledger.Dijkstra.Core ( AlonzoEraScript (..), AsItem, AsIx, + DijkstraBlockBody, Era, EraPParams (..), EraRule, @@ -30,10 +31,12 @@ import Cardano.Ledger.Dijkstra.Core ( EraTxCert (..), EraTxOut (..), PlutusScript, + TopTx, Value, ) import Cardano.Ledger.Dijkstra.PParams (DijkstraPParams) import Cardano.Ledger.Dijkstra.Rules ( + DijkstraBbodyPredFailure, DijkstraGovCertPredFailure, DijkstraGovPredFailure, DijkstraLedgerPredFailure, @@ -122,6 +125,10 @@ instance ToExpr (DijkstraTxBodyRaw l DijkstraEra) where instance ToExpr (TxBody l DijkstraEra) +instance ToExpr PerasCert + +instance (ToExpr (Tx TopTx era), ToExpr PerasCert) => ToExpr (DijkstraBlockBody era) + instance ToExpr (DijkstraTx l DijkstraEra) where toExpr = \case txBody@(DijkstraTx _ _ _ _) -> @@ -186,3 +193,7 @@ instance ToExpr (DijkstraGovPredFailure era) instance ToExpr (DijkstraGovCertPredFailure era) + +instance + ToExpr (PredicateFailure (EraRule "LEDGERS" era)) => + ToExpr (DijkstraBbodyPredFailure era) diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index cea95816ded..1f51af6b8ed 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -49,6 +49,15 @@ ### `testlib` +* Add `NFData` and `ToExpr` constraints and instances for: + - `AlonzoBlockBody` + - `AlonzoBbodyPredFailure` + - `ConwayBbodyPredFailure` + - `ShelleyBlockBody` + - `ShelleyBbodyPredFailure` + - `BHeaderView` + - `Block` +* Add a `Generic` instance for `BHeaderView` * Add `impEventsFrom` * Change type of `ImpTestState.impEvents` field from `[]` to `Seq` * Renamed `impLastTick` to `impCurSlotNo` and `impLastTickG` to `impCurSlotNoG` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody/Internal.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody/Internal.hs index d82d0de0dfe..8ae905cad90 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody/Internal.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody/Internal.hs @@ -63,6 +63,7 @@ import Cardano.Ledger.Core import Cardano.Ledger.Shelley.Era (ShelleyEra) import Cardano.Ledger.Shelley.Tx () import Cardano.Ledger.Slot (SlotNo (..)) +import Control.DeepSeq (NFData) import Control.Monad (unless) import Data.ByteString (ByteString) import Data.ByteString.Builder (Builder, shortByteString, toLazyByteString) @@ -95,6 +96,8 @@ data ShelleyBlockBody era = ShelleyBlockBodyInternal } deriving (Generic) +instance NFData (Tx TopTx era) => NFData (ShelleyBlockBody era) + instance EraBlockBody ShelleyEra where type BlockBody ShelleyEra = ShelleyBlockBody ShelleyEra mkBasicBlockBody = mkBasicBlockBodyShelley diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs index f103d953ad1..a770e61815c 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs @@ -58,6 +58,7 @@ import Cardano.Ledger.Shelley.Rules.Ppup (ShelleyPpupPredFailure) import Cardano.Ledger.Shelley.Rules.Utxo (ShelleyUtxoPredFailure) import Cardano.Ledger.Shelley.Rules.Utxow (ShelleyUtxowPredFailure) import Cardano.Ledger.Slot (epochInfoEpoch, epochInfoFirst) +import Control.DeepSeq (NFData) import Control.Monad.Trans.Reader (asks) import Control.State.Transition ( Embed (..), @@ -98,6 +99,8 @@ data ShelleyBbodyPredFailure era | LedgersFailure (PredicateFailure (EraRule "LEDGERS" era)) -- Subtransition Failures deriving (Generic) +instance NFData (PredicateFailure (EraRule "LEDGERS" era)) => NFData (ShelleyBbodyPredFailure era) + type instance EraRuleFailure "BBODY" ShelleyEra = ShelleyBbodyPredFailure ShelleyEra instance InjectRuleFailure "BBODY" ShelleyBbodyPredFailure ShelleyEra 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 2165ddf575c..dd44e64d9f1 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -424,6 +424,10 @@ class , State (EraRule "BBODY" era) ~ ShelleyBbodyState era , Signal (EraRule "BBODY" era) ~ Block BHeaderView era , ToExpr (Event (EraRule "BBODY" era)) + , NFData (BlockBody era) + , ToExpr (BlockBody era) + , NFData (PredicateFailure (EraRule "BBODY" era)) + , ToExpr (PredicateFailure (EraRule "BBODY" era)) , State (EraRule "LEDGERS" era) ~ LedgerState era , -- For the LEDGER rule STS (EraRule "LEDGER" era) diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/TreeDiff.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/TreeDiff.hs index ac672f3ec32..cb2c84821cb 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/TreeDiff.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/TreeDiff.hs @@ -14,6 +14,7 @@ import Cardano.Ledger.BaseTypes import Cardano.Ledger.Core import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Shelley.AdaPots (AdaPots) +import Cardano.Ledger.Shelley.BlockBody import Cardano.Ledger.Shelley.Governance import Cardano.Ledger.Shelley.LedgerState import Cardano.Ledger.Shelley.PParams @@ -106,6 +107,9 @@ instance ToExpr (ShelleyTxBodyRaw TopTx ShelleyEra) where instance ToExpr (TxBody TopTx ShelleyEra) +-- BlockBody +instance ToExpr (Tx TopTx era) => ToExpr (ShelleyBlockBody era) + -- PoolRank instance ToExpr Likelihood diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/BHeaderView.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/BHeaderView.hs index bf7c0038d70..7b2475a7b70 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/BHeaderView.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/BHeaderView.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} module Cardano.Ledger.BHeaderView where @@ -6,7 +7,9 @@ module Cardano.Ledger.BHeaderView where import Cardano.Ledger.BaseTypes (BoundedRational (..), UnitInterval) import Cardano.Ledger.Hashes (EraIndependentBlockBody, HASH, Hash, KeyHash, KeyRole (..)) import Cardano.Ledger.Slot (SlotNo (..), (-*)) +import Control.DeepSeq (NFData) import Data.Word (Word32) +import GHC.Generics (Generic) -- | 'BHeaderView' provides an interface between block headers -- from different Cardano protocols and packages that should be @@ -30,6 +33,9 @@ data BHeaderView = BHeaderView , bhviewSlot :: SlotNo -- ^ The slot for which this block was submitted to the chain. } + deriving (Generic) + +instance NFData BHeaderView -- | Determine if the given slot is reserved for the overlay schedule. isOverlaySlot :: diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs index 4c025deed6b..748ede4a718 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs @@ -1002,6 +1002,8 @@ instance ToKeyValuePairs a => ToJSON (KeyValuePairs a) where data PerasCert = PerasCert deriving (Eq, Show, Generic, NoThunks) +instance NFData PerasCert + instance EncCBOR PerasCert where encCBOR PerasCert = encCBOR () diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs index 7ee7d19052c..fbd2a31ccf6 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs @@ -32,6 +32,7 @@ import Cardano.Ledger.Binary ( import qualified Cardano.Ledger.Binary.Plain as Plain import Cardano.Ledger.Core import Cardano.Ledger.TxIn (TxIn (..)) +import Control.DeepSeq (NFData) import Data.Foldable (toList) import Data.Set (Set) import qualified Data.Set as Set @@ -61,6 +62,8 @@ deriving anyclass instance ) => NoThunks (Block h era) +instance (NFData h, NFData (BlockBody era)) => NFData (Block h era) + instance forall era h. ( Era era diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs index 4321082b133..bce7e7af42a 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs @@ -16,7 +16,9 @@ module Test.Cardano.Ledger.TreeDiff ( ) where import Cardano.Ledger.Address +import Cardano.Ledger.BHeaderView import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Block import Cardano.Ledger.Coin import Cardano.Ledger.Compactible (fromCompact) import Cardano.Ledger.Core @@ -251,3 +253,7 @@ instance ToExpr a => ToExpr (NonZero a) where instance ToExpr PositiveInterval where toExpr = toExpr . unboundRational + +instance ToExpr BHeaderView + +instance (ToExpr h, ToExpr (BlockBody era)) => ToExpr (Block h era) From a29113dd9de95d1c4331cb4c94b03333f52d434b Mon Sep 17 00:00:00 2001 From: Neil Mayhew Date: Mon, 3 Nov 2025 18:19:42 -0700 Subject: [PATCH 4/9] Move tryRunImpBBODY from Conway.Imp.BbodySpec to Shelly.ImpTest --- .../Cardano/Ledger/Conway/Imp/BbodySpec.hs | 40 ++----------------- .../Test/Cardano/Ledger/Shelley/ImpTest.hs | 37 +++++++++++++++-- 2 files changed, 38 insertions(+), 39 deletions(-) diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs index e33825bc741..6e5aa387c7e 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs @@ -1,34 +1,23 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Test.Cardano.Ledger.Conway.Imp.BbodySpec ( - spec, -) where +module Test.Cardano.Ledger.Conway.Imp.BbodySpec (spec) where -import Cardano.Ledger.BHeaderView (BHeaderView (..)) import Cardano.Ledger.Babbage.Core -import Cardano.Ledger.BaseTypes (BlocksMade (..), Mismatch (..), ProtVer (..), natVersion) -import Cardano.Ledger.Block +import Cardano.Ledger.BaseTypes (Mismatch (..), ProtVer (..), natVersion) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Conway.PParams (ConwayEraPParams (..)) import Cardano.Ledger.Conway.Rules ( ConwayBbodyPredFailure (..), totalRefScriptSizeInBlock, ) -import Cardano.Ledger.Conway.State import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript) -import Cardano.Ledger.Shelley.LedgerState -import Cardano.Ledger.Shelley.Rules ( - BbodyEnv (..), - ShelleyBbodyState (..), - ) import Cardano.Ledger.Shelley.Scripts ( pattern RequireSignature, ) @@ -36,11 +25,9 @@ import Cardano.Ledger.TxIn import Control.Monad (forM) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map import qualified Data.Sequence.Strict as SSeq import Data.Word (Word32) import Lens.Micro ((&), (.~), (^.)) -import Lens.Micro.Mtl (use) import Test.Cardano.Ledger.Babbage.ImpTest import Test.Cardano.Ledger.Conway.ImpTest (ConwayEraImp) import Test.Cardano.Ledger.Core.Utils (txInAt) @@ -82,7 +69,7 @@ spec = do >>= updateAddrTxWits let expectedTotalRefScriptSize = scriptSize * sum txScriptCounts - predFailures <- expectLeftExpr =<< tryRunBBODY txs + predFailures <- expectLeftExpr =<< tryRunImpBBODY txs predFailures `shouldBe` NE.fromList [ injectFailure @@ -129,7 +116,7 @@ spec = do pure $ refScriptTxs ++ [spendTx] ) - predFailures <- expectLeftExpr =<< tryRunBBODY txs + predFailures <- expectLeftExpr =<< tryRunImpBBODY txs predFailures `shouldBe` NE.fromList [ injectFailure @@ -267,25 +254,6 @@ spec = do <$> getUTxO `shouldReturn` (if isPostV10 protVer then scriptSize else 0) where - tryRunBBODY txs = do - let blockBody = mkBasicBlockBody @era & txSeqBlockBodyL .~ SSeq.fromList txs - nes <- use impNESL - let ls = nes ^. nesEsL . esLStateL - pp = nes ^. nesEsL . curPParamsEpochStateL @era - kh <- freshKeyHash - slotNo <- use impCurSlotNoG - let bhView = - BHeaderView - { bhviewID = kh - , bhviewBSize = fromIntegral $ bBodySize (ProtVer (eraProtVerLow @era) 0) blockBody - , bhviewHSize = 0 - , bhviewBHash = hashBlockBody blockBody - , bhviewSlot = slotNo - } - tryRunImpRule @"BBODY" - (BbodyEnv pp (nes ^. chainAccountStateL)) - (BbodyState ls (BlocksMade Map.empty)) - (Block {blockHeader = bhView, blockBody}) isPostV10 protVer = pvMajor protVer >= natVersion @11 -- Generate a list of integers such that the sum of their multiples by scale is greater than toExceed 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 dd44e64d9f1..909dc64aab0 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -68,6 +68,7 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( impAnnDoc, impLogToExpr, runImpRule, + tryRunImpBBODY, tryRunImpRule, tryRunImpRuleNoAssertions, delegateStake, @@ -170,10 +171,10 @@ import Cardano.Ledger.Address ( RewardAccount (..), bootstrapKeyHash, ) -import Cardano.Ledger.BHeaderView (BHeaderView) +import Cardano.Ledger.BHeaderView (BHeaderView (..)) import Cardano.Ledger.BaseTypes import Cardano.Ledger.Binary (DecCBOR, EncCBOR) -import Cardano.Ledger.Block (Block) +import Cardano.Ledger.Block (Block (..)) import Cardano.Ledger.Coin import Cardano.Ledger.Compactible (fromCompact) import Cardano.Ledger.Credential (Credential (..), Ptr, StakeReference (..), credToText) @@ -212,7 +213,7 @@ import Cardano.Ledger.Shelley.LedgerState ( import Cardano.Ledger.Shelley.Rules ( BbodyEnv (..), LedgerEnv (..), - ShelleyBbodyState, + ShelleyBbodyState (..), ShelleyDelegPredFailure, ShelleyPoolPredFailure, ShelleyUtxoPredFailure, @@ -1261,6 +1262,36 @@ submitFailingTxM tx mkExpectedFailures = do expectedFailures <- mkExpectedFailures fixedUpTx predFailures `shouldBeExpr` expectedFailures +tryRunImpBBODY :: + forall era. + ShelleyEraImp era => + [Tx TopTx era] -> + ImpTestM + era + ( Either + (NonEmpty (PredicateFailure (EraRule "BBODY" era))) + (State (EraRule "BBODY" era), [Event (EraRule "BBODY" era)]) + ) +tryRunImpBBODY txs = do + let blockBody = mkBasicBlockBody @era & txSeqBlockBodyL .~ SSeq.fromList txs + nes <- use impNESL + let ls = nes ^. nesEsL . esLStateL + pp = nes ^. nesEsL . curPParamsEpochStateL @era + kh <- freshKeyHash + slotNo <- use impCurSlotNoG + let bhView = + BHeaderView + { bhviewID = kh + , bhviewBSize = fromIntegral $ bBodySize (ProtVer (eraProtVerLow @era) 0) blockBody + , bhviewHSize = 0 + , bhviewBHash = hashBlockBody blockBody + , bhviewSlot = slotNo + } + tryRunImpRule @"BBODY" + (BbodyEnv pp (nes ^. chainAccountStateL)) + (BbodyState ls (BlocksMade Map.empty)) + (Block {blockHeader = bhView, blockBody}) + tryRunImpRule :: forall rule era. (STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) => From a88ffac3faff8e555296f9e2b120b82af2192e37 Mon Sep 17 00:00:00 2001 From: Neil Mayhew Date: Tue, 4 Nov 2025 11:28:16 -0700 Subject: [PATCH 5/9] Implement block-submitting Imp functions --- .../src/Cardano/Ledger/Alonzo/Rules/Bbody.hs | 4 + .../Cardano/Ledger/Conway/Imp/BbodySpec.hs | 123 +++----- eras/shelley/impl/CHANGELOG.md | 17 +- .../src/Cardano/Ledger/Shelley/Rules/Bbody.hs | 4 + .../Cardano/Ledger/Shelley/Rules/Ledgers.hs | 4 + .../Test/Cardano/Ledger/Shelley/Era.hs | 3 +- .../Test/Cardano/Ledger/Shelley/ImpTest.hs | 282 +++++++++++++++--- 7 files changed, 315 insertions(+), 122 deletions(-) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs index 1da008f2e4a..8e0a81825b6 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs @@ -87,6 +87,10 @@ newtype AlonzoBbodyEvent era = ShelleyInAlonzoEvent (ShelleyBbodyEvent era) deriving (Generic) +deriving instance + Eq (Event (EraRule "LEDGERS" era)) => + Eq (AlonzoBbodyEvent era) + type instance EraRuleFailure "BBODY" AlonzoEra = AlonzoBbodyPredFailure AlonzoEra instance InjectRuleFailure "BBODY" AlonzoBbodyPredFailure AlonzoEra diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs index 6e5aa387c7e..ddf999f457e 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs @@ -21,11 +21,13 @@ import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript) import Cardano.Ledger.Shelley.Scripts ( pattern RequireSignature, ) -import Cardano.Ledger.TxIn -import Control.Monad (forM) +import Data.Foldable (for_) +import Data.List (inits) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Sequence.Strict as SSeq +import qualified Data.Set as Set +import Data.Traversable (for) import Data.Word (Word32) import Lens.Micro ((&), (.~), (^.)) import Test.Cardano.Ledger.Babbage.ImpTest @@ -48,38 +50,32 @@ spec = do let maxRefScriptSizePerTx = fromIntegral @Word32 @Int $ pp ^. ppMaxRefScriptSizePerTxG maxRefScriptSizePerBlock = fromIntegral @Word32 @Int $ pp ^. ppMaxRefScriptSizePerBlockG + txScriptCounts <- genNumAdditionsExceeding scriptSize maxRefScriptSizePerTx maxRefScriptSizePerBlock - let mkTxWithNScripts n = do - -- Instead of using the rootTxIn, we are creating an input for each transaction - -- that we subsequently need to submit, - -- so that we can submit them independently of each other. - txIn <- freshKeyAddr_ >>= \addr -> sendCoinTo addr (Coin 8_000_000) - refIns <- replicateM n $ produceRefScript (fromPlutusScript plutusScript) - pure $ mkTxWithRefInputs txIn (NE.fromList refIns) - - txs <- do - forM txScriptCounts $ \n -> do - mkTxWithNScripts n - >>= fixupFees - >>= updateAddrTxWits - - let expectedTotalRefScriptSize = scriptSize * sum txScriptCounts - predFailures <- expectLeftExpr =<< tryRunImpBBODY txs - predFailures - `shouldBe` NE.fromList - [ injectFailure - ( BodyRefScriptsSizeTooBig $ - Mismatch - { mismatchSupplied = expectedTotalRefScriptSize - , mismatchExpected = maxRefScriptSizePerBlock - } - ) - ] + txs <- for txScriptCounts $ \n -> do + -- Instead of using the rootTxIn, we're creating an input for each transaction + -- so that transactions that will be submitted in a block + -- can be submitted independently from the ones that prepared the + -- reference inputs + txIn <- freshKeyAddr_ >>= \addr -> sendCoinTo addr (Coin 100_000_000) + refIns <- replicateM n $ produceRefScript (fromPlutusScript plutusScript) + pure $ mkTxWithRefInputs txIn (NE.fromList refIns) + + submitFailingBlock + txs + [ injectFailure + ( BodyRefScriptsSizeTooBig $ + Mismatch + { mismatchSupplied = scriptSize * sum txScriptCounts + , mismatchExpected = maxRefScriptSizePerBlock + } + ) + ] it "BodyRefScriptsSizeTooBig with reference scripts in the same block" $ whenMajorVersionAtLeast @11 $ do @@ -96,37 +92,24 @@ spec = do maxRefScriptSizePerTx maxRefScriptSizePerBlock - let expectedTotalRefScriptSize = scriptSize * sum txScriptCounts - - -- We are creating reference scripts and transaction that depend on them in a "simulation", - -- so the result will be correctly constructed that are not applied to the ledger state - txs :: [Tx TopTx era] <- simulateThenRestore $ do - concat - <$> forM - txScriptCounts - ( \n -> do - -- produce reference scripts - refScriptTxs <- - replicateM n (produceRefScriptsTx (fromPlutusScript plutusScript :| [])) + let + -- These txs will be grouped into a block + buildTxs = for_ txScriptCounts $ \n -> do + refIns <- replicateM n $ produceRefScript (fromPlutusScript plutusScript) + submitTx $ + mkBasicTx mkBasicTxBody + & bodyTxL . referenceInputsTxBodyL .~ Set.fromList refIns - -- spend using the reference scripts - let txIns = (`mkTxInPartial` 0) . txIdTx <$> refScriptTxs - rootIn <- fst <$> getImpRootTxOut - spendTx <- submitTxWithRefInputs rootIn (NE.fromList txIns) - pure $ refScriptTxs ++ [spendTx] + withTxsInFailingBlock + buildTxs + [ injectFailure + ( BodyRefScriptsSizeTooBig $ + Mismatch + { mismatchSupplied = scriptSize * sum txScriptCounts + , mismatchExpected = maxRefScriptSizePerBlock + } ) - - predFailures <- expectLeftExpr =<< tryRunImpBBODY txs - predFailures - `shouldBe` NE.fromList - [ injectFailure - ( BodyRefScriptsSizeTooBig $ - Mismatch - { mismatchSupplied = expectedTotalRefScriptSize - , mismatchExpected = maxRefScriptSizePerBlock - } - ) - ] + ] it "totalRefScriptSizeInBlock" $ do script <- RequireSignature @era <$> freshKeyHash @@ -141,7 +124,7 @@ spec = do -- their individual reference script sizes, and then restore the original state - -- meaning the transactions are not actually applied. -- Finally, we check that the accumulated sizes from both before and after match. - txsWithRefScriptSizes :: ([(Tx TopTx era, Int)], Int) <- simulateThenRestore $ do + txsWithSizes <- simulateThenRestore $ do let mkTxWithExpectedSize expectedSize txAction = do tx <- txAction totalRefScriptSizeInBlock protVer [tx] <$> getUTxO `shouldReturn` expectedSize @@ -187,24 +170,16 @@ spec = do -- check and return the accumulated reference script size of all transactions, -- so we can check that the same sum for the unapplied transactions matches - let expectedTotalRefScriptSize = 5 * scriptSize - totalRefScriptSizeInBlock protVer (SSeq.fromList (fst <$> txsWithRefScriptSizes)) - <$> getUTxO `shouldReturn` expectedTotalRefScriptSize - pure (txsWithRefScriptSizes, expectedTotalRefScriptSize) + let (txs, sizes) = unzip txsWithRefScriptSizes + totalRefScriptSizeInBlock protVer (SSeq.fromList txs) <$> getUTxO `shouldReturn` sum sizes - let (txWithSizes, expectedTotalSize) = txsWithRefScriptSizes + pure txsWithRefScriptSizes -- for each prefix of the list, the accumulated sum should match the sum of the applied transactions - forM_ ([1 .. length txWithSizes] :: [Int]) $ \ix -> do - let slice = take ix txWithSizes - - totalRefScriptSizeInBlock protVer (SSeq.fromList (fst <$> slice)) - <$> getUTxO - `shouldReturn` (if isPostV10 protVer then sum (snd <$> slice) else 0) - - totalRefScriptSizeInBlock protVer (SSeq.fromList (fst <$> txWithSizes)) - <$> getUTxO - `shouldReturn` (if isPostV10 protVer then expectedTotalSize else 0) + for_ (drop 1 $ inits txsWithSizes) $ \prefix -> do + let (txs, sizes) = unzip prefix + expectedSize = if isPostV10 protVer then sum sizes else 0 + totalRefScriptSizeInBlock protVer (SSeq.fromList txs) <$> getUTxO `shouldReturn` expectedSize -- disabled in conformance because submiting phase2-invalid transactions are not supported atm -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/910 @@ -231,7 +206,7 @@ spec = do else freshKeyAddrNoPtr_ pure $ mkBasicTxOut addr mempty & referenceScriptTxOutL .~ pure (fromNativeScript script) - (txs :: [Tx TopTx era]) <- simulateThenRestore $ do + txs <- simulateThenRestore $ do -- submit an invalid transaction which attempts to consume the failing script -- and specifies as collateral return the txout with reference script createCollateralTx <- diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 1f51af6b8ed..a20be8fe7f2 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -49,6 +49,21 @@ ### `testlib` +* Add: + - `submitBlock_` + - `submitBlock` + - `submitFailingBlock` + - `submitFailingBlockM` + - `withTxsInBlock_` + - `withTxsInBlock` + - `withTxsInFailingBlock` + - `withTxsInFailingBlockM` + - `tryTxsInBlock` +* Remove `tryRunImpBBODY` +* Add `Eq` instances for: + - `AlonzoBbodyEvent` + - `ShelleyBbodyEvent` + - `ShelleyLedgersEvent` * Add `NFData` and `ToExpr` constraints and instances for: - `AlonzoBlockBody` - `AlonzoBbodyPredFailure` @@ -58,7 +73,7 @@ - `BHeaderView` - `Block` * Add a `Generic` instance for `BHeaderView` -* Add `impEventsFrom` +* Add `impEventsFrom`, `impTransactionsFrom` * Change type of `ImpTestState.impEvents` field from `[]` to `Seq` * Renamed `impLastTick` to `impCurSlotNo` and `impLastTickG` to `impCurSlotNoG` * Add CDDL certificate definitions: `account_registration_cert`, `account_unregistration_cert`, `delegation_to_stake_pool_cert` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs index a770e61815c..f805678d9d0 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs @@ -160,6 +160,10 @@ newtype ShelleyBbodyEvent era = LedgersEvent (Event (EraRule "LEDGERS" era)) deriving (Generic) +deriving instance + Eq (Event (EraRule "LEDGERS" era)) => + Eq (ShelleyBbodyEvent era) + deriving stock instance ( Era era , Show (PredicateFailure (EraRule "LEDGERS" era)) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledgers.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledgers.hs index 372f325507c..ec02f8e1e75 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledgers.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledgers.hs @@ -125,6 +125,10 @@ newtype ShelleyLedgersEvent era = LedgerEvent (Event (EraRule "LEDGER" era)) deriving (Generic) +deriving instance + Eq (Event (EraRule "LEDGER" era)) => + Eq (ShelleyLedgersEvent era) + deriving stock instance ( Era era , Show (PredicateFailure (EraRule "LEDGER" era)) 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 f1c9b813d3e..adf5f2d9f79 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Era.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Era.hs @@ -21,7 +21,7 @@ import Cardano.Ledger.Core import Cardano.Ledger.Credential import Cardano.Ledger.Plutus (emptyCostModels) import Cardano.Ledger.Shelley -import Cardano.Ledger.Shelley.API (ApplyTx) +import Cardano.Ledger.Shelley.API (ApplyBlock, ApplyTx) import Cardano.Ledger.Shelley.LedgerState import Cardano.Ledger.Shelley.Scripts import Cardano.Ledger.Shelley.State @@ -38,6 +38,7 @@ import Test.Cardano.Ledger.Shelley.TreeDiff () class ( EraTest era + , ApplyBlock era , ApplyTx era , ShelleyEraScript era , EraTransition 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 909dc64aab0..475b558d6a0 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -33,6 +33,9 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( ShelleyEraImp (..), PlutusArgs, ScriptTestContext, + iteFixupL, + itePostSubmitTxHookL, + itePostEpochBoundaryHookL, impWitsVKeyNeeded, modifyPrevPParams, passEpoch, @@ -58,6 +61,16 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( submitFailingTx, submitFailingTxM, trySubmitTx, + submitBlock_, + submitBlock, + submitFailingBlock, + submitFailingBlockM, + withTxsInBlock_, + withTxsInBlock, + withTxsInFailingBlock, + withTxsInFailingBlockM, + withTxsInBlockEither, + tryTxsInBlock, impShelleyExpectTxSuccess, modifyNES, getProtVer, @@ -68,7 +81,6 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( impAnnDoc, impLogToExpr, runImpRule, - tryRunImpBBODY, tryRunImpRule, tryRunImpRuleNoAssertions, delegateStake, @@ -149,6 +161,8 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( withPostFixup, withPreFixup, impEventsFrom, + impTransactionsFrom, + impWithoutRecordingTxs, impNESL, impGlobalsL, impCurSlotNoG, @@ -188,6 +202,7 @@ import Cardano.Ledger.Keys ( ) import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Shelley.API.ByronTranslation (translateToShelleyLedgerStateFromUtxo) +import Cardano.Ledger.Shelley.API.Validation (BlockTransitionError (..), applyBlockEither) import Cardano.Ledger.Shelley.AdaPots (sumAdaPots, totalAdaPotsES) import Cardano.Ledger.Shelley.Core import Cardano.Ledger.Shelley.Genesis ( @@ -238,10 +253,10 @@ 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 (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, modify', put) import Control.Monad.Trans.Fail.String (errorFail) import Control.Monad.Trans.Reader (ReaderT (..)) import Control.Monad.Writer.Class (MonadWriter (..)) @@ -256,7 +271,7 @@ import Data.Bifunctor (first) import Data.Coerce (coerce) import Data.Data (Proxy (..), type (:~:) (..)) import Data.Default (Default (..)) -import Data.Foldable (toList, traverse_) +import Data.Foldable (fold, toList, traverse_) import Data.Functor (($>)) import Data.Functor.Identity (Identity (..)) import Data.List.NonEmpty (NonEmpty) @@ -351,6 +366,9 @@ data ImpTestState era = ImpTestState , impCurSlotNo :: !SlotNo , impGlobals :: !Globals , impEvents :: Seq (SomeSTSEvent era) + , impRecordedTransactions :: !(StrictMaybe (StrictSeq (Tx TopTx era))) + -- ^ When this is set to `SNothing` transactions are not being recorded. + -- This should never be switched to `Just` outside of simulations. } -- | This is a preliminary state that is used to prepare the actual `ImpTestState` @@ -416,19 +434,30 @@ impNativeScriptsG = impNativeScriptsL impEventsL :: Lens' (ImpTestState era) (Seq (SomeSTSEvent era)) impEventsL = lens impEvents (\x y -> x {impEvents = y}) +impRecordedTransactionsL :: Lens' (ImpTestState era) (StrictMaybe (StrictSeq (Tx TopTx era))) +impRecordedTransactionsL = lens impRecordedTransactions (\x y -> x {impRecordedTransactions = y}) + class ( ShelleyEraTest era - , -- For BBODY rule + , -- For the 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 + , Eq (Event (EraRule "BBODY" era)) , ToExpr (Event (EraRule "BBODY" era)) + , Typeable (Event (EraRule "BBODY" era)) , NFData (BlockBody era) , ToExpr (BlockBody era) , NFData (PredicateFailure (EraRule "BBODY" era)) , ToExpr (PredicateFailure (EraRule "BBODY" era)) + , EncCBOR (PredicateFailure (EraRule "BBODY" era)) + , DecCBOR (PredicateFailure (EraRule "BBODY" era)) + , -- For the LEDGERS rule + Eq (Event (EraRule "LEDGERS" era)) + , ToExpr (Event (EraRule "LEDGERS" era)) + , Typeable (Event (EraRule "LEDGERS" era)) , State (EraRule "LEDGERS" era) ~ LedgerState era , -- For the LEDGER rule STS (EraRule "LEDGER" era) @@ -469,6 +498,7 @@ class , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era + , InjectRuleFailure "BBODY" ShelleyPoolPredFailure era ) => ShelleyEraImp era where @@ -652,6 +682,7 @@ defaultInitImpTestState nes = do , impCurSlotNo = slotNo , impGlobals = globals , impEvents = mempty + , impRecordedTransactions = mempty } withEachEraVersion :: @@ -923,6 +954,25 @@ impEventsFrom :: ImpTestM era [SomeSTSEvent era] impEventsFrom = fmap (toList . snd) . listen +impTransactionsFrom :: + ImpTestM era () -> + ImpTestM era (StrictSeq (Tx TopTx era)) +impTransactionsFrom act = do + mTxsPrev <- use impRecordedTransactionsL + impRecordedTransactionsL .= SJust mempty + act + mTxsDuring <- use impRecordedTransactionsL + impRecordedTransactionsL .= liftA2 (<>) mTxsPrev mTxsDuring + pure $ fold mTxsDuring + +impWithoutRecordingTxs :: ImpTestM era a -> ImpTestM era a +impWithoutRecordingTxs act = do + prev <- use impRecordedTransactionsL + impRecordedTransactionsL .= SNothing + res <- act + impRecordedTransactionsL .= prev + pure res + runShelleyBase :: ShelleyBase a -> ImpTestM era a runShelleyBase act = do globals <- use impGlobalsL @@ -1182,6 +1232,8 @@ logFeeMismatch tx = do logDoc $ "Estimated fee " <> ansiExpr feeUsed <> " while required fee is " <> ansiExpr feeMin +-- * Submitting transactions + submitTx_ :: (HasCallStack, ShelleyEraImp era) => Tx TopTx era -> ImpTestM era () submitTx_ = void . submitTx @@ -1200,14 +1252,14 @@ trySubmitTx :: 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 - globals <- use impGlobalsL - let trc = TRC (lEnv, st ^. nesEsL . esLStateL, txFixed) -- Check for conformance + globals <- use impGlobalsL + let trc = TRC (lEnv, st ^. nesEsL . esLStateL, txFixed) asks itePostSubmitTxHook >>= (\f -> f globals trc res) case res of @@ -1215,25 +1267,32 @@ trySubmitTx tx = do -- Verify that produced predicate failures are ready for the node-to-client protocol liftIO $ forM_ predFailures $ roundTripEraExpectation @era 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) + Right (newState, events) -> do + impNESL . nesEsL . esLStateL .= newState tell . Seq.fromList $ SomeSTSEvent @era @"LEDGER" <$> events - modify $ impNESL . nesEsL . esLStateL .~ st' + + modify' $ impRecordedTransactionsL %~ fmap (SSeq.|> txFixed) + + ImpTestState {impRootTxIn} <- get 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" + 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) + -- 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. + assumedNewRoot = TxIn txId (mkTxIxPartial (fromIntegral rootIndex)) + 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. @@ -1262,35 +1321,166 @@ submitFailingTxM tx mkExpectedFailures = do expectedFailures <- mkExpectedFailures fixedUpTx predFailures `shouldBeExpr` expectedFailures -tryRunImpBBODY :: +-- * Submitting blocks + +-- | Submit a list of transactions as a block that's expected to succeed. +-- The inputs and outputs are automatically balanced. +submitBlock_ :: + ( HasCallStack + , ShelleyEraImp era + ) => + [Tx TopTx era] -> + ImpTestM era () +submitBlock_ = withTxsInBlock_ . traverse_ submitTx_ + +-- | Submit a list of transactions as a block that's expected to succeed. +-- The inputs and outputs are automatically balanced. +submitBlock :: + ( HasCallStack + , ShelleyEraImp era + ) => + [Tx TopTx era] -> + ImpTestM era (Block BHeaderView era) +submitBlock = withTxsInBlock . traverse_ submitTx_ + +-- | Submit a list of transactions as a block that's expected to fail +-- with the given predicate failures. +-- The inputs and outputs are automatically balanced. +submitFailingBlock :: + ( HasCallStack + , ShelleyEraImp era + ) => + [Tx TopTx era] -> + NonEmpty (PredicateFailure (EraRule "BBODY" era)) -> + ImpTestM era () +submitFailingBlock = withTxsInFailingBlock . traverse_ submitTx_ + +-- | Submit a list of transactions as a block that's expected to be rejected, +-- and compute the expected predicate failures from the created block using the supplied action. +-- The inputs and outputs are automatically balanced. +submitFailingBlockM :: + ( HasCallStack + , ShelleyEraImp era + ) => + [Tx TopTx era] -> + (Block BHeaderView era -> ImpTestM era (NonEmpty (PredicateFailure (EraRule "BBODY" era)))) -> + ImpTestM era () +submitFailingBlockM = withTxsInFailingBlockM . traverse_ submitTx_ + +-- | Gather all the txs submitted by @act@ and resubmit them as a block that's expected to succeed. +withTxsInBlock_ :: + ( HasCallStack + , ShelleyEraImp era + ) => + ImpTestM era a -> + ImpTestM era () +withTxsInBlock_ = void . withTxsInBlock . void + +-- | Gather all the txs submitted by @act@ and resubmit them as a block that's expected to succeed. +withTxsInBlock :: + ( HasCallStack + , ShelleyEraImp era + ) => + ImpTestM era () -> + ImpTestM era (Block BHeaderView era) +withTxsInBlock = expectRightDeepExpr <=< withTxsInBlockEither + +-- | Gather all the txs submitted by @act@ and resubmit them as a block +-- that's expected to fail with the given predicate failures. +withTxsInFailingBlock :: + ( HasCallStack + , ShelleyEraImp era + ) => + ImpTestM era () -> + NonEmpty (PredicateFailure (EraRule "BBODY" era)) -> + ImpTestM era () +withTxsInFailingBlock act = withTxsInFailingBlockM act . const . pure + +-- | Gather all the txs submitted by @act@ and resubmit them as a block that's expected to fail +-- and compute the expected predicate failures from the created block using the supplied action. +withTxsInFailingBlockM :: + ( HasCallStack + , ShelleyEraImp era + ) => + ImpTestM era () -> + (Block BHeaderView era -> ImpTestM era (NonEmpty (PredicateFailure (EraRule "BBODY" era)))) -> + ImpTestM era () +withTxsInFailingBlockM act mkExpectedFailures = do + (predFailures, block) <- expectLeftDeepExpr <=< withTxsInBlockEither $ act + expectedFailures <- mkExpectedFailures block + predFailures `shouldBeExpr` expectedFailures + +-- | Given an action that submits transactions, try to resubmit the transactions as a block. +-- Return the block that was created using the transactions and any predicate +-- failures that are produced. +withTxsInBlockEither :: forall era. ShelleyEraImp era => - [Tx TopTx era] -> + ImpTestM era () -> ImpTestM era ( Either - (NonEmpty (PredicateFailure (EraRule "BBODY" era))) - (State (EraRule "BBODY" era), [Event (EraRule "BBODY" era)]) + (NonEmpty (PredicateFailure (EraRule "BBODY" era)), Block BHeaderView era) + (Block BHeaderView era) ) -tryRunImpBBODY txs = do - let blockBody = mkBasicBlockBody @era & txSeqBlockBodyL .~ SSeq.fromList txs - nes <- use impNESL - let ls = nes ^. nesEsL . esLStateL - pp = nes ^. nesEsL . curPParamsEpochStateL @era - kh <- freshKeyHash +withTxsInBlockEither act = do + stateBefore <- get + txs <- impTransactionsFrom act + stateAfter <- get + put stateBefore + tryTxsInBlock txs stateAfter + +-- | Given a sequence of fixed-up transactions and an expected final test state, +-- try to submit the transactions as a block. +-- Return the block that was created using the transactions and any predicate +-- failures that are produced. +tryTxsInBlock :: + forall era. + ShelleyEraImp era => + StrictSeq (Tx TopTx era) -> + ImpTestState era -> + ImpTestM + era + ( Either + (NonEmpty (PredicateFailure (EraRule "BBODY" era)), Block BHeaderView era) + (Block BHeaderView era) + ) +tryTxsInBlock txs finalState = do + blockIssuer <- freshKeyHash slotNo <- use impCurSlotNoG - let bhView = - BHeaderView - { bhviewID = kh - , bhviewBSize = fromIntegral $ bBodySize (ProtVer (eraProtVerLow @era) 0) blockBody - , bhviewHSize = 0 - , bhviewBHash = hashBlockBody blockBody - , bhviewSlot = slotNo - } - tryRunImpRule @"BBODY" - (BbodyEnv pp (nes ^. chainAccountStateL)) - (BbodyState ls (BlocksMade Map.empty)) - (Block {blockHeader = bhView, blockBody}) + + let + blockBody = mkBasicBlockBody @era & txSeqBlockBodyL .~ txs + blockHeader = + BHeaderView + { bhviewID = blockIssuer + , bhviewBSize = fromIntegral $ bBodySize (ProtVer (eraProtVerLow @era) 0) blockBody + , bhviewHSize = 0 + , bhviewBHash = hashBlockBody blockBody + , bhviewSlot = slotNo + } + block = Block {blockHeader, blockBody} + + globals <- use impGlobalsL + nes <- use impNESL + + let res = applyBlockEither EPReturn ValidateAll globals nes block + + case res of + Left (BlockTransitionError predFailures) -> do + -- Verify that produced predicate failures are ready for the node-to-client protocol + liftIO $ forM_ predFailures $ roundTripEraExpectation @era + pure $ Left (predFailures, block) + Right (blockNes, events) -> do + previousEvents <- use impEventsL + let newEvents = SomeSTSEvent @era @"BBODY" <$> Seq.fromList events + blockEvents = previousEvents <> newEvents + put $ + finalState + & impNESL .~ blockNes + & impEventsL .~ blockEvents + + pure $ Right block tryRunImpRule :: forall rule era. @@ -2033,4 +2223,4 @@ shelleyDelegStakeTxCert :: Credential Staking -> KeyHash StakePool -> TxCert era -shelleyDelegStakeTxCert cred pool = DelegStakeTxCert cred pool +shelleyDelegStakeTxCert = DelegStakeTxCert From 9ad09cfe474b29d78cbdc58fadcd38ade350b312 Mon Sep 17 00:00:00 2001 From: Neil Mayhew Date: Mon, 17 Nov 2025 16:35:04 -0700 Subject: [PATCH 6/9] Bump MaxBlockExUnits used in Imp tests --- .../alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 3c185c95771..5976ee3c491 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs @@ -426,8 +426,8 @@ instance ShelleyEraImp AlonzoEra where } , agMaxBlockExUnits = ExUnits - { exUnitsMem = 50_000_000 - , exUnitsSteps = 40_000_000_000 + { exUnitsMem = 200_000_000 + , exUnitsSteps = 200_000_000_000 } , agMaxValSize = 5000 , agCollateralPercentage = 150 From 49a609bdab46cf49b06afe99369449a9394f1104 Mon Sep 17 00:00:00 2001 From: Neil Mayhew Date: Mon, 3 Nov 2025 17:56:42 -0700 Subject: [PATCH 7/9] Implement BBODY Imp tests for Alonzo --- eras/alonzo/impl/cardano-ledger-alonzo.cabal | 1 + .../testlib/Test/Cardano/Ledger/Alonzo/Imp.hs | 2 + .../Cardano/Ledger/Alonzo/Imp/BbodySpec.hs | 113 ++++++++++++++++++ 3 files changed, 116 insertions(+) create mode 100644 eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/BbodySpec.hs diff --git a/eras/alonzo/impl/cardano-ledger-alonzo.cabal b/eras/alonzo/impl/cardano-ledger-alonzo.cabal index 63a72c73047..97ce58b34ca 100644 --- a/eras/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/eras/alonzo/impl/cardano-ledger-alonzo.cabal @@ -161,6 +161,7 @@ library testlib Test.Cardano.Ledger.Alonzo.Era Test.Cardano.Ledger.Alonzo.Examples Test.Cardano.Ledger.Alonzo.Imp + Test.Cardano.Ledger.Alonzo.Imp.BbodySpec Test.Cardano.Ledger.Alonzo.Imp.UtxoSpec Test.Cardano.Ledger.Alonzo.Imp.UtxosSpec Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs index dee9216e2b4..c11e5bcb646 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs @@ -10,6 +10,7 @@ module Test.Cardano.Ledger.Alonzo.Imp where import Cardano.Ledger.Alonzo (AlonzoEra) import Cardano.Ledger.Shelley.Core (ShelleyEraTxCert) +import qualified Test.Cardano.Ledger.Alonzo.Imp.BbodySpec as Bbody import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxoSpec as Utxo import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxosSpec as Utxos import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec as Utxow @@ -27,6 +28,7 @@ spec :: spec = do MaryImp.spec @era describe "AlonzoImpSpec" . withEachEraVersion @era $ do + Bbody.spec Utxo.spec Utxos.spec Utxow.spec diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/BbodySpec.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/BbodySpec.hs new file mode 100644 index 00000000000..f784ed37a0c --- /dev/null +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/BbodySpec.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Cardano.Ledger.Alonzo.Imp.BbodySpec (spec) where + +import Cardano.Ledger.Alonzo.Core +import Cardano.Ledger.Alonzo.Scripts (eraLanguages) +import Cardano.Ledger.Alonzo.TxWits (unRedeemersL) +import Cardano.Ledger.BaseTypes ( + StrictMaybe (..), + textToUrl, + ) +import Cardano.Ledger.Credential (Credential (..)) +import Cardano.Ledger.Plutus ( + Data (..), + hashPlutusScript, + withSLanguage, + ) +import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL, nesEsL) +import Cardano.Ledger.Shelley.Rules (ShelleyPoolPredFailure (..)) +import Cardano.Ledger.State (PoolMetadata (..), sppMetadataL) +import Control.Monad.Reader (asks) +import Control.Monad.State.Strict (get) +import qualified Data.ByteString as BS +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust) +import Lens.Micro +import qualified PlutusLedgerApi.Common as P +import Test.Cardano.Ledger.Alonzo.ImpTest +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Ledger.Plutus.Examples + +spec :: forall era. AlonzoEraImp era => SpecWith (ImpInit (LedgerSpec era)) +spec = describe "BBODY" $ do + forM_ (eraLanguages @era) $ \lang -> + withSLanguage lang $ \slang -> + describe (show lang) $ do + let + alwaysSucceedsWithDatumHash = hashPlutusScript $ alwaysSucceedsWithDatum slang :: ScriptHash + alwaysFailsWithDatumHash = hashPlutusScript $ alwaysFailsWithDatum slang :: ScriptHash + alwaysSucceedsNoDatumHash = hashPlutusScript $ alwaysSucceedsNoDatum slang :: ScriptHash + alwaysFailsNoDatumHash = hashPlutusScript $ alwaysFailsNoDatum slang :: ScriptHash + evenRedeemerNoDatumHash = hashPlutusScript $ evenRedeemerNoDatum slang :: ScriptHash + + it "succeeds with eight Plutus scripts" $ do + rewardAccount <- registerStakeCredential $ ScriptHashObj evenRedeemerNoDatumHash + txCert <- genUnRegTxCert $ ScriptHashObj evenRedeemerNoDatumHash + + withTxsInBlock_ $ do + impAnn "notValidatingTx" $ do + txIn <- produceScript alwaysFailsWithDatumHash + submitPhase2Invalid_ $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn] + impAnn "validatingTx" $ do + txIn <- produceScript alwaysSucceedsWithDatumHash + submitTx_ $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn] + + impAnn "notValidatingTxWithMint" $ do + submitPhase2Invalid_ =<< mkTokenMintingTx alwaysFailsNoDatumHash + impAnn "validatingTxWithMint" $ do + submitTx_ =<< mkTokenMintingTx alwaysSucceedsNoDatumHash + + maxExUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL + + let dex i = (Data $ P.I i, maxExUnits) + rPurpose = mkRewardingPurpose (AsIx 0) + cPurpose = mkCertifyingPurpose (AsIx 0) + + impAnn "notValidatingTxWithWithdrawal" $ do + submitPhase2Invalid_ $ + mkBasicTx mkBasicTxBody + & bodyTxL . withdrawalsTxBodyL .~ Withdrawals [(rewardAccount, mempty)] + & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert rPurpose (dex 1) + impAnn "validatingTxWithWithdrawal" $ do + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL . withdrawalsTxBodyL .~ Withdrawals [(rewardAccount, mempty)] + & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert rPurpose (dex 0) + + impAnn "notValidatingTxWithCert" $ do + submitPhase2Invalid_ $ + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL .~ [txCert] + & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert cPurpose (dex 1) + impAnn "validatingTxWithCert" $ do + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL .~ [txCert] + & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert cPurpose (dex 0) + + it "fails with bad pool MD hash in Tx" $ do + let + hashSize = standardHashSize + 1 + metadata = PoolMetadata (fromJust $ textToUrl 64 "") (BS.replicate hashSize 0) + + poolId <- freshKeyHash + rewardAccount <- registerStakeCredential $ ScriptHashObj alwaysSucceedsNoDatumHash + poolParams <- freshPoolParams poolId rewardAccount <&> sppMetadataL .~ SJust metadata + + let tx = mkBasicTx $ mkBasicTxBody & certsTxBodyL .~ [RegPoolTxCert poolParams] + + submitFailingTx tx [injectFailure $ PoolMedataHashTooBig poolId hashSize] + + fixup <- asks iteFixup + txs <- traverse fixup [tx] + finalState <- get + + failures <- fmap fst . expectLeftDeepExpr =<< tryTxsInBlock txs finalState + failures `shouldBeExpr` [injectFailure $ PoolMedataHashTooBig poolId hashSize] From 1e320541630adb2315b2a50eabd0aeb07b0ef80c Mon Sep 17 00:00:00 2001 From: Neil Mayhew Date: Thu, 13 Nov 2025 14:15:32 -0700 Subject: [PATCH 8/9] Remove obsolete AlonzoBBODY tests from cardano-ledger-test --- .../cardano-ledger-test.cabal | 1 - .../Cardano/Ledger/Examples/AlonzoBBODY.hs | 630 ------------------ libs/cardano-ledger-test/test/Tests.hs | 2 - 3 files changed, 633 deletions(-) delete mode 100644 libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs diff --git a/libs/cardano-ledger-test/cardano-ledger-test.cabal b/libs/cardano-ledger-test/cardano-ledger-test.cabal index e77a53df1b3..e9f0f9c376d 100644 --- a/libs/cardano-ledger-test/cardano-ledger-test.cabal +++ b/libs/cardano-ledger-test/cardano-ledger-test.cabal @@ -43,7 +43,6 @@ library Test.Cardano.Ledger.Constrained.Conway.Utxo Test.Cardano.Ledger.Constrained.Conway.WitnessUniverse Test.Cardano.Ledger.Examples.AlonzoAPI - Test.Cardano.Ledger.Examples.AlonzoBBODY Test.Cardano.Ledger.Examples.AlonzoCollectInputs Test.Cardano.Ledger.Examples.STSTestUtils Test.Cardano.Ledger.Generic.AggPropTests diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs deleted file mode 100644 index 2e0918ade1f..00000000000 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs +++ /dev/null @@ -1,630 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Test.Cardano.Ledger.Examples.AlonzoBBODY (tests) where - -import Cardano.Ledger.Address (RewardAccount (..)) -import Cardano.Ledger.Allegra.Scripts (pattern RequireTimeStart) -import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusTxInfo) -import Cardano.Ledger.Alonzo.Scripts (ExUnits (..)) -import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), hashDataTxWitsL) -import Cardano.Ledger.BHeaderView (BHeaderView (..)) -import Cardano.Ledger.BaseTypes ( - BlocksMade (..), - Network (..), - ShelleyBase, - StrictMaybe (..), - natVersion, - textToUrl, - ) -import Cardano.Ledger.Block (Block (..)) -import Cardano.Ledger.Coin (Coin (..), CompactForm (..)) -import Cardano.Ledger.Compactible (fromCompact) -import Cardano.Ledger.Conway.Core -import Cardano.Ledger.Credential (Credential (..), Ptr (..)) -import Cardano.Ledger.Keys (coerceKeyRole) -import Cardano.Ledger.Mary.Value (AssetName (..), MaryValue (..), MultiAsset (..), PolicyID (..)) -import Cardano.Ledger.Plutus.Data (Data (..), hashData) -import Cardano.Ledger.Plutus.Language (Language (..)) -import Cardano.Ledger.Shelley.API ( - GenDelegs (..), - LedgerState (..), - ProtVer (..), - ) -import Cardano.Ledger.Shelley.LedgerState (smartUTxOState) -import Cardano.Ledger.Shelley.Rules ( - BbodyEnv (..), - ShelleyBbodyState (..), - ShelleyPoolPredFailure (..), - ) -import Cardano.Ledger.Shelley.Scripts ( - ShelleyEraScript, - pattern RequireAllOf, - pattern RequireSignature, - ) -import Cardano.Ledger.State -import Cardano.Ledger.TxIn (TxIn (..)) -import Cardano.Ledger.Val (inject, (<->)) -import Cardano.Protocol.Crypto (hashVerKeyVRF) -import Cardano.Slotting.Slot (SlotNo (..)) -import Control.State.Transition.Extended (STS (..), TRC (..)) -import qualified Data.ByteString as BS (replicate) -import Data.Default (Default (..)) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust) -import qualified Data.Sequence.Strict as SSeq -import qualified Data.Sequence.Strict as StrictSeq -import qualified Data.Set as Set -import Lens.Micro ((&), (.~)) -import qualified PlutusLedgerApi.V1 as PV1 -import Test.Cardano.Ledger.Common -import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkAddr, mkWitnessVKey) -import Test.Cardano.Ledger.Era (registerTestAccount) -import Test.Cardano.Ledger.Examples.STSTestUtils ( - EraModel (..), - alwaysFailsHash, - alwaysSucceedsHash, - genericCont, - initUTxO, - mkGenesisTxIn, - mkSingleRedeemer, - mkTxDats, - someAddr, - someKeys, - someScriptAddr, - ) -import Test.Cardano.Ledger.Generic.Indexed (theKeyHash) -import Test.Cardano.Ledger.Generic.Instances () -import Test.Cardano.Ledger.Generic.Proof -import Test.Cardano.Ledger.Plutus (zeroTestingCostModels) -import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto) -import Test.Cardano.Ledger.Shelley.Utils ( - RawSeed (..), - mkKeyPair, - mkKeyPair', - mkVRFKeyPair, - ) -import Test.Cardano.Protocol.TPraos.Create (VRFKeyPair (..)) - -forge :: forall era. EraScript era => Integer -> Script era -> MultiAsset -forge n s = MultiAsset $ Map.singleton pid (Map.singleton an n) - where - pid = PolicyID (hashScript @era s) - an = AssetName "an" - -tests :: Spec -tests = - describe "Generic Tests, testing Alonzo PredicateFailures, in postAlonzo eras" $ do - alonzoBBODYexamplesP Alonzo - alonzoBBODYexamplesP Babbage - alonzoBBODYexamplesP Conway - -alonzoBBODYexamplesP :: - forall 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 - , InjectRuleFailure "BBODY" ShelleyPoolPredFailure era - , STS (EraRule "BBODY" era) - , State (EraRule "LEDGERS" era) ~ LedgerState era - , ShelleyEraTxCert era - , AlonzoEraTx era - , Value era ~ MaryValue - , ToExpr (PredicateFailure (EraRule "BBODY" era)) - , EraModel era - , EraPlutusTxInfo PlutusV1 era - ) => - Proof era -> - Spec -alonzoBBODYexamplesP proof = - describe (show proof ++ " BBODY examples") $ do - it "eight plutus scripts cases" $ - runSTS @"BBODY" @era - (TRC (BbodyEnv @era defaultPParams def, initialBBodyState @era initUTxO, testAlonzoBlock @era)) - (genericCont "" $ Right testBBodyState) - it "block with bad pool md hash in tx" $ - runSTS @"BBODY" @era - (TRC (BbodyEnv @era defaultPParams def, initialBBodyState initUTxO, testAlonzoBadPMDHBlock)) - (genericCont "" . Left . pure $ makeTooBig @era) - -initialBBodyState :: - forall era. - ( State (EraRule "LEDGERS" era) ~ LedgerState era - , AlonzoEraPParams era - , AlonzoEraScript era - , EraModel era - ) => - UTxO era -> - ShelleyBbodyState era -initialBBodyState utxo = - BbodyState (LedgerState initialUtxoSt dpstate) (BlocksMade mempty) - where - initialUtxoSt = - smartUTxOState defaultPParams utxo (fromCompact successDeposit) (Coin 0) def mempty - ptr = Just (Ptr minBound minBound minBound) - cred = scriptStakeCredSucceed @era - dpstate = - def - & certDStateL - .~ DState - { dsAccounts = - addToBalanceAccounts (Map.singleton cred (CompactCoin 1000)) $ - registerTestAccount cred ptr successDeposit Nothing Nothing def - , dsFutureGenDelegs = Map.empty - , dsGenDelegs = GenDelegs Map.empty - , dsIRewards = def - } - -testAlonzoBlock :: - ( Value era ~ MaryValue - , ShelleyEraTxCert era - , AlonzoEraTx era - , EraModel era - , EraPlutusTxInfo PlutusV1 era - ) => - Block BHeaderView era -testAlonzoBlock = - makeNaiveBlock - [ validatingTx & isValidTxL .~ IsValid True - , notValidatingTx & isValidTxL .~ IsValid False - , validatingTxWithWithdrawal & isValidTxL .~ IsValid True - , notValidatingTxWithWithdrawal & isValidTxL .~ IsValid False - , validatingTxWithCert & isValidTxL .~ IsValid True - , notValidatingTxWithCert & isValidTxL .~ IsValid False - , validatingTxWithMint & isValidTxL .~ IsValid True - , notValidatingTxWithMint & isValidTxL .~ IsValid False - ] - -testAlonzoBadPMDHBlock :: - ( AlonzoEraTx era - , EraModel era - ) => - Block BHeaderView era -testAlonzoBadPMDHBlock = makeNaiveBlock [poolMDHTooBigTx & isValidTxL .~ IsValid True] - --- ============================== DATA =============================== - -someDatum :: Era era => Data era -someDatum = Data (PV1.I 123) - -anotherDatum :: Era era => Data era -anotherDatum = Data (PV1.I 0) - -validatingTx :: - forall era. - ( AlonzoEraTxWits era - , AlonzoEraTxBody era - , EraModel era - ) => - Tx TopTx era -validatingTx = - mkBasicTx validatingBody - & witsTxL . addrTxWitsL .~ [mkWitnessVKey (hashAnnotated $ validatingBody @era) someKeys] - & witsTxL . hashScriptTxWitsL .~ [always 3] - & witsTxL . hashDataTxWitsL .~ [someDatum] - & witsTxL . rdmrsTxWitsL .~ validatingRedeemers - -validatingBody :: - forall era. - ( AlonzoEraTxBody era - , AlonzoEraScript era - , EraModel era - ) => - TxBody TopTx era -validatingBody = - mkBasicTxBody - & inputsTxBodyL .~ Set.singleton (mkGenesisTxIn 1) - & collateralInputsTxBodyL .~ Set.singleton (mkGenesisTxIn 11) - & outputsTxBodyL .~ SSeq.singleton validatingTxOut - & feeTxBodyL .~ Coin 5 - & scriptIntegrityHashTxBodyL - .~ newScriptIntegrityHash @era defaultPParams [PlutusV1] validatingRedeemers (mkTxDats someDatum) - -validatingRedeemers :: AlonzoEraScript era => Redeemers era -validatingRedeemers = mkSingleRedeemer (SpendingPurpose $ AsIx 0) (Data (PV1.I 42)) - -validatingTxOut :: EraTxOut era => TxOut era -validatingTxOut = mkBasicTxOut someAddr (inject $ Coin 4995) - -notValidatingTx :: - forall era. - ( AlonzoEraTxWits era - , AlonzoEraTxBody era - , EraModel era - ) => - Tx TopTx era -notValidatingTx = - mkBasicTx notValidatingBody - & witsTxL . addrTxWitsL .~ [mkWitnessVKey (hashAnnotated notValidatingBody) someKeys] - & witsTxL . hashScriptTxWitsL .~ [never 0] - & witsTxL . hashDataTxWitsL .~ [anotherDatum] - & witsTxL . rdmrsTxWitsL .~ notValidatingRedeemers - where - notValidatingBody = - mkBasicTxBody @era - & inputsTxBodyL .~ Set.singleton (mkGenesisTxIn 2) - & collateralInputsTxBodyL .~ Set.singleton (mkGenesisTxIn 12) - & outputsTxBodyL .~ SSeq.singleton (mkBasicTxOut someAddr (inject $ Coin 2995)) - & feeTxBodyL .~ Coin 5 - & scriptIntegrityHashTxBodyL - .~ newScriptIntegrityHash - defaultPParams - [PlutusV1] - notValidatingRedeemers - (mkTxDats anotherDatum) - notValidatingRedeemers = mkSingleRedeemer (SpendingPurpose $ AsIx 0) (Data (PV1.I 1)) - -validatingTxWithWithdrawal :: - forall era. - (AlonzoEraTxBody era, EraModel era, AlonzoEraTxWits era) => - Tx TopTx era -validatingTxWithWithdrawal = - mkBasicTx validatingBodyWithWithdrawal - & witsTxL . addrTxWitsL - .~ [mkWitnessVKey (hashAnnotated $ validatingBodyWithWithdrawal @era) someKeys] - & witsTxL . hashScriptTxWitsL .~ [always 2] - & witsTxL . rdmrsTxWitsL .~ validatingWithWithdrawalRedeemers - -validatingBodyWithWithdrawal :: - forall era. - ( AlonzoEraTxBody era - , AlonzoEraScript era - , EraModel era - ) => - TxBody TopTx era -validatingBodyWithWithdrawal = - mkBasicTxBody - & inputsTxBodyL .~ Set.singleton (mkGenesisTxIn 5) - & collateralInputsTxBodyL .~ Set.singleton (mkGenesisTxIn 15) - & outputsTxBodyL .~ SSeq.singleton validatingTxWithWithdrawalOut - & feeTxBodyL .~ Coin 5 - & withdrawalsTxBodyL - .~ Withdrawals (Map.singleton (RewardAccount Testnet (scriptStakeCredSucceed @era)) $ Coin 1000) - & scriptIntegrityHashTxBodyL - .~ newScriptIntegrityHash @era - defaultPParams - [PlutusV1] - validatingWithWithdrawalRedeemers - mempty - -validatingWithWithdrawalRedeemers :: AlonzoEraScript era => Redeemers era -validatingWithWithdrawalRedeemers = mkSingleRedeemer (RewardingPurpose $ AsIx 0) (Data (PV1.I 42)) - -validatingTxWithWithdrawalOut :: EraTxOut era => TxOut era -validatingTxWithWithdrawalOut = mkBasicTxOut someAddr . inject $ Coin 1995 - -notValidatingTxWithWithdrawal :: - forall era. - ( AlonzoEraTxWits era - , AlonzoEraTxBody era - , EraModel era - ) => - Tx TopTx era -notValidatingTxWithWithdrawal = - mkBasicTx notValidatingBodyWithWithdrawal - & witsTxL . addrTxWitsL .~ [mkWitnessVKey (hashAnnotated notValidatingBodyWithWithdrawal) someKeys] - & witsTxL . hashScriptTxWitsL .~ [never 1] - & witsTxL . rdmrsTxWitsL .~ notValidatingRedeemers - where - notValidatingBodyWithWithdrawal = - mkBasicTxBody - & inputsTxBodyL .~ Set.singleton (mkGenesisTxIn 6) - & collateralInputsTxBodyL .~ Set.singleton (mkGenesisTxIn 16) - & outputsTxBodyL .~ SSeq.singleton (mkBasicTxOut someAddr . inject $ Coin 1995) - & feeTxBodyL .~ Coin 5 - & withdrawalsTxBodyL - .~ Withdrawals (Map.singleton (RewardAccount Testnet $ scriptStakeCredFail @era) . inject $ Coin 1000) - & scriptIntegrityHashTxBodyL - .~ newScriptIntegrityHash defaultPParams [PlutusV1] notValidatingRedeemers mempty - notValidatingRedeemers = mkSingleRedeemer (RewardingPurpose $ AsIx 0) (Data (PV1.I 0)) - -validatingTxWithCert :: - forall era. - ( ShelleyEraTxCert era - , AlonzoEraTxWits era - , AlonzoEraTxBody era - , EraModel era - ) => - Tx TopTx era -validatingTxWithCert = - mkBasicTx validatingBodyWithCert - & witsTxL . addrTxWitsL .~ [mkWitnessVKey (hashAnnotated $ validatingBodyWithCert @era) someKeys] - & witsTxL . hashScriptTxWitsL .~ [always 2] - & witsTxL . rdmrsTxWitsL .~ validatingRedeemersWithCert - -validatingBodyWithCert :: - forall era. - ( ShelleyEraTxCert era - , AlonzoEraTxBody era - , AlonzoEraScript era - , EraModel era - ) => - TxBody TopTx era -validatingBodyWithCert = - mkBasicTxBody - & inputsTxBodyL .~ Set.singleton (mkGenesisTxIn 3) - & collateralInputsTxBodyL .~ Set.singleton (mkGenesisTxIn 13) - & outputsTxBodyL .~ SSeq.singleton validatingTxWithCertOut - & certsTxBodyL .~ SSeq.singleton (UnRegTxCert $ scriptStakeCredSucceed @era) - & feeTxBodyL .~ Coin 5 - & scriptIntegrityHashTxBodyL - .~ newScriptIntegrityHash @era defaultPParams [PlutusV1] validatingRedeemersWithCert mempty - -validatingRedeemersWithCert :: AlonzoEraScript era => Redeemers era -validatingRedeemersWithCert = mkSingleRedeemer (CertifyingPurpose $ AsIx 0) (Data (PV1.I 42)) - -validatingTxWithCertOut :: EraTxOut era => TxOut era -validatingTxWithCertOut = - mkBasicTxOut someAddr . inject $ Coin 995 <> fromCompact successDeposit - -notValidatingTxWithCert :: - forall era. - ( ShelleyEraTxCert era - , AlonzoEraTxWits era - , AlonzoEraTxBody era - , EraModel era - ) => - Tx TopTx era -notValidatingTxWithCert = - mkBasicTx notValidatingBodyWithCert - & witsTxL . addrTxWitsL .~ [mkWitnessVKey (hashAnnotated notValidatingBodyWithCert) someKeys] - & witsTxL . hashScriptTxWitsL .~ [never 1] - & witsTxL . rdmrsTxWitsL .~ notValidatingRedeemersWithCert - where - notValidatingBodyWithCert = - mkBasicTxBody - & inputsTxBodyL .~ Set.singleton (mkGenesisTxIn 4) - & collateralInputsTxBodyL .~ Set.singleton (mkGenesisTxIn 14) - & outputsTxBodyL .~ SSeq.singleton (mkBasicTxOut someAddr . inject $ Coin 995) - & certsTxBodyL .~ SSeq.singleton (UnRegTxCert $ scriptStakeCredFail @era) - & feeTxBodyL .~ Coin 5 - & scriptIntegrityHashTxBodyL - .~ newScriptIntegrityHash @era defaultPParams [PlutusV1] notValidatingRedeemersWithCert mempty - notValidatingRedeemersWithCert = mkSingleRedeemer (CertifyingPurpose $ AsIx 0) (Data (PV1.I 0)) - -validatingTxWithMint :: - forall era. - ( Value era ~ MaryValue - , AlonzoEraTxWits era - , AlonzoEraTxBody era - , EraModel era - , EraPlutusTxInfo PlutusV1 era - ) => - Tx TopTx era -validatingTxWithMint = - mkBasicTx validatingBodyWithMint - & witsTxL . addrTxWitsL .~ [mkWitnessVKey (hashAnnotated $ validatingBodyWithMint @era) someKeys] - & witsTxL . hashScriptTxWitsL .~ [always 2] - & witsTxL . rdmrsTxWitsL .~ validatingRedeemersWithMint - -validatingBodyWithMint :: - forall era. - ( Value era ~ MaryValue - , AlonzoEraTxBody era - , EraModel era - , EraPlutusTxInfo PlutusV1 era - ) => - TxBody TopTx era -validatingBodyWithMint = - mkBasicTxBody - & inputsTxBodyL .~ Set.singleton (mkGenesisTxIn 7) - & collateralInputsTxBodyL .~ Set.singleton (mkGenesisTxIn 17) - & outputsTxBodyL .~ SSeq.singleton validatingTxWithMintOut - & feeTxBodyL .~ Coin 5 - & mintTxBodyL .~ multiAsset @era - & scriptIntegrityHashTxBodyL - .~ newScriptIntegrityHash @era defaultPParams [PlutusV1] validatingRedeemersWithMint mempty - -validatingRedeemersWithMint :: AlonzoEraScript era => Redeemers era -validatingRedeemersWithMint = mkSingleRedeemer (MintingPurpose $ AsIx 0) (Data (PV1.I 42)) - -multiAsset :: forall era. EraModel era => MultiAsset -multiAsset = forge @era 1 $ always 2 - -validatingTxWithMintOut :: - forall era. - ( Value era ~ MaryValue - , EraModel era - ) => - TxOut era -validatingTxWithMintOut = - mkBasicTxOut someAddr . MaryValue (Coin 995) $ multiAsset @era - -notValidatingTxWithMint :: - forall era. - ( Value era ~ MaryValue - , AlonzoEraTxWits era - , AlonzoEraTxBody era - , EraModel era - ) => - Tx TopTx era -notValidatingTxWithMint = - mkBasicTx notValidatingBodyWithMint - & witsTxL . addrTxWitsL .~ [mkWitnessVKey (hashAnnotated notValidatingBodyWithMint) someKeys] - & witsTxL . hashScriptTxWitsL .~ [never 1] - & witsTxL . rdmrsTxWitsL .~ notValidatingRedeemersWithMint - where - notValidatingBodyWithMint = - mkBasicTxBody - & inputsTxBodyL .~ Set.singleton (mkGenesisTxIn 8) - & collateralInputsTxBodyL .~ Set.singleton (mkGenesisTxIn 18) - & outputsTxBodyL - .~ [mkBasicTxOut someAddr $ MaryValue (Coin 995) ma] - & feeTxBodyL .~ Coin 5 - & mintTxBodyL .~ ma - & scriptIntegrityHashTxBodyL - .~ newScriptIntegrityHash defaultPParams [PlutusV1] notValidatingRedeemersWithMint mempty - notValidatingRedeemersWithMint = mkSingleRedeemer @era (MintingPurpose $ AsIx 0) (Data (PV1.I 0)) - ma = forge @era 1 (never 1) - -poolMDHTooBigTx :: - forall era. - (ShelleyEraScript era, EraModel era) => - Tx TopTx era -poolMDHTooBigTx = - -- Note that the UTXOW rule will no trigger the expected predicate failure, - -- since it is checked in the POOL rule. BBODY will trigger it, however. - mkBasicTx poolMDHTooBigTxBody - & witsTxL . addrTxWitsL .~ [mkWitnessVKey (hashAnnotated poolMDHTooBigTxBody) someKeys] - where - poolMDHTooBigTxBody = - mkBasicTxBody - & inputsTxBodyL .~ [mkGenesisTxIn 3] - & outputsTxBodyL .~ [mkBasicTxOut someAddr . inject $ Coin 995 <-> poolDeposit] - & certsTxBodyL .~ [RegPoolTxCert stakePoolParams] - & feeTxBodyL .~ Coin 5 - where - tooManyBytes = BS.replicate (standardHashSize + 1) 0 - stakePoolParams = - StakePoolParams - { sppId = coerceKeyRole . hashKey $ vKey someKeys - , sppVrf = - hashVerKeyVRF @MockCrypto . vrfVerKey @MockCrypto . mkVRFKeyPair @MockCrypto $ - RawSeed 0 0 0 0 0 - , sppPledge = Coin 0 - , sppCost = Coin 0 - , sppMargin = minBound - , sppRewardAccount = RewardAccount Testnet $ scriptStakeCredSucceed @era - , sppOwners = mempty - , sppRelays = mempty - , sppMetadata = SJust $ PoolMetadata (fromJust $ textToUrl 64 "") tooManyBytes - } - --- ============================== Expected UTXO =============================== - -testBBodyState :: - forall era. - ( Value era ~ MaryValue - , State (EraRule "LEDGERS" era) ~ LedgerState era - , ShelleyEraTxCert era - , AlonzoEraTxBody era - , EraModel era - , EraPlutusTxInfo PlutusV1 era - ) => - ShelleyBbodyState era -testBBodyState = - let utxo = - UTxO $ - Map.fromList - [ (TxIn (txIdTxBody @era validatingBody) minBound, validatingTxOut) - , (TxIn (txIdTxBody @era validatingBodyWithCert) minBound, validatingTxWithCertOut) - , (TxIn (txIdTxBody @era validatingBodyWithWithdrawal) minBound, validatingTxWithWithdrawalOut) - , (TxIn (txIdTxBody @era validatingBodyWithMint) minBound, validatingTxWithMintOut) - , (mkGenesisTxIn 11, mkBasicTxOut someAddr $ inject $ Coin 5) - , (mkGenesisTxIn 2, alwaysFailsOutput) - , (mkGenesisTxIn 13, mkBasicTxOut someAddr . inject $ Coin 5) - , (mkGenesisTxIn 4, mkBasicTxOut someAddr . inject $ Coin 1000) - , (mkGenesisTxIn 15, mkBasicTxOut someAddr . inject $ Coin 5) - , (mkGenesisTxIn 6, mkBasicTxOut someAddr . inject $ Coin 1000) - , (mkGenesisTxIn 17, mkBasicTxOut someAddr . inject $ Coin 5) - , (mkGenesisTxIn 8, mkBasicTxOut someAddr . inject $ Coin 1000) - , (mkGenesisTxIn 100, timelockOut) - , (mkGenesisTxIn 101, unspendableOut) - , (mkGenesisTxIn 102, alwaysSucceedsOutputV1) - , (mkGenesisTxIn 103, nonScriptOutWithDatum) - ] - alwaysFailsOutput = - mkBasicTxOut - (someScriptAddr $ never @era 0) - (inject $ Coin 3000) - & dataHashTxOutL .~ SJust (hashData $ anotherDatum @era) - timelockOut = mkBasicTxOut timelockAddr . inject $ Coin 1 - timelockAddr = mkAddr timelockHash $ mkKeyPair' @Staking (RawSeed 0 0 0 0 2) - where - timelockHash = - hashScript . fromNativeScript @era $ - RequireAllOf [RequireSignature $ theKeyHash 1, RequireTimeStart 100] - -- This output is unspendable since it is locked by a plutus script, - -- but has no datum hash. - unspendableOut = - mkBasicTxOut - (someScriptAddr $ always @era 3) - (inject $ Coin 5000) - alwaysSucceedsOutputV1 = - mkBasicTxOut - (someScriptAddr $ always @era 3) - (inject $ Coin 5000) - & dataHashTxOutL .~ SJust (hashData $ someDatum @era) - nonScriptOutWithDatum = - mkBasicTxOut someAddr (inject $ Coin 1221) - & dataHashTxOutL .~ SJust (hashData $ someDatum @era) - poolID = hashKey . vKey . coerceKeyRole $ coldKeys - example1UtxoSt = - smartUTxOState defaultPParams utxo totalDeposits (Coin 40) def mempty - -- the default CertState 'def' means that the 'totalDeposits' must be 0 - totalDeposits = Coin 0 - in BbodyState - (LedgerState example1UtxoSt def) - (BlocksMade $ Map.singleton poolID 1) - --- ============================== Helper functions =============================== - -makeTooBig :: - forall era. - InjectRuleFailure "BBODY" ShelleyPoolPredFailure era => - PredicateFailure (EraRule "BBODY" era) -makeTooBig = - injectFailure @"BBODY" @_ @era $ - PoolMedataHashTooBig (coerceKeyRole . hashKey $ vKey someKeys) (standardHashSize + 1) - -coldKeys :: KeyPair BlockIssuer -coldKeys = KeyPair vk sk - where - (sk, vk) = mkKeyPair (RawSeed 1 2 3 2 1) - -makeNaiveBlock :: - forall era. EraBlockBody era => [Tx TopTx era] -> Block BHeaderView era -makeNaiveBlock txs = Block {blockHeader = bhView, blockBody} - where - bhView = - BHeaderView - { bhviewID = hashKey (vKey coldKeys) - , bhviewBSize = fromIntegral $ bBodySize (ProtVer (eraProtVerLow @era) 0) blockBody - , bhviewHSize = 0 - , bhviewBHash = hashBlockBody blockBody - , bhviewSlot = SlotNo 0 - } - blockBody = mkBasicBlockBody & txSeqBlockBodyL .~ StrictSeq.fromList txs - -scriptStakeCredFail :: forall era. (ShelleyEraScript era, EraModel era) => Credential Staking -scriptStakeCredFail = ScriptHashObj (alwaysFailsHash @era 1) - -scriptStakeCredSucceed :: forall era. (ShelleyEraScript era, EraModel era) => Credential Staking -scriptStakeCredSucceed = ScriptHashObj (alwaysSucceedsHash @era 2) - --- | The deposit made when 'scriptStakeCredSucceed' was registered. It is also --- The Refund when 'scriptStakeCredSucceed' is de-registered. -successDeposit :: CompactForm Coin -successDeposit = CompactCoin 7 - --- ============================== PParams =============================== - -poolDeposit :: Coin -poolDeposit = Coin 5 - -defaultPParams :: AlonzoEraPParams era => PParams era -defaultPParams = - emptyPParams - & ppCostModelsL .~ zeroTestingCostModels [PlutusV1] - & ppMaxValSizeL .~ 1000000000 - & ppMaxTxExUnitsL .~ ExUnits 1000000 1000000 - & ppMaxBlockExUnitsL .~ ExUnits 1000000 1000000 - & ppProtocolVersionL .~ ProtVer (natVersion @5) 0 - & ppCollateralPercentageL .~ 100 - & ppKeyDepositL .~ Coin 2 - & ppPoolDepositL .~ poolDeposit diff --git a/libs/cardano-ledger-test/test/Tests.hs b/libs/cardano-ledger-test/test/Tests.hs index a36d385ba2c..26816ad8eab 100644 --- a/libs/cardano-ledger-test/test/Tests.hs +++ b/libs/cardano-ledger-test/test/Tests.hs @@ -11,7 +11,6 @@ import Test.Cardano.Ledger.Common import qualified Test.Cardano.Ledger.Constrained.Conway.LedgerTypes.Tests as LedgerTypes import qualified Test.Cardano.Ledger.Constrained.Conway.MiniTrace as MiniTrace import qualified Test.Cardano.Ledger.Examples.AlonzoAPI as AlonzoAPI (tests) -import qualified Test.Cardano.Ledger.Examples.AlonzoBBODY as AlonzoBBODY (tests) import qualified Test.Cardano.Ledger.Examples.AlonzoCollectInputs as AlonzoCollectInputs (tests) import Test.Cardano.Ledger.Generic.AggPropTests (aggTests, depositTests) import Test.Cardano.Ledger.Generic.GenState (defaultGenSize) @@ -37,7 +36,6 @@ defaultTests = do depositTests calcPoolDistOldEqualsNew describe "STS Tests" $ do - AlonzoBBODY.tests AlonzoAPI.tests AlonzoCollectInputs.tests genericProperties defaultGenSize From 22770d9542abeb5794eb4dfb0c9cee908b20f8d2 Mon Sep 17 00:00:00 2001 From: Neil Mayhew Date: Mon, 8 Dec 2025 17:40:33 -0700 Subject: [PATCH 9/9] Add a new BBODY Imp test for Alonzo --- .../Cardano/Ledger/Alonzo/Imp/BbodySpec.hs | 34 +++++++++++++++++++ .../Test/Cardano/Ledger/Alonzo/ImpTest.hs | 2 ++ 2 files changed, 36 insertions(+) diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/BbodySpec.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/BbodySpec.hs index f784ed37a0c..6d284548fa6 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/BbodySpec.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/BbodySpec.hs @@ -9,15 +9,18 @@ module Test.Cardano.Ledger.Alonzo.Imp.BbodySpec (spec) where import Cardano.Ledger.Alonzo.Core +import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyPredFailure (TooManyExUnits)) import Cardano.Ledger.Alonzo.Scripts (eraLanguages) import Cardano.Ledger.Alonzo.TxWits (unRedeemersL) import Cardano.Ledger.BaseTypes ( + Mismatch (..), StrictMaybe (..), textToUrl, ) import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.Plutus ( Data (..), + ExUnits (..), hashPlutusScript, withSLanguage, ) @@ -27,6 +30,7 @@ import Cardano.Ledger.State (PoolMetadata (..), sppMetadataL) import Control.Monad.Reader (asks) import Control.Monad.State.Strict (get) import qualified Data.ByteString as BS +import Data.Foldable (for_) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) import Lens.Micro @@ -92,6 +96,36 @@ spec = describe "BBODY" $ do & bodyTxL . certsTxBodyL .~ [txCert] & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert cPurpose (dex 0) + it "enforces ppMaxBlockExUnits" $ do + maxBlockUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxBlockExUnitsL + maxTxUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL + + let + ExUnits bMem bSteps = maxBlockUnits + ExUnits tMem tSteps = maxTxUnits + txCount = 1 + max (bMem `div` tMem) (bSteps `div` tSteps) + mismatch = + Mismatch + { mismatchExpected = maxBlockUnits + , mismatchSupplied = ExUnits (txCount * tMem) (txCount * tSteps) + } + + txIns <- replicateM (fromIntegral txCount) $ produceScript alwaysSucceedsWithDatumHash + + let + purpose = mkSpendingPurpose (AsIx 0) + dex = (Data (P.I 0), maxTxUnits) + buildTxs = + for_ txIns $ \txIn -> + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL . inputsTxBodyL .~ [txIn] + & witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert purpose dex + + withTxsInFailingBlock + buildTxs + [injectFailure $ TooManyExUnits mismatch] + it "fails with bad pool MD hash in Tx" $ do let hashSize = standardHashSize + 1 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 5976ee3c491..d6fb7dcc2d3 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs @@ -55,6 +55,7 @@ import Cardano.Ledger.Alonzo.Plutus.Evaluate ( evalTxExUnits, ) import Cardano.Ledger.Alonzo.Rules ( + AlonzoBbodyPredFailure, AlonzoUtxoPredFailure, AlonzoUtxosPredFailure (..), AlonzoUtxowPredFailure, @@ -127,6 +128,7 @@ class , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era , InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era + , InjectRuleFailure "BBODY" AlonzoBbodyPredFailure era ) => AlonzoEraImp era where