Skip to content

Commit a462432

Browse files
SoupstrawSoupstraw
committed
Disabled BabbageNonDisjointRefInputs predicate failure for PlutusV2 scripts
1 parent c377787 commit a462432

File tree

20 files changed

+448
-111
lines changed

20 files changed

+448
-111
lines changed

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

Lines changed: 26 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -78,6 +78,7 @@ import Cardano.Ledger.Plutus (
7878
ScriptResult (..),
7979
hashData,
8080
hashPlutusScript,
81+
plutusLanguage,
8182
)
8283
import Cardano.Ledger.Shelley.LedgerState (
8384
curPParamsEpochStateL,
@@ -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
@@ -302,10 +315,10 @@ fixupPPHash tx = impAnn "fixupPPHash" $ do
302315
let
303316
scriptHashes :: Set ScriptHash
304317
scriptHashes = getScriptsHashesNeeded . getScriptsNeeded utxo $ tx ^. bodyTxL
305-
plutusLanguage sh = do
318+
scriptLanguage sh = do
306319
let mbyPlutus = impLookupPlutusScript sh
307320
pure $ getLanguageView pp . plutusScriptLanguage @era <$> mbyPlutus
308-
langs <- traverse plutusLanguage $ Set.toList scriptHashes
321+
langs <- traverse scriptLanguage $ Set.toList scriptHashes
309322
let
310323
integrityHash =
311324
hashScriptIntegrity
@@ -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)
@@ -400,6 +413,9 @@ plutusTestScripts lang =
400413
, mkScriptTestEntry (inputsOutputsAreNotEmptyWithDatum lang) $ PlutusArgs (P.I 222) (Just $ P.I 5)
401414
, mkScriptTestEntry guardrailScript $ PlutusArgs (P.I 0) Nothing
402415
]
416+
++ [ mkScriptTestEntry (inputsOverlapsWithRefInputs lang) $ PlutusArgs (P.I 0) Nothing
417+
| plutusLanguage lang >= PlutusV2
418+
]
403419

404420
malformedPlutus :: Plutus l
405421
malformedPlutus = Plutus (PlutusBinary "invalid")

‎eras/babbage/impl/CHANGELOG.md

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22

33
## 1.12.0.0
44

5+
* Remove `BabbageNonDisjointRefInputs` for protocol versions >10
56
* Remove `BabbageTxBody`
67
* Removed `era` parameter from `BabbageTxBodyRaw`
78
* Move `Annotator` instances to `testlib`

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -104,6 +104,7 @@ library testlib
104104
Test.Cardano.Ledger.Babbage.CDDL
105105
Test.Cardano.Ledger.Babbage.Era
106106
Test.Cardano.Ledger.Babbage.Imp
107+
Test.Cardano.Ledger.Babbage.Imp.UtxoSpec
107108
Test.Cardano.Ledger.Babbage.Imp.UtxowSpec
108109
Test.Cardano.Ledger.Babbage.ImpTest
109110
Test.Cardano.Ledger.Babbage.Translation.TranslatableGen
@@ -137,6 +138,7 @@ library testlib
137138
generic-random,
138139
heredoc,
139140
microlens,
141+
plutus-ledger-api,
140142
small-steps >=1.1,
141143

142144
executable huddle-cddl

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

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,7 @@ module Cardano.Ledger.Babbage.Rules.Utxo (
2424
validateTotalCollateral,
2525
validateCollateralEqBalance,
2626
validateOutputTooSmallUTxO,
27+
disjointRefInputs,
2728
) where
2829

2930
import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure, shelleyToAllegraUtxoPredFailure)
@@ -60,7 +61,7 @@ import Cardano.Ledger.BaseTypes (
6061
networkId,
6162
systemStart,
6263
)
63-
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), Sized (..))
64+
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), Sized (..), natVersion)
6465
import Cardano.Ledger.Binary.Coders
6566
import Cardano.Ledger.Coin (Coin (..), DeltaCoin, toDeltaCoin)
6667
import Cardano.Ledger.Rules.ValidationMode (
@@ -231,7 +232,7 @@ disjointRefInputs ::
231232
Test (BabbageUtxoPredFailure era)
232233
disjointRefInputs pp inputs refInputs =
233234
when
234-
(pvMajor (pp ^. ppProtocolVersionL) > eraProtVerHigh @BabbageEra)
235+
(pvMajor (pp ^. ppProtocolVersionL) == natVersion @10)
235236
(failureOnNonEmpty common BabbageNonDisjointRefInputs)
236237
where
237238
common = inputs `Set.intersection` refInputs

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ import Cardano.Ledger.Shelley.Rules (
2525
)
2626
import qualified Test.Cardano.Ledger.Alonzo.Imp as AlonzoImp
2727
import Test.Cardano.Ledger.Alonzo.ImpTest (AlonzoEraImp, LedgerSpec)
28+
import qualified Test.Cardano.Ledger.Babbage.Imp.UtxoSpec as Utxo
2829
import qualified Test.Cardano.Ledger.Babbage.Imp.UtxowSpec as Utxow
2930
import Test.Cardano.Ledger.Imp.Common
3031

@@ -47,3 +48,4 @@ spec = do
4748
AlonzoImp.spec @era
4849
describe "BabbageImpSpec" . withImpInit @(LedgerSpec era) $ do
4950
Utxow.spec
51+
Utxo.spec

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

Lines changed: 65 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,65 @@
1+
{-# LANGUAGE AllowAmbiguousTypes #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE NumericUnderscores #-}
4+
{-# LANGUAGE RankNTypes #-}
5+
{-# LANGUAGE ScopedTypeVariables #-}
6+
{-# LANGUAGE TypeApplications #-}
7+
8+
module Test.Cardano.Ledger.Babbage.Imp.UtxoSpec (spec) where
9+
10+
import Cardano.Ledger.Babbage.Core (
11+
BabbageEraTxBody (..),
12+
BabbageEraTxOut (..),
13+
EraTx (..),
14+
EraTxBody (..),
15+
EraTxOut (..),
16+
KeyRole (..),
17+
)
18+
import Cardano.Ledger.BaseTypes (Inject (..))
19+
import Cardano.Ledger.Coin (Coin (..))
20+
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
21+
import Cardano.Ledger.Plutus (
22+
Data (..),
23+
Datum (..),
24+
SLanguage (..),
25+
dataToBinaryData,
26+
hashPlutusScript,
27+
)
28+
import qualified Data.Sequence.Strict as SSeq
29+
import qualified Data.Set as Set
30+
import Lens.Micro ((&), (.~))
31+
import qualified PlutusLedgerApi.V1 as PV1
32+
import Test.Cardano.Ledger.Babbage.ImpTest (
33+
AlonzoEraImp,
34+
ImpInit,
35+
LedgerSpec,
36+
submitTx,
37+
submitTx_,
38+
)
39+
import Test.Cardano.Ledger.Common (SpecWith, describe, it)
40+
import Test.Cardano.Ledger.Core.Utils (txInAt)
41+
import Test.Cardano.Ledger.Imp.Common (mkAddr)
42+
import Test.Cardano.Ledger.Plutus.Examples (inputsOverlapsWithRefInputs)
43+
44+
spec :: forall era. (AlonzoEraImp era, BabbageEraTxBody era) => SpecWith (ImpInit (LedgerSpec era))
45+
spec = describe "UTXO" $ do
46+
describe "Reference scripts" $ do
47+
it "Reference inputs can overlap with regular inputs in PlutusV2" $ do
48+
let
49+
txOut =
50+
mkBasicTxOut
51+
( mkAddr
52+
(ScriptHashObj @'Payment $ hashPlutusScript (inputsOverlapsWithRefInputs SPlutusV2))
53+
StakeRefNull
54+
)
55+
(inject $ Coin 1_000_000)
56+
& datumTxOutL .~ (Datum . dataToBinaryData . Data . PV1.I $ 0)
57+
tx <-
58+
submitTx $
59+
mkBasicTx mkBasicTxBody
60+
& bodyTxL . outputsTxBodyL .~ SSeq.singleton txOut
61+
let txIn = txInAt (0 :: Integer) tx
62+
submitTx_ @era $
63+
mkBasicTx mkBasicTxBody
64+
& bodyTxL . inputsTxBodyL .~ Set.singleton txIn
65+
& bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn

‎eras/conway/impl/CHANGELOG.md

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22

33
## 1.20.0.0
44

5+
* Add `ReferenceInputsNotDisjointFromInputs`
56
* Bump `ProtVerHigh ConwayEra` to `11`
67
* Remove `ConwayTxBody`
78
* Removed `era` parameter from `ConwayTxBodyRaw`

‎eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs

Lines changed: 20 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -55,7 +55,7 @@ import Cardano.Ledger.BaseTypes (
5555
strictMaybe,
5656
txIxToInt,
5757
)
58-
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
58+
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), natVersion)
5959
import Cardano.Ledger.Binary.Coders (
6060
Decode (..),
6161
Encode (..),
@@ -166,6 +166,7 @@ data ConwayContextError era
166166
| VotingProceduresFieldNotSupported !(VotingProcedures era)
167167
| ProposalProceduresFieldNotSupported !(OSet.OSet (ProposalProcedure era))
168168
| TreasuryDonationFieldNotSupported !Coin
169+
| ReferenceInputsNotDisjointFromInputs !(Set.Set TxIn)
169170
deriving (Generic)
170171

171172
deriving instance
@@ -232,6 +233,8 @@ instance
232233
encode $ Sum ProposalProceduresFieldNotSupported 13 !> To proposalProcedures
233234
TreasuryDonationFieldNotSupported coin ->
234235
encode $ Sum TreasuryDonationFieldNotSupported 14 !> To coin
236+
ReferenceInputsNotDisjointFromInputs common ->
237+
encode $ Sum ReferenceInputsNotDisjointFromInputs 15 !> To common
235238

236239
instance
237240
( EraPParams era
@@ -249,6 +252,7 @@ instance
249252
12 -> SumD VotingProceduresFieldNotSupported <! From
250253
13 -> SumD ProposalProceduresFieldNotSupported <! From
251254
14 -> SumD TreasuryDonationFieldNotSupported <! From
255+
15 -> SumD ReferenceInputsNotDisjointFromInputs <! From
252256
n -> Invalid n
253257

254258
instance
@@ -281,6 +285,10 @@ instance
281285
kindObject
282286
"TreasuryDonationFieldNotSupported"
283287
["treasury_donation" .= toJSON coin]
288+
ReferenceInputsNotDisjointFromInputs common ->
289+
kindObject
290+
"ReferenceInputsNotDisjointFromInputs"
291+
["common" .= toJSON common]
284292

285293
-- | Given a TxOut, translate it for V2 and return (Right transalation).
286294
-- If the transaction contains any Byron addresses or Babbage features, return Left.
@@ -457,8 +465,15 @@ instance EraPlutusTxInfo 'PlutusV3 ConwayEra where
457465
toPlutusTxInfo proxy LedgerTxInfo {ltiProtVer, ltiEpochInfo, ltiSystemStart, ltiUTxO, ltiTx} = do
458466
timeRange <-
459467
Alonzo.transValidityInterval ltiTx ltiProtVer ltiEpochInfo ltiSystemStart (txBody ^. vldtTxBodyL)
460-
inputs <- mapM (transTxInInfoV3 ltiUTxO) (Set.toList (txBody ^. inputsTxBodyL))
461-
refInputs <- mapM (transTxInInfoV3 ltiUTxO) (Set.toList (txBody ^. referenceInputsTxBodyL))
468+
let
469+
txInputs = txBody ^. inputsTxBodyL
470+
refInputs = txBody ^. referenceInputsTxBodyL
471+
inputsInfo <- mapM (transTxInInfoV3 ltiUTxO) (Set.toList txInputs)
472+
refInputsInfo <- mapM (transTxInInfoV3 ltiUTxO) (Set.toList refInputs)
473+
let
474+
commonInputs = txInputs `Set.intersection` refInputs
475+
unless (pvMajor ltiProtVer < natVersion @11 || Set.null commonInputs) . Left $
476+
ReferenceInputsNotDisjointFromInputs commonInputs
462477
outputs <-
463478
zipWithM
464479
(Babbage.transTxOutV2 . TxOutFromOutput)
@@ -468,9 +483,9 @@ instance EraPlutusTxInfo 'PlutusV3 ConwayEra where
468483
plutusRedeemers <- Babbage.transTxRedeemers proxy ltiProtVer ltiTx
469484
pure
470485
PV3.TxInfo
471-
{ PV3.txInfoInputs = inputs
486+
{ PV3.txInfoInputs = inputsInfo
472487
, PV3.txInfoOutputs = outputs
473-
, PV3.txInfoReferenceInputs = refInputs
488+
, PV3.txInfoReferenceInputs = refInputsInfo
474489
, PV3.txInfoFee = transCoinToLovelace (txBody ^. feeTxBodyL)
475490
, PV3.txInfoMint = transMintValue (txBody ^. mintTxBodyL)
476491
, PV3.txInfoTxCerts = txCerts

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -90,6 +90,7 @@ spec ::
9090
, ToExpr (Event (EraRule "ENACT" era))
9191
, Eq (Event (EraRule "ENACT" era))
9292
, Typeable (Event (EraRule "ENACT" era))
93+
, ContextError era ~ ConwayContextError era
9394
) =>
9495
Spec
9596
spec = do
@@ -125,6 +126,7 @@ conwaySpec ::
125126
, ToExpr (Event (EraRule "ENACT" era))
126127
, Eq (Event (EraRule "ENACT" era))
127128
, Typeable (Event (EraRule "ENACT" era))
129+
, ContextError era ~ ConwayContextError era
128130
) =>
129131
SpecWith (ImpInit (LedgerSpec era))
130132
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

0 commit comments

Comments
 (0)