Skip to content

Commit 7aaa7e1

Browse files
neilmayhewneilmayhew
authored
Merge pull request #5392 from IntersectMBO/nm/4182-AlonzoBBODY-tests
Translate all tests from `AlonzoBBODY` to Imp test
2 parents a158253 + 78f3f09 commit 7aaa7e1

File tree

9 files changed

+144
-660
lines changed

9 files changed

+144
-660
lines changed

‎eras/alonzo/impl/cardano-ledger-alonzo.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -159,6 +159,7 @@ library testlib
159159
Test.Cardano.Ledger.Alonzo.Era
160160
Test.Cardano.Ledger.Alonzo.Examples
161161
Test.Cardano.Ledger.Alonzo.Imp
162+
Test.Cardano.Ledger.Alonzo.Imp.BbodySpec
162163
Test.Cardano.Ledger.Alonzo.Imp.UtxoSpec
163164
Test.Cardano.Ledger.Alonzo.Imp.UtxosSpec
164165
Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec

‎eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ module Test.Cardano.Ledger.Alonzo.Imp where
1010

1111
import Cardano.Ledger.Alonzo (AlonzoEra)
1212
import Cardano.Ledger.Shelley.Core (ShelleyEraTxCert)
13+
import qualified Test.Cardano.Ledger.Alonzo.Imp.BbodySpec as Bbody
1314
import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxoSpec as Utxo
1415
import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxosSpec as Utxos
1516
import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec as Utxow
@@ -27,6 +28,7 @@ spec ::
2728
spec = do
2829
MaryImp.spec @era
2930
describe "AlonzoImpSpec" . withEachEraVersion @era $ do
31+
Bbody.spec
3032
Utxo.spec
3133
Utxos.spec
3234
Utxow.spec

‎eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/BbodySpec.hs‎

Lines changed: 117 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,117 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE OverloadedLists #-}
4+
{-# LANGUAGE OverloadedStrings #-}
5+
{-# LANGUAGE ScopedTypeVariables #-}
6+
{-# LANGUAGE TypeApplications #-}
7+
{-# LANGUAGE TypeFamilies #-}
8+
9+
module Test.Cardano.Ledger.Alonzo.Imp.BbodySpec (spec) where
10+
11+
import Cardano.Ledger.Alonzo.Core
12+
import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyPredFailure (TooManyExUnits))
13+
import Cardano.Ledger.Alonzo.Scripts (eraLanguages)
14+
import Cardano.Ledger.Alonzo.TxWits (unRedeemersL)
15+
import Cardano.Ledger.BaseTypes (Mismatch (..))
16+
import Cardano.Ledger.Credential (Credential (..))
17+
import Cardano.Ledger.Plutus (
18+
Data (..),
19+
ExUnits (..),
20+
hashPlutusScript,
21+
withSLanguage,
22+
)
23+
import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL, nesEsL)
24+
import Data.Foldable (for_)
25+
import qualified Data.Map.Strict as Map
26+
import Lens.Micro
27+
import qualified PlutusLedgerApi.Common as P
28+
import Test.Cardano.Ledger.Alonzo.ImpTest
29+
import Test.Cardano.Ledger.Imp.Common
30+
import Test.Cardano.Ledger.Plutus.Examples
31+
32+
spec :: forall era. AlonzoEraImp era => SpecWith (ImpInit (LedgerSpec era))
33+
spec = describe "BBODY" $ do
34+
forM_ (eraLanguages @era) $ \lang ->
35+
withSLanguage lang $ \slang ->
36+
describe (show lang) $ do
37+
let
38+
alwaysSucceedsWithDatumHash = hashPlutusScript $ alwaysSucceedsWithDatum slang :: ScriptHash
39+
alwaysFailsWithDatumHash = hashPlutusScript $ alwaysFailsWithDatum slang :: ScriptHash
40+
alwaysSucceedsNoDatumHash = hashPlutusScript $ alwaysSucceedsNoDatum slang :: ScriptHash
41+
alwaysFailsNoDatumHash = hashPlutusScript $ alwaysFailsNoDatum slang :: ScriptHash
42+
evenRedeemerNoDatumHash = hashPlutusScript $ evenRedeemerNoDatum slang :: ScriptHash
43+
44+
it "succeeds with eight Plutus scripts" $ do
45+
rewardAccount <- registerStakeCredential $ ScriptHashObj evenRedeemerNoDatumHash
46+
txCert <- genUnRegTxCert $ ScriptHashObj evenRedeemerNoDatumHash
47+
48+
withTxsInBlock_ $ do
49+
impAnn "notValidatingTx" $ do
50+
txIn <- produceScript alwaysFailsWithDatumHash
51+
submitPhase2Invalid_ $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn]
52+
impAnn "validatingTx" $ do
53+
txIn <- produceScript alwaysSucceedsWithDatumHash
54+
submitTx_ $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn]
55+
56+
impAnn "notValidatingTxWithMint" $ do
57+
submitPhase2Invalid_ =<< mkTokenMintingTx alwaysFailsNoDatumHash
58+
impAnn "validatingTxWithMint" $ do
59+
submitTx_ =<< mkTokenMintingTx alwaysSucceedsNoDatumHash
60+
61+
maxExUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL
62+
63+
let dex i = (Data $ P.I i, maxExUnits)
64+
rPurpose = mkRewardingPurpose (AsIx 0)
65+
cPurpose = mkCertifyingPurpose (AsIx 0)
66+
67+
impAnn "notValidatingTxWithWithdrawal" $ do
68+
submitPhase2Invalid_ $
69+
mkBasicTx mkBasicTxBody
70+
& bodyTxL . withdrawalsTxBodyL .~ Withdrawals [(rewardAccount, mempty)]
71+
& witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert rPurpose (dex 1)
72+
impAnn "validatingTxWithWithdrawal" $ do
73+
submitTx_ $
74+
mkBasicTx mkBasicTxBody
75+
& bodyTxL . withdrawalsTxBodyL .~ Withdrawals [(rewardAccount, mempty)]
76+
& witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert rPurpose (dex 0)
77+
78+
impAnn "notValidatingTxWithCert" $ do
79+
submitPhase2Invalid_ $
80+
mkBasicTx mkBasicTxBody
81+
& bodyTxL . certsTxBodyL .~ [txCert]
82+
& witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert cPurpose (dex 1)
83+
impAnn "validatingTxWithCert" $ do
84+
submitTx_ $
85+
mkBasicTx mkBasicTxBody
86+
& bodyTxL . certsTxBodyL .~ [txCert]
87+
& witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert cPurpose (dex 0)
88+
89+
it "enforces ppMaxBlockExUnits" $ do
90+
maxBlockUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxBlockExUnitsL
91+
maxTxUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL
92+
93+
let
94+
ExUnits bMem bSteps = maxBlockUnits
95+
ExUnits tMem tSteps = maxTxUnits
96+
txCount = 1 + max (bMem `div` tMem) (bSteps `div` tSteps)
97+
mismatch =
98+
Mismatch
99+
{ mismatchExpected = maxBlockUnits
100+
, mismatchSupplied = ExUnits (txCount * tMem) (txCount * tSteps)
101+
}
102+
103+
txIns <- replicateM (fromIntegral txCount) $ produceScript alwaysSucceedsWithDatumHash
104+
105+
let
106+
purpose = mkSpendingPurpose (AsIx 0)
107+
dex = (Data (P.I 0), maxTxUnits)
108+
buildTxs =
109+
for_ txIns $ \txIn ->
110+
submitTx_ $
111+
mkBasicTx mkBasicTxBody
112+
& bodyTxL . inputsTxBodyL .~ [txIn]
113+
& witsTxL . rdmrsTxWitsL . unRedeemersL %~ Map.insert purpose dex
114+
115+
withTxsInFailingBlock
116+
buildTxs
117+
[injectFailure $ TooManyExUnits mismatch]

‎eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -55,6 +55,7 @@ import Cardano.Ledger.Alonzo.Plutus.Evaluate (
5555
evalTxExUnits,
5656
)
5757
import Cardano.Ledger.Alonzo.Rules (
58+
AlonzoBbodyPredFailure,
5859
AlonzoUtxoPredFailure,
5960
AlonzoUtxosPredFailure (..),
6061
AlonzoUtxowPredFailure,
@@ -128,6 +129,7 @@ class
128129
, InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
129130
, InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era
130131
, InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era
132+
, InjectRuleFailure "BBODY" AlonzoBbodyPredFailure era
131133
) =>
132134
AlonzoEraImp era
133135
where
@@ -427,8 +429,8 @@ instance ShelleyEraImp AlonzoEra where
427429
}
428430
, agMaxBlockExUnits =
429431
ExUnits
430-
{ exUnitsMem = 50_000_000
431-
, exUnitsSteps = 40_000_000_000
432+
{ exUnitsMem = 200_000_000
433+
, exUnitsSteps = 200_000_000_000
432434
}
433435
, agMaxValSize = 5000
434436
, agCollateralPercentage = 150

‎eras/shelley/impl/CHANGELOG.md‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -76,7 +76,7 @@
7676
- `BHeaderView`
7777
- `Block`
7878
* Add a `Generic` instance for `BHeaderView`
79-
* Add `impEventsFrom`, `impTransactionsFrom`
79+
* Add `impEventsFrom`, `impRecordSubmittedTxs`
8080
* Change type of `ImpTestState.impEvents` field from `[]` to `Seq`
8181
* Remove `huddle-cddl` and the `CDDL` modules.
8282
* Add `ToCBOR (StashedAVVMAddresses era)` superclass to `ShelleyEraTest`

‎eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs‎

Lines changed: 19 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -161,8 +161,7 @@ module Test.Cardano.Ledger.Shelley.ImpTest (
161161
withPostFixup,
162162
withPreFixup,
163163
impEventsFrom,
164-
impTransactionsFrom,
165-
impWithoutRecordingTxs,
164+
impRecordSubmittedTxs,
166165
impNESL,
167166
impGlobalsL,
168167
impCurSlotNoG,
@@ -366,7 +365,7 @@ data ImpTestState era = ImpTestState
366365
, impCurSlotNo :: !SlotNo
367366
, impGlobals :: !Globals
368367
, impEvents :: Seq (SomeSTSEvent era)
369-
, impRecordedTransactions :: !(StrictMaybe (StrictSeq (Tx TopTx era)))
368+
, impRecordedTxs :: !(StrictMaybe (StrictSeq (Tx TopTx era)))
370369
-- ^ When this is set to `SNothing` transactions are not being recorded.
371370
-- This should never be switched to `Just` outside of simulations.
372371
}
@@ -434,8 +433,8 @@ impNativeScriptsG = impNativeScriptsL
434433
impEventsL :: Lens' (ImpTestState era) (Seq (SomeSTSEvent era))
435434
impEventsL = lens impEvents (\x y -> x {impEvents = y})
436435

437-
impRecordedTransactionsL :: Lens' (ImpTestState era) (StrictMaybe (StrictSeq (Tx TopTx era)))
438-
impRecordedTransactionsL = lens impRecordedTransactions (\x y -> x {impRecordedTransactions = y})
436+
impRecordedTxsL :: Lens' (ImpTestState era) (StrictMaybe (StrictSeq (Tx TopTx era)))
437+
impRecordedTxsL = lens impRecordedTxs (\x y -> x {impRecordedTxs = y})
439438

440439
class
441440
( ShelleyEraTest era
@@ -682,7 +681,7 @@ defaultInitImpTestState nes = do
682681
, impCurSlotNo = slotNo
683682
, impGlobals = globals
684683
, impEvents = mempty
685-
, impRecordedTransactions = mempty
684+
, impRecordedTxs = mempty
686685
}
687686

688687
withEachEraVersion ::
@@ -954,25 +953,23 @@ impEventsFrom ::
954953
ImpTestM era [SomeSTSEvent era]
955954
impEventsFrom = fmap (toList . snd) . listen
956955

957-
impTransactionsFrom ::
956+
-- | Returns fixed up versions of all transactions that have been submitted by the supplied action.
957+
-- Will result in a runtime exception if invoked again anywhere within the supplied action.
958+
impRecordSubmittedTxs ::
959+
ShelleyEraImp era =>
958960
ImpTestM era () ->
959961
ImpTestM era (StrictSeq (Tx TopTx era))
960-
impTransactionsFrom act = do
961-
mTxsPrev <- use impRecordedTransactionsL
962-
impRecordedTransactionsL .= SJust mempty
962+
impRecordSubmittedTxs act = do
963+
mTxsPrev <- use impRecordedTxsL
964+
forM_ mTxsPrev $ \txsPrev -> do
965+
logToExpr txsPrev
966+
assertFailure "Detected a recursive attempt to record transactions"
967+
impRecordedTxsL .= SJust mempty
963968
act
964-
mTxsDuring <- use impRecordedTransactionsL
965-
impRecordedTransactionsL .= liftA2 (<>) mTxsPrev mTxsDuring
969+
mTxsDuring <- use impRecordedTxsL
970+
impRecordedTxsL .= mTxsPrev
966971
pure $ fold mTxsDuring
967972

968-
impWithoutRecordingTxs :: ImpTestM era a -> ImpTestM era a
969-
impWithoutRecordingTxs act = do
970-
prev <- use impRecordedTransactionsL
971-
impRecordedTransactionsL .= SNothing
972-
res <- act
973-
impRecordedTransactionsL .= prev
974-
pure res
975-
976973
runShelleyBase :: ShelleyBase a -> ImpTestM era a
977974
runShelleyBase act = do
978975
globals <- use impGlobalsL
@@ -1271,7 +1268,7 @@ trySubmitTx tx = do
12711268
impNESL . nesEsL . esLStateL .= newState
12721269
tell . Seq.fromList $ SomeSTSEvent @era @"LEDGER" <$> events
12731270

1274-
modify' $ impRecordedTransactionsL %~ fmap (SSeq.|> txFixed)
1271+
modify' $ impRecordedTxsL %~ fmap (SSeq.|> txFixed)
12751272

12761273
ImpTestState {impRootTxIn} <- get
12771274
UTxO utxo <- getUTxO
@@ -1425,7 +1422,7 @@ withTxsInBlockEither ::
14251422
)
14261423
withTxsInBlockEither act = do
14271424
stateBefore <- get
1428-
txs <- impTransactionsFrom act
1425+
txs <- impRecordSubmittedTxs act
14291426
stateAfter <- get
14301427
put stateBefore
14311428
tryTxsInBlock txs stateAfter

‎libs/cardano-ledger-test/cardano-ledger-test.cabal‎

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -43,7 +43,6 @@ library
4343
Test.Cardano.Ledger.Constrained.Conway.Utxo
4444
Test.Cardano.Ledger.Constrained.Conway.WitnessUniverse
4545
Test.Cardano.Ledger.Examples.AlonzoAPI
46-
Test.Cardano.Ledger.Examples.AlonzoBBODY
4746
Test.Cardano.Ledger.Examples.AlonzoCollectInputs
4847
Test.Cardano.Ledger.Examples.STSTestUtils
4948
Test.Cardano.Ledger.Generic.AggPropTests
@@ -95,7 +94,6 @@ library
9594
cardano-ledger-mary,
9695
cardano-ledger-shelley:{cardano-ledger-shelley, testlib},
9796
cardano-ledger-shelley-test,
98-
cardano-protocol-tpraos:{cardano-protocol-tpraos, testlib},
9997
cardano-slotting:{cardano-slotting, testlib},
10098
cardano-strict-containers,
10199
constrained-generators,

0 commit comments

Comments
 (0)