Skip to content

Commit 622fd9c

Browse files
Soupstrawlehins
Soupstraw
and
lehins
committed
Disabled BabbageNonDisjointRefInputs predicate failure for PlutusV2 scripts
Add majorVersionAtLeast and majorVersionAtMost Co-authored-by: Alexey Kuleshevich <alexey.kuleshevich@iohk.io>
1 parent 32cb074 commit 622fd9c

File tree

21 files changed

+508
-132
lines changed

21 files changed

+508
-132
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 | hashData @era (spendDatum x) == dh -> pure . Just $ spendDatum x
292+
_ -> 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: 5 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,9 @@ disjointRefInputs ::
231232
Test (BabbageUtxoPredFailure era)
232233
disjointRefInputs pp inputs refInputs =
233234
when
234-
(pvMajor (pp ^. ppProtocolVersionL) > eraProtVerHigh @BabbageEra)
235+
( pvMajor (pp ^. ppProtocolVersionL) > eraProtVerHigh @BabbageEra
236+
&& pvMajor (pp ^. ppProtocolVersionL) < natVersion @11
237+
)
235238
(failureOnNonEmpty common BabbageNonDisjointRefInputs)
236239
where
237240
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: 68 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
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+
ppProtocolVersionL,
17+
)
18+
import Cardano.Ledger.BaseTypes (Inject (..), ProtVer (..), natVersion)
19+
import Cardano.Ledger.Coin (Coin (..))
20+
import Cardano.Ledger.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+
getsPParams,
37+
submitTx,
38+
submitTx_,
39+
)
40+
import Test.Cardano.Ledger.Common (SpecWith, describe, it, when)
41+
import Test.Cardano.Ledger.Core.Utils (txInAt)
42+
import Test.Cardano.Ledger.Imp.Common (mkAddr)
43+
import Test.Cardano.Ledger.Plutus.Examples (inputsOverlapsWithRefInputs)
44+
45+
spec :: forall era. (AlonzoEraImp era, BabbageEraTxBody era) => SpecWith (ImpInit (LedgerSpec era))
46+
spec = describe "UTXO" $ do
47+
describe "Reference scripts" $ do
48+
it "Reference inputs can overlap with regular inputs in PlutusV2" $ do
49+
let
50+
txOut =
51+
mkBasicTxOut
52+
( mkAddr
53+
(hashPlutusScript (inputsOverlapsWithRefInputs SPlutusV2))
54+
StakeRefNull
55+
)
56+
(inject $ Coin 1_000_000)
57+
& datumTxOutL .~ Datum (dataToBinaryData . Data $ PV1.I 0)
58+
tx <-
59+
submitTx $
60+
mkBasicTx mkBasicTxBody
61+
& bodyTxL . outputsTxBodyL .~ SSeq.singleton txOut
62+
let txIn = txInAt (0 :: Integer) tx
63+
majorVer <- pvMajor <$> getsPParams ppProtocolVersionL
64+
when (majorVer < natVersion @9 || majorVer > natVersion @10) $
65+
submitTx_ @era $
66+
mkBasicTx mkBasicTxBody
67+
& bodyTxL . inputsTxBodyL .~ Set.singleton txIn
68+
& 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: 22 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 (..),
@@ -118,6 +118,7 @@ import Control.DeepSeq (NFData)
118118
import Control.Monad (unless, when, zipWithM)
119119
import Data.Aeson (ToJSON (..), (.=))
120120
import Data.Foldable as F (Foldable (..))
121+
import Data.List.NonEmpty (NonEmpty (..))
121122
import qualified Data.Map.Strict as Map
122123
import qualified Data.OSet.Strict as OSet
123124
import qualified Data.Set as Set
@@ -166,6 +167,7 @@ data ConwayContextError era
166167
| VotingProceduresFieldNotSupported !(VotingProcedures era)
167168
| ProposalProceduresFieldNotSupported !(OSet.OSet (ProposalProcedure era))
168169
| TreasuryDonationFieldNotSupported !Coin
170+
| ReferenceInputsNotDisjointFromInputs !(NonEmpty TxIn)
169171
deriving (Generic)
170172

171173
deriving instance
@@ -232,6 +234,8 @@ instance
232234
encode $ Sum ProposalProceduresFieldNotSupported 13 !> To proposalProcedures
233235
TreasuryDonationFieldNotSupported coin ->
234236
encode $ Sum TreasuryDonationFieldNotSupported 14 !> To coin
237+
ReferenceInputsNotDisjointFromInputs common ->
238+
encode $ Sum ReferenceInputsNotDisjointFromInputs 15 !> To common
235239

236240
instance
237241
( EraPParams era
@@ -249,6 +253,7 @@ instance
249253
12 -> SumD VotingProceduresFieldNotSupported <! From
250254
13 -> SumD ProposalProceduresFieldNotSupported <! From
251255
14 -> SumD TreasuryDonationFieldNotSupported <! From
256+
15 -> SumD ReferenceInputsNotDisjointFromInputs <! From
252257
n -> Invalid n
253258

254259
instance
@@ -281,6 +286,10 @@ instance
281286
kindObject
282287
"TreasuryDonationFieldNotSupported"
283288
["treasury_donation" .= toJSON coin]
289+
ReferenceInputsNotDisjointFromInputs common ->
290+
kindObject
291+
"ReferenceInputsNotDisjointFromInputs"
292+
["common" .= toJSON common]
284293

285294
-- | Given a TxOut, translate it for V2 and return (Right transalation).
286295
-- If the transaction contains any Byron addresses or Babbage features, return Left.
@@ -457,8 +466,16 @@ instance EraPlutusTxInfo 'PlutusV3 ConwayEra where
457466
toPlutusTxInfo proxy LedgerTxInfo {ltiProtVer, ltiEpochInfo, ltiSystemStart, ltiUTxO, ltiTx} = do
458467
timeRange <-
459468
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))
469+
let
470+
txInputs = txBody ^. inputsTxBodyL
471+
refInputs = txBody ^. referenceInputsTxBodyL
472+
inputsInfo <- mapM (transTxInInfoV3 ltiUTxO) (Set.toList txInputs)
473+
refInputsInfo <- mapM (transTxInInfoV3 ltiUTxO) (Set.toList refInputs)
474+
let
475+
commonInputs = txInputs `Set.intersection` refInputs
476+
unless (pvMajor ltiProtVer < natVersion @11) $ case toList commonInputs of
477+
(x : xs) -> Left $ ReferenceInputsNotDisjointFromInputs $ x :| xs
478+
_ -> Right ()
462479
outputs <-
463480
zipWithM
464481
(Babbage.transTxOutV2 . TxOutFromOutput)
@@ -468,9 +485,9 @@ instance EraPlutusTxInfo 'PlutusV3 ConwayEra where
468485
plutusRedeemers <- Babbage.transTxRedeemers proxy ltiProtVer ltiTx
469486
pure
470487
PV3.TxInfo
471-
{ PV3.txInfoInputs = inputs
488+
{ PV3.txInfoInputs = inputsInfo
472489
, PV3.txInfoOutputs = outputs
473-
, PV3.txInfoReferenceInputs = refInputs
490+
, PV3.txInfoReferenceInputs = refInputsInfo
474491
, PV3.txInfoFee = transCoinToLovelace (txBody ^. feeTxBodyL)
475492
, PV3.txInfoMint = transMintValue (txBody ^. mintTxBodyL)
476493
, PV3.txInfoTxCerts = txCerts

‎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: 41 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,8 @@
1+
{-# LANGUAGE AllowAmbiguousTypes #-}
12
{-# LANGUAGE DataKinds #-}
23
{-# LANGUAGE FlexibleContexts #-}
34
{-# LANGUAGE LambdaCase #-}
5+
{-# LANGUAGE OverloadedLists #-}
46
{-# LANGUAGE OverloadedStrings #-}
57
{-# LANGUAGE PatternSynonyms #-}
68
{-# LANGUAGE ScopedTypeVariables #-}
@@ -10,14 +12,23 @@
1012
module Test.Cardano.Ledger.Conway.Imp.UtxoSpec (spec) where
1113

1214
import Cardano.Ledger.Address
15+
import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext (..))
16+
import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (..))
17+
import Cardano.Ledger.Alonzo.Rules (AlonzoUtxosPredFailure (..))
1318
import Cardano.Ledger.Alonzo.Scripts
19+
import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..))
1420
import Cardano.Ledger.Babbage.TxBody (referenceInputsTxBodyL)
1521
import Cardano.Ledger.Babbage.TxOut (referenceScriptTxOutL)
1622
import Cardano.Ledger.BaseTypes
1723
import Cardano.Ledger.Coin (Coin (..))
1824
import Cardano.Ledger.Conway.PParams (ppMinFeeRefScriptCostPerByteL)
25+
import Cardano.Ledger.Conway.TxInfo (ConwayContextError (..))
1926
import Cardano.Ledger.MemoBytes (getMemoRawBytes)
20-
import Cardano.Ledger.Plutus.Language (SLanguage (..), hashPlutusScript, plutusBinary)
27+
import Cardano.Ledger.Plutus.Language (
28+
Plutus (..),
29+
SLanguage (..),
30+
hashPlutusScript,
31+
)
2132
import Cardano.Ledger.Shelley.Core
2233
import Cardano.Ledger.Shelley.LedgerState
2334
import Cardano.Ledger.Shelley.Scripts (
@@ -38,11 +49,15 @@ import Test.Cardano.Ledger.Conway.ImpTest
3849
import Test.Cardano.Ledger.Core.Rational ((%!))
3950
import Test.Cardano.Ledger.Core.Utils (txInAt)
4051
import Test.Cardano.Ledger.Imp.Common
41-
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum)
52+
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum, inputsOverlapsWithRefInputs)
4253

4354
spec ::
4455
forall era.
45-
ConwayEraImp era =>
56+
( ConwayEraImp era
57+
, InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
58+
, InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
59+
, Inject (ConwayContextError era) (ContextError era)
60+
) =>
4661
SpecWith (ImpInit (LedgerSpec era))
4762
spec =
4863
describe "Reference scripts" $ do
@@ -63,6 +78,29 @@ spec =
6378
[fromNativeScript spendingScript, fromNativeScript spendingScript]
6479
++ extraScripts
6580
++ extraScripts
81+
describe "disjoint inputs and reference inputs" $ do
82+
let
83+
scriptHash lang = hashPlutusScript $ inputsOverlapsWithRefInputs lang
84+
mkTestTx :: TxIn -> Tx era
85+
mkTestTx txIn =
86+
mkBasicTx mkBasicTxBody
87+
& bodyTxL . inputsTxBodyL .~ Set.singleton txIn
88+
& bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn
89+
90+
it "Cannot run scripts that expect inputs and refInputs to overlap (PV 9/10)" $ do
91+
whenMajorVersionAtMost @10 $ do
92+
txIn <- produceScript $ scriptHash SPlutusV3
93+
submitFailingTx @era
94+
(mkTestTx txIn)
95+
[ injectFailure $ BabbageNonDisjointRefInputs [txIn]
96+
]
97+
it "Same script cannot appear in regular and reference inputs in PlutusV3 (PV 11)" $ whenMajorVersionAtLeast @11 $ do
98+
txIn <- produceScript $ scriptHash SPlutusV3
99+
submitFailingTx @era
100+
(mkTestTx txIn)
101+
[ injectFailure $
102+
CollectErrors [BadTranslation . inject $ ReferenceInputsNotDisjointFromInputs @era [txIn]]
103+
]
66104
where
67105
checkMinFee :: HasCallStack => NativeScript era -> [Script era] -> ImpTestM era ()
68106
checkMinFee scriptToSpend refScripts = do

0 commit comments

Comments
 (0)