Skip to content

Commit a71d627

Browse files
SoupstrawSoupstraw
committed
Plutus preprocessor Maybe
1 parent ba482bb commit a71d627

File tree

18 files changed

+291
-228
lines changed

18 files changed

+291
-228
lines changed

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

Lines changed: 24 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -76,6 +76,7 @@ import Cardano.Ledger.Plutus (
7676
Prices (..),
7777
SLanguage (..),
7878
ScriptResult (..),
79+
fromSLanguage,
7980
hashData,
8081
hashPlutusScript,
8182
)
@@ -93,6 +94,7 @@ import Data.MapExtras (fromElems)
9394
import Data.Maybe (catMaybes, isJust, isNothing)
9495
import Data.Set (Set, (\\))
9596
import qualified Data.Set as Set
97+
import qualified Data.Text as T
9698
import Lens.Micro
9799
import Lens.Micro.Mtl (use)
98100
import qualified PlutusLedgerApi.Common as P
@@ -276,13 +278,24 @@ fixupDatums tx = impAnn "fixupDatums" $ do
276278
collectDatums :: PlutusPurpose AsIxItem era -> ImpTestM era (Maybe (Data era))
277279
collectDatums purpose = do
278280
let txIn = unAsItem <$> toSpendingPurpose (hoistPlutusPurpose toAsItem purpose)
279-
txOut <- traverse (impGetUTxO @era) txIn
280-
pure $ getData =<< txOut
281-
282-
getData :: TxOut era -> Maybe (Data era)
283-
getData txOut = case txOut ^. datumTxOutF of
284-
DatumHash _dh -> spendDatum <$> Map.lookup (txOutScriptHash txOut) (scriptTestContexts @era)
285-
_ -> Nothing
281+
mbyTxOut <- traverse (impGetUTxO @era) txIn
282+
case mbyTxOut of
283+
Just txOut -> getData txOut
284+
Nothing -> pure Nothing
285+
286+
getData :: TxOut era -> ImpTestM era (Maybe (Data era))
287+
getData txOut =
288+
let sh = txOutScriptHash txOut
289+
in case txOut ^. datumTxOutF of
290+
DatumHash _dh -> case Map.lookup sh (scriptTestContexts @era) of
291+
Just x -> pure . Just $ spendDatum x
292+
Nothing -> do
293+
logText $
294+
"Script not found in `scriptTestContexts`:\n"
295+
<> T.pack (show sh)
296+
<> "\n\nThe transaction will likely fail. To fix this, add the script to `scriptTestContexts`."
297+
pure Nothing
298+
_ -> pure Nothing
286299

287300
txOutScriptHash txOut
288301
| Addr _ (ScriptHashObj sh) _ <- txOut ^. addrTxOutL = sh
@@ -383,7 +396,7 @@ plutusTestScripts ::
383396
SLanguage l ->
384397
Map.Map ScriptHash ScriptTestContext
385398
plutusTestScripts lang =
386-
Map.fromList
399+
Map.fromList $
387400
[ mkScriptTestEntry (malformedPlutus @l) $ PlutusArgs (P.I 0) (Just $ P.I 7)
388401
, mkScriptTestEntry (alwaysSucceedsNoDatum lang) $ PlutusArgs (P.I 0) Nothing
389402
, mkScriptTestEntry (alwaysSucceedsWithDatum lang) $ PlutusArgs (P.I 0) (Just $ P.I 0)
@@ -399,8 +412,10 @@ plutusTestScripts lang =
399412
, mkScriptTestEntry (inputsOutputsAreNotEmptyNoDatum lang) $ PlutusArgs (P.I 122) Nothing
400413
, mkScriptTestEntry (inputsOutputsAreNotEmptyWithDatum lang) $ PlutusArgs (P.I 222) (Just $ P.I 5)
401414
, mkScriptTestEntry guardrailScript $ PlutusArgs (P.I 0) Nothing
402-
, mkScriptTestEntry (inputsIsSubsetOfRefInputs lang) $ PlutusArgs (P.I 0) Nothing
403415
]
416+
++ [ mkScriptTestEntry (inputsOverlapsWithRefInputs lang) $ PlutusArgs (P.I 0) Nothing
417+
| fromSLanguage lang >= PlutusV2
418+
]
404419

405420
malformedPlutus :: Plutus l
406421
malformedPlutus = Plutus (PlutusBinary "invalid")

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -133,6 +133,7 @@ library testlib
133133
cardano-ledger-core:{cardano-ledger-core, testlib} >=1.13.2,
134134
cardano-ledger-shelley,
135135
cardano-strict-containers,
136+
plutus-ledger-api,
136137
containers,
137138
cuddle,
138139
generic-random,

‎eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxo.hs

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -232,9 +232,7 @@ disjointRefInputs ::
232232
Test (BabbageUtxoPredFailure era)
233233
disjointRefInputs pp inputs refInputs =
234234
when
235-
( pvMajor (pp ^. ppProtocolVersionL) > eraProtVerHigh @BabbageEra
236-
&& pvMajor (pp ^. ppProtocolVersionL) < natVersion @11
237-
)
235+
(pvMajor (pp ^. ppProtocolVersionL) == natVersion @10)
238236
(failureOnNonEmpty common BabbageNonDisjointRefInputs)
239237
where
240238
common = inputs `Set.intersection` refInputs

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -24,9 +24,9 @@ import Cardano.Ledger.Shelley.Rules (
2424
)
2525
import qualified Test.Cardano.Ledger.Alonzo.Imp as AlonzoImp
2626
import Test.Cardano.Ledger.Alonzo.ImpTest (AlonzoEraImp, LedgerSpec)
27+
import qualified Test.Cardano.Ledger.Babbage.Imp.UtxoSpec as Utxo
2728
import qualified Test.Cardano.Ledger.Babbage.Imp.UtxowSpec as Utxow
2829
import Test.Cardano.Ledger.Imp.Common
29-
import qualified Test.Cardano.Ledger.Babbage.Imp.UtxoSpec as Utxo
3030

3131
spec ::
3232
forall era.

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

Lines changed: 13 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ module Test.Cardano.Ledger.Babbage.Imp.UtxoSpec (spec) where
99

1010
import Cardano.Ledger.Babbage.Core (
1111
BabbageEraTxBody (..),
12+
BabbageEraTxOut (..),
1213
EraTx (..),
1314
EraTxBody (..),
1415
EraTxOut (..),
@@ -17,10 +18,17 @@ import Cardano.Ledger.Babbage.Core (
1718
import Cardano.Ledger.BaseTypes (Inject (..))
1819
import Cardano.Ledger.Coin (Coin (..))
1920
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
20-
import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
21+
import Cardano.Ledger.Plutus (
22+
Data (..),
23+
Datum (..),
24+
SLanguage (..),
25+
dataToBinaryData,
26+
hashPlutusScript,
27+
)
2128
import qualified Data.Sequence.Strict as SSeq
2229
import qualified Data.Set as Set
2330
import Lens.Micro ((&), (.~))
31+
import qualified PlutusLedgerApi.V1 as PV1
2432
import Test.Cardano.Ledger.Babbage.ImpTest (
2533
AlonzoEraImp,
2634
ImpInit,
@@ -29,9 +37,9 @@ import Test.Cardano.Ledger.Babbage.ImpTest (
2937
submitTx_,
3038
)
3139
import Test.Cardano.Ledger.Common (SpecWith, describe, it)
32-
import Test.Cardano.Ledger.Imp.Common (mkAddr)
33-
import Test.Cardano.Ledger.Plutus.Examples (inputsIsSubsetOfRefInputs)
3440
import Test.Cardano.Ledger.Core.Utils (txInAt)
41+
import Test.Cardano.Ledger.Imp.Common (mkAddr)
42+
import Test.Cardano.Ledger.Plutus.Examples (inputsOverlapsWithRefInputs)
3543

3644
spec :: forall era. (AlonzoEraImp era, BabbageEraTxBody era) => SpecWith (ImpInit (LedgerSpec era))
3745
spec = describe "UTXO" $ do
@@ -41,10 +49,11 @@ spec = describe "UTXO" $ do
4149
txOut =
4250
mkBasicTxOut
4351
( mkAddr
44-
(ScriptHashObj @'Payment $ hashPlutusScript (inputsIsSubsetOfRefInputs SPlutusV2))
52+
(ScriptHashObj @'Payment $ hashPlutusScript (inputsOverlapsWithRefInputs SPlutusV2))
4553
StakeRefNull
4654
)
4755
(inject $ Coin 1_000_000)
56+
& datumTxOutL .~ (Datum . dataToBinaryData . Data . PV1.I $ 0)
4857
tx <-
4958
submitTx $
5059
mkBasicTx mkBasicTxBody

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

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -167,7 +167,6 @@ library testlib
167167
base,
168168
bytestring,
169169
cardano-data:{cardano-data, testlib},
170-
cardano-crypto-class,
171170
cardano-ledger-allegra,
172171
cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib},
173172
cardano-ledger-babbage:{cardano-ledger-babbage, testlib},
@@ -186,7 +185,6 @@ library testlib
186185
microlens-mtl,
187186
mtl,
188187
plutus-ledger-api,
189-
plutus-preprocessor,
190188
prettyprinter,
191189
small-steps >=1.1,
192190
text,

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -88,6 +88,7 @@ spec ::
8888
, ToExpr (Event (EraRule "ENACT" era))
8989
, Eq (Event (EraRule "ENACT" era))
9090
, Typeable (Event (EraRule "ENACT" era))
91+
, ContextError era ~ ConwayContextError era
9192
) =>
9293
Spec
9394
spec = do
@@ -123,6 +124,7 @@ conwaySpec ::
123124
, ToExpr (Event (EraRule "ENACT" era))
124125
, Eq (Event (EraRule "ENACT" era))
125126
, Typeable (Event (EraRule "ENACT" era))
127+
, ContextError era ~ ConwayContextError era
126128
) =>
127129
SpecWith (ImpInit (LedgerSpec era))
128130
conwaySpec = do

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -77,7 +77,7 @@ spec = do
7777

7878
it "When already already registered" $ do
7979
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
80-
let sh = hashPlutusScript (evenRedeemerNoDatum SPlutusV3)
80+
let sh = hashPlutusScript $ evenRedeemerNoDatum SPlutusV3
8181
let tx =
8282
mkBasicTx mkBasicTxBody
8383
& bodyTxL . certsTxBodyL

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

Lines changed: 42 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -2,25 +2,28 @@
22
{-# LANGUAGE DataKinds #-}
33
{-# LANGUAGE FlexibleContexts #-}
44
{-# LANGUAGE LambdaCase #-}
5-
{-# LANGUAGE NumericUnderscores #-}
65
{-# LANGUAGE OverloadedLists #-}
76
{-# LANGUAGE OverloadedStrings #-}
87
{-# LANGUAGE PatternSynonyms #-}
98
{-# LANGUAGE ScopedTypeVariables #-}
109
{-# LANGUAGE TypeApplications #-}
1110
{-# LANGUAGE TypeFamilies #-}
11+
{-# LANGUAGE TypeOperators #-}
1212

1313
module Test.Cardano.Ledger.Conway.Imp.UtxoSpec (spec) where
1414

1515
import Cardano.Ledger.Address
16+
import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext (..))
17+
import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (..))
18+
import Cardano.Ledger.Alonzo.Rules (AlonzoUtxosPredFailure (..))
1619
import Cardano.Ledger.Alonzo.Scripts
1720
import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..))
1821
import Cardano.Ledger.Babbage.TxBody (referenceInputsTxBodyL)
1922
import Cardano.Ledger.Babbage.TxOut (referenceScriptTxOutL)
2023
import Cardano.Ledger.BaseTypes
2124
import Cardano.Ledger.Coin (Coin (..))
2225
import Cardano.Ledger.Conway.PParams (ppMinFeeRefScriptCostPerByteL)
23-
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
26+
import Cardano.Ledger.Conway.TxInfo (ConwayContextError (..))
2427
import Cardano.Ledger.MemoBytes (getMemoRawBytes)
2528
import Cardano.Ledger.Plutus.Language (
2629
Plutus (..),
@@ -48,11 +51,15 @@ import Test.Cardano.Ledger.Conway.ImpTest
4851
import Test.Cardano.Ledger.Core.Rational ((%!))
4952
import Test.Cardano.Ledger.Core.Utils (txInAt)
5053
import Test.Cardano.Ledger.Imp.Common
51-
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum, inputsIsSubsetOfRefInputs)
54+
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum, inputsOverlapsWithRefInputs)
5255

5356
spec ::
5457
forall era.
55-
(ConwayEraImp era, InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era) =>
58+
( ConwayEraImp era
59+
, InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
60+
, InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
61+
, ContextError era ~ ConwayContextError era
62+
) =>
5663
SpecWith (ImpInit (LedgerSpec era))
5764
spec =
5865
describe "Reference scripts" $ do
@@ -75,20 +82,42 @@ spec =
7582
++ extraScripts
7683
describe "disjoint inputs and reference inputs" $ do
7784
let
78-
scriptHash lang = hashPlutusScript (inputsIsSubsetOfRefInputs lang)
85+
scriptHash lang = hashPlutusScript $ inputsOverlapsWithRefInputs lang
7986
tx :: TxIn -> Tx era
8087
tx txIn =
8188
mkBasicTx mkBasicTxBody
8289
& bodyTxL . inputsTxBodyL .~ Set.singleton txIn
8390
& bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn
84-
it "Same script cannot appear in regular and reference inputs in PlutusV3" $ do
85-
txIn <- produceScript $ scriptHash SPlutusV3
86-
submitFailingTx @era
87-
(tx txIn)
88-
[ injectFailure $
89-
BabbageNonDisjointRefInputs
90-
(txIn NE.:| [])
91-
]
91+
92+
it "Same script cannot appear in regular and reference inputs in PlutusV3 (PV 9)"
93+
. whenMajorVersion @9
94+
$ do
95+
txIn <- produceScript $ scriptHash SPlutusV3
96+
submitTx_ @era $ tx txIn
97+
it "Same script cannot appear in regular and reference inputs in PlutusV3 (PV 10)"
98+
. whenMajorVersion @10
99+
$ do
100+
txIn <- produceScript $ scriptHash SPlutusV3
101+
submitFailingTx @era
102+
(tx txIn)
103+
[ injectFailure $
104+
BabbageNonDisjointRefInputs
105+
(txIn NE.:| [])
106+
]
107+
it "Same script cannot appear in regular and reference inputs in PlutusV3 (PV 11)"
108+
. whenMajorVersion @11
109+
$ do
110+
txIn <- produceScript $ scriptHash SPlutusV3
111+
submitFailingTx @era
112+
(tx txIn)
113+
[ injectFailure $
114+
CollectErrors
115+
[ BadTranslation
116+
( ReferenceInputsNotDisjointFromInputs
117+
(Set.singleton txIn)
118+
)
119+
]
120+
]
92121
where
93122
checkMinFee :: HasCallStack => NativeScript era -> [Script era] -> ImpTestM era ()
94123
checkMinFee scriptToSpend refScripts = do

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

Lines changed: 12 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ import Cardano.Ledger.Shelley.LedgerState
3232
import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..))
3333
import Cardano.Ledger.TxIn (TxId (..), mkTxInPartial)
3434
import Data.Default (def)
35+
import Data.Either (isLeft, isRight)
3536
import Data.List.NonEmpty (NonEmpty (..))
3637
import qualified Data.Map.Strict as Map
3738
import qualified Data.OSet.Strict as OSet
@@ -120,11 +121,17 @@ datumAndReferenceInputsSpec = do
120121
, mkTxInPartial producingTx 1
121122
]
122123
& bodyTxL . referenceInputsTxBodyL .~ Set.singleton (mkTxInPartial producingTx 0)
123-
submitFailingTx
124-
consumingTx
125-
( pure . injectFailure . BabbageNonDisjointRefInputs $
126-
mkTxInPartial producingTx 0 :| []
127-
)
124+
pv <- getProtVer
125+
res <- trySubmitTx consumingTx
126+
if pv == ProtVer (natVersion @10) 0
127+
then case res of
128+
Left (err, _) ->
129+
err
130+
`shouldBeExpr` ( pure . injectFailure . BabbageNonDisjointRefInputs $
131+
mkTxInPartial producingTx 0 :| []
132+
)
133+
x -> x `shouldSatisfyExpr` isLeft
134+
else res `shouldSatisfyExpr` isRight
128135
it "fails when using inline datums for PlutusV1" $ do
129136
let shSpending = hashPlutusScript (redeemerSameAsDatum SPlutusV1)
130137
refTxOut <- mkRefTxOut shSpending
@@ -150,22 +157,6 @@ datumAndReferenceInputsSpec = do
150157
CollectErrors
151158
[BadTranslation . inject . InlineDatumsNotSupported @era $ TxOutFromInput lockedTxIn]
152159
)
153-
it "fails with same txIn in regular inputs and reference inputs" $ do
154-
producingTx <- setupRefTx
155-
let
156-
consumingTx =
157-
mkBasicTx mkBasicTxBody
158-
& bodyTxL . inputsTxBodyL
159-
.~ Set.fromList
160-
[ mkTxInPartial producingTx 0
161-
, mkTxInPartial producingTx 1
162-
]
163-
& bodyTxL . referenceInputsTxBodyL .~ Set.singleton (mkTxInPartial producingTx 0)
164-
submitFailingTx
165-
consumingTx
166-
( pure . injectFailure . BabbageNonDisjointRefInputs $
167-
mkTxInPartial producingTx 0 :| []
168-
)
169160
it "fails when using inline datums for PlutusV1" $ do
170161
let shSpending = hashPlutusScript $ redeemerSameAsDatum SPlutusV1
171162
refTxOut <- mkRefTxOut shSpending

0 commit comments

Comments
 (0)