Skip to content

Commit da31832

Browse files
neilmayhewneilmayhew
committed
Add expectTxSuccess to ShelleyEraImp and use it in trySubmitTx 
1 parent 4b973eb commit da31832

File tree

7 files changed

+80
-28
lines changed
  • eras
    • allegra/impl/testlib/Test/Cardano/Ledger/Allegra
    • alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo
    • babbage/impl/testlib/Test/Cardano/Ledger/Babbage
    • conway/impl/testlib/Test/Cardano/Ledger/Conway
    • mary/impl/testlib/Test/Cardano/Ledger/Mary
    • shelley/impl/testlib/Test/Cardano/Ledger/Shelley

7 files changed

+80
-28
lines changed

‎eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ instance ShelleyEraImp AllegraEra where
3939
impSatisfyNativeScript = impAllegraSatisfyNativeScript
4040

4141
fixupTx = shelleyFixupTx
42+
expectTxSuccess = impShelleyExpectTxSuccess
4243

4344
impAllegraSatisfyNativeScript ::
4445
( AllegraEraScript era

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

Lines changed: 12 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -34,7 +34,6 @@ import Cardano.Ledger.Shelley.Scripts (
3434
pattern RequireAllOf,
3535
pattern RequireSignature,
3636
)
37-
import Control.Monad ((<=<))
3837
import GHC.Exts (fromList)
3938
import Lens.Micro ((%~), (&), (.~))
4039
import Lens.Micro.Mtl (use)
@@ -67,7 +66,7 @@ spec = describe "Valid transactions" $ do
6766
txIn <- txInAt (0 :: Int) <$> submitTx tx1
6867
let
6968
tx2 = mkBasicTx mkBasicTxBody & bodyTxL . inputsTxBodyL .~ [txIn]
70-
expectTxSuccess =<< submitTx tx2
69+
submitTx_ tx2
7170

7271
forM_ (eraLanguages @era) $ \lang ->
7372
withSLanguage lang $ \slang ->
@@ -80,20 +79,20 @@ spec = describe "Valid transactions" $ do
8079

8180
it "Validating SPEND script" $ do
8281
txIn <- produceScript alwaysSucceedsWithDatumHash
83-
expectTxSuccess <=< submitTx $
82+
submitTx_ $
8483
mkBasicTx $
8584
mkBasicTxBody & inputsTxBodyL .~ [txIn]
8685

8786
it "Not validating SPEND script" $ do
8887
txIn <- produceScript alwaysFailsWithDatumHash
89-
expectTxSuccess <=< submitPhase2Invalid $
88+
submitPhase2Invalid_ $
9089
mkBasicTx $
9190
mkBasicTxBody & inputsTxBodyL .~ [txIn]
9291

9392
it "Validating CERT script" $ do
9493
txIn <- produceScript alwaysSucceedsWithDatumHash
9594
let txCert = RegTxCert $ ScriptHashObj alwaysSucceedsNoDatumHash
96-
expectTxSuccess <=< submitTx $
95+
submitTx_ $
9796
mkBasicTx $
9897
mkBasicTxBody
9998
& inputsTxBodyL .~ [txIn]
@@ -102,29 +101,29 @@ spec = describe "Valid transactions" $ do
102101
it "Not validating CERT script" $ do
103102
txIn <- produceScript alwaysFailsWithDatumHash
104103
let txCert = RegTxCert $ ScriptHashObj alwaysSucceedsNoDatumHash
105-
expectTxSuccess <=< submitPhase2Invalid $
104+
submitPhase2Invalid_ $
106105
mkBasicTx $
107106
mkBasicTxBody
108107
& inputsTxBodyL .~ [txIn]
109108
& certsTxBodyL .~ [txCert]
110109

111110
it "Validating WITHDRAWAL script" $ do
112111
account <- registerStakeCredential $ ScriptHashObj alwaysSucceedsNoDatumHash
113-
expectTxSuccess <=< submitTx $
112+
submitTx_ $
114113
mkBasicTx $
115114
mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(account, mempty)]
116115

117116
it "Not validating WITHDRAWAL script" $ do
118117
account <- registerStakeCredential $ ScriptHashObj alwaysFailsNoDatumHash
119-
expectTxSuccess <=< submitPhase2Invalid $
118+
submitPhase2Invalid_ $
120119
mkBasicTx $
121120
mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(account, mempty)]
122121

123122
it "Validating MINT script" $ do
124-
expectTxSuccess <=< submitTx <=< mkTokenMintingTx $ alwaysSucceedsNoDatumHash
123+
submitTx_ =<< mkTokenMintingTx alwaysSucceedsNoDatumHash
125124

126125
it "Not validating MINT script" $ do
127-
expectTxSuccess <=< submitPhase2Invalid <=< mkTokenMintingTx $ alwaysFailsNoDatumHash
126+
submitPhase2Invalid_ =<< mkTokenMintingTx alwaysFailsNoDatumHash
128127

129128
-- Process a transaction with a succeeding script in every place possible,
130129
-- and also with succeeding timelock scripts.
@@ -162,7 +161,7 @@ spec = describe "Valid transactions" $ do
162161
& withdrawalsTxBodyL .~ Withdrawals (fromList [(acct, mempty) | acct <- rewardAccounts])
163162
& certsTxBodyL .~ fromList (UnRegTxCert . ScriptHashObj <$> rewardScriptHashes)
164163
& outputsTxBodyL .~ [txOut]
165-
expectTxSuccess <=< submitTx $ mkBasicTx txBody
164+
submitTx_ $ mkBasicTx txBody
166165

167166
it "Acceptable supplementary datum" $ do
168167
inputAddr <- freshKeyHash @'Payment
@@ -183,7 +182,7 @@ spec = describe "Valid transactions" $ do
183182
tx =
184183
mkBasicTx txBody
185184
& witsTxL . datsTxWitsL . unTxDatsL %~ Map.insert datumHash datum
186-
expectTxSuccess =<< submitTx tx
185+
submitTx_ tx
187186

188187
it "Multiple identical certificates" $ do
189188
let scriptHash = alwaysSucceedsNoDatumHash
@@ -199,4 +198,4 @@ spec = describe "Valid transactions" $ do
199198
[injectFailure $ StakeKeyNotRegisteredDELEG (ScriptHashObj scriptHash)]
200199
else
201200
-- Conway fixed the bug that was causing DELEG to fail
202-
expectTxSuccess =<< submitTx tx
201+
submitTx_ tx

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

Lines changed: 14 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,7 @@ module Test.Cardano.Ledger.Alonzo.ImpTest (
3030
impScriptPredicateFailure,
3131
submitPhase2Invalid_,
3232
submitPhase2Invalid,
33-
expectTxSuccess,
33+
impAlonzoExpectTxSuccess,
3434
-- Fixup
3535
fixupDatums,
3636
fixupOutputDatums,
@@ -436,6 +436,7 @@ instance ShelleyEraImp AlonzoEra where
436436

437437
impSatisfyNativeScript = impAllegraSatisfyNativeScript
438438
fixupTx = alonzoFixupTx
439+
expectTxSuccess = impAlonzoExpectTxSuccess
439440

440441
instance MaryEraImp AlonzoEra
441442

@@ -516,25 +517,25 @@ submitPhase2Invalid tx = do
516517
impAnn "Submit tx with IsValid False" $ do
517518
withNoFixup $ submitTx $ fixedUpTx & isValidTxL .~ IsValid False
518519

519-
expectTxSuccess ::
520+
impAlonzoExpectTxSuccess ::
520521
( HasCallStack
521522
, AlonzoEraImp era
522523
) =>
523524
Tx era -> ImpTestM era ()
524-
expectTxSuccess tx
525-
| tx ^. isValidTxL == IsValid True = do
526-
utxo <- getsNES utxoL
527-
let inputs = Set.toList $ tx ^. bodyTxL . inputsTxBodyL
528-
outputs = Map.toList . unUTxO . txouts $ tx ^. bodyTxL
525+
impAlonzoExpectTxSuccess tx = do
526+
utxo <- getsNES utxoL
527+
let inputs = tx ^. bodyTxL . inputsTxBodyL
528+
collaterals = tx ^. bodyTxL . collateralInputsTxBodyL
529+
outputs = Map.toList . unUTxO . txouts $ tx ^. bodyTxL
530+
if tx ^. isValidTxL == IsValid True
531+
then do
529532
impAnn "Inputs should be gone from UTxO" $
530-
expectUTxOContent utxo [(txIn, isNothing) | txIn <- inputs]
533+
expectUTxOContent utxo [(txIn, isNothing) | txIn <- Set.toList inputs]
534+
impAnn "Collateral inputs should still be in UTxO" $
535+
expectUTxOContent utxo [(txIn, isJust) | txIn <- Set.toList $ collaterals \\ inputs]
531536
impAnn "Outputs should be in UTxO" $
532537
expectUTxOContent utxo [(txIn, (== Just txOut)) | (txIn, txOut) <- outputs]
533-
| otherwise = do
534-
utxo <- getsNES utxoL
535-
let inputs = tx ^. bodyTxL . inputsTxBodyL
536-
collaterals = tx ^. bodyTxL . collateralInputsTxBodyL
537-
outputs = Map.toList . unUTxO . txouts $ tx ^. bodyTxL
538+
else do
538539
impAnn "Non-collateral inputs should still be in UTxO" $
539540
expectUTxOContent utxo [(txIn, isJust) | txIn <- Set.toList $ inputs \\ collaterals]
540541
impAnn "Collateral inputs should not be in UTxO" $

‎eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/ImpTest.hs‎

Lines changed: 31 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -12,21 +12,31 @@
1212

1313
module Test.Cardano.Ledger.Babbage.ImpTest (
1414
babbageFixupTx,
15+
impBabbageExpectTxSuccess,
1516
module Test.Cardano.Ledger.Alonzo.ImpTest,
1617
produceRefScript,
1718
produceRefScripts,
1819
) where
1920

21+
import Cardano.Ledger.Alonzo.Tx (IsValid (..))
2022
import Cardano.Ledger.Babbage (BabbageEra)
23+
import Cardano.Ledger.Babbage.Collateral (collOuts)
2124
import Cardano.Ledger.Babbage.Core
2225
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
2326
import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..))
24-
import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL, nesEsL)
27+
import Cardano.Ledger.Shelley.LedgerState (
28+
UTxO (..),
29+
curPParamsEpochStateL,
30+
nesEsL,
31+
utxoL,
32+
)
2533
import Cardano.Ledger.Tools (ensureMinCoinTxOut, setMinCoinTxOut)
2634
import Cardano.Ledger.TxIn (TxIn, mkTxInPartial)
2735
import Control.Monad (forM, (>=>))
2836
import Data.List.NonEmpty (NonEmpty (..))
2937
import qualified Data.List.NonEmpty as NE
38+
import qualified Data.Map.Strict as Map
39+
import Data.Maybe (isNothing)
3040
import qualified Data.Sequence.Strict as SSeq
3141
import GHC.Stack (HasCallStack)
3242
import Lens.Micro
@@ -40,6 +50,7 @@ instance ShelleyEraImp BabbageEra where
4050
(nesEsL . curPParamsEpochStateL . ppCostModelsL <>~ testingCostModels [PlutusV2])
4151
impSatisfyNativeScript = impAllegraSatisfyNativeScript
4252
fixupTx = babbageFixupTx
53+
expectTxSuccess = impBabbageExpectTxSuccess
4354

4455
babbageFixupTx ::
4556
( HasCallStack
@@ -74,6 +85,25 @@ fixupCollateralReturn tx = do
7485
pp <- getsNES $ nesEsL . curPParamsEpochStateL
7586
pure $ tx & bodyTxL . collateralReturnTxBodyL %~ fmap (ensureMinCoinTxOut pp)
7687

88+
impBabbageExpectTxSuccess ::
89+
( HasCallStack
90+
, AlonzoEraImp era
91+
, BabbageEraTxBody era
92+
) =>
93+
Tx era -> ImpTestM era ()
94+
impBabbageExpectTxSuccess tx = do
95+
impAlonzoExpectTxSuccess tx
96+
-- Check that the balance of the collateral was returned
97+
let returns = Map.toList . unUTxO . collOuts $ tx ^. bodyTxL
98+
utxo <- getsNES utxoL
99+
if tx ^. isValidTxL == IsValid True
100+
then do
101+
impAnn "Collateral return should not be in UTxO" $
102+
expectUTxOContent utxo [(txIn, isNothing) | (txIn, _txOut) <- returns]
103+
else do
104+
impAnn "Collateral return should be in UTxO" $
105+
expectUTxOContent utxo [(txIn, (== Just txOut)) | (txIn, txOut) <- returns]
106+
77107
instance ShelleyEraImp BabbageEra => MaryEraImp BabbageEra
78108

79109
instance ShelleyEraImp BabbageEra => AlonzoEraImp BabbageEra where

‎eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -319,6 +319,7 @@ instance ShelleyEraImp ConwayEra where
319319
modifyPParams = conwayModifyPParams
320320

321321
fixupTx = babbageFixupTx
322+
expectTxSuccess = impBabbageExpectTxSuccess
322323

323324
instance MaryEraImp ConwayEra
324325

‎eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ import Test.Cardano.Ledger.Mary.TreeDiff ()
2525
instance ShelleyEraImp MaryEra where
2626
impSatisfyNativeScript = impAllegraSatisfyNativeScript
2727
fixupTx = shelleyFixupTx
28+
expectTxSuccess = impShelleyExpectTxSuccess
2829

2930
class
3031
( ShelleyEraImp era

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

Lines changed: 20 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -56,6 +56,7 @@ module Test.Cardano.Ledger.Shelley.ImpTest (
5656
submitFailingTx,
5757
submitFailingTxM,
5858
trySubmitTx,
59+
impShelleyExpectTxSuccess,
5960
modifyNES,
6061
getProtVer,
6162
getsNES,
@@ -237,7 +238,7 @@ import Data.Functor.Identity (Identity (..))
237238
import Data.List.NonEmpty (NonEmpty)
238239
import Data.Map.Strict (Map)
239240
import qualified Data.Map.Strict as Map
240-
import Data.Maybe (catMaybes, mapMaybe)
241+
import Data.Maybe (catMaybes, isNothing, mapMaybe)
241242
import Data.Ratio ((%))
242243
import Data.Sequence.Strict (StrictSeq (..))
243244
import qualified Data.Sequence.Strict as SSeq
@@ -519,6 +520,8 @@ class
519520

520521
fixupTx :: HasCallStack => Tx era -> ImpTestM era (Tx era)
521522

523+
expectTxSuccess :: HasCallStack => Tx era -> ImpTestM era ()
524+
522525
defaultInitNewEpochState ::
523526
forall era g s m.
524527
( MonadState s m
@@ -751,6 +754,7 @@ instance
751754
pure $ satisfyScript script
752755

753756
fixupTx = shelleyFixupTx
757+
expectTxSuccess = impShelleyExpectTxSuccess
754758

755759
-- | Figure out all the Byron Addresses that need witnesses as well as all of the
756760
-- KeyHashes for Shelley Key witnesses that are required.
@@ -1031,6 +1035,20 @@ shelleyFixupTx =
10311035
>=> updateAddrTxWits
10321036
>=> (\tx -> logFeeMismatch tx $> tx)
10331037

1038+
impShelleyExpectTxSuccess ::
1039+
forall era.
1040+
(ShelleyEraImp era, HasCallStack) =>
1041+
Tx era ->
1042+
ImpTestM era ()
1043+
impShelleyExpectTxSuccess tx = do
1044+
utxo <- getsNES utxoL
1045+
let inputs = tx ^. bodyTxL . inputsTxBodyL
1046+
outputs = Map.toList . unUTxO . txouts $ tx ^. bodyTxL
1047+
impAnn "Inputs should be gone from UTxO" $
1048+
expectUTxOContent utxo [(txIn, isNothing) | txIn <- Set.toList inputs]
1049+
impAnn "Outputs should be in UTxO" $
1050+
expectUTxOContent utxo [(txIn, (== Just txOut)) | (txIn, txOut) <- outputs]
1051+
10341052
logFeeMismatch :: (EraGov era, EraUTxO era, HasCallStack) => Tx era -> ImpTestM era ()
10351053
logFeeMismatch tx = do
10361054
pp <- getsNES $ nesEsL . curPParamsEpochStateL
@@ -1105,6 +1123,7 @@ trySubmitTx tx = do
11051123
| Map.member impRootTxIn utxo = impRootTxIn
11061124
| otherwise = error "Root not found in UTxO"
11071125
impRootTxInL .= newRoot
1126+
expectTxSuccess txFixed
11081127
pure $ Right txFixed
11091128
{- FOURMOLU_ENABLE -}
11101129

0 commit comments

Comments
 (0)