Skip to content

Commit ba482bb

Browse files
SoupstrawSoupstraw
committed
WIP
1 parent 1902bdc commit ba482bb

File tree

9 files changed

+225
-67
lines changed

9 files changed

+225
-67
lines changed

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -399,6 +399,7 @@ plutusTestScripts lang =
399399
, mkScriptTestEntry (inputsOutputsAreNotEmptyNoDatum lang) $ PlutusArgs (P.I 122) Nothing
400400
, mkScriptTestEntry (inputsOutputsAreNotEmptyWithDatum lang) $ PlutusArgs (P.I 222) (Just $ P.I 5)
401401
, mkScriptTestEntry guardrailScript $ PlutusArgs (P.I 0) Nothing
402+
, mkScriptTestEntry (inputsIsSubsetOfRefInputs lang) $ PlutusArgs (P.I 0) Nothing
402403
]
403404

404405
malformedPlutus :: Plutus l

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

Lines changed: 1 addition & 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

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

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

3031
spec ::
3132
forall era.
@@ -45,3 +46,4 @@ spec = do
4546
AlonzoImp.spec @era
4647
describe "BabbageImpSpec" . withImpInit @(LedgerSpec era) $ do
4748
Utxow.spec
49+
Utxo.spec

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

Lines changed: 56 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,56 @@
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+
EraTx (..),
13+
EraTxBody (..),
14+
EraTxOut (..),
15+
KeyRole (..),
16+
)
17+
import Cardano.Ledger.BaseTypes (Inject (..))
18+
import Cardano.Ledger.Coin (Coin (..))
19+
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
20+
import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
21+
import qualified Data.Sequence.Strict as SSeq
22+
import qualified Data.Set as Set
23+
import Lens.Micro ((&), (.~))
24+
import Test.Cardano.Ledger.Babbage.ImpTest (
25+
AlonzoEraImp,
26+
ImpInit,
27+
LedgerSpec,
28+
submitTx,
29+
submitTx_,
30+
)
31+
import Test.Cardano.Ledger.Common (SpecWith, describe, it)
32+
import Test.Cardano.Ledger.Imp.Common (mkAddr)
33+
import Test.Cardano.Ledger.Plutus.Examples (inputsIsSubsetOfRefInputs)
34+
import Test.Cardano.Ledger.Core.Utils (txInAt)
35+
36+
spec :: forall era. (AlonzoEraImp era, BabbageEraTxBody era) => SpecWith (ImpInit (LedgerSpec era))
37+
spec = describe "UTXO" $ do
38+
describe "Reference scripts" $ do
39+
it "Reference inputs can overlap with regular inputs in PlutusV2" $ do
40+
let
41+
txOut =
42+
mkBasicTxOut
43+
( mkAddr
44+
(ScriptHashObj @'Payment $ hashPlutusScript (inputsIsSubsetOfRefInputs SPlutusV2))
45+
StakeRefNull
46+
)
47+
(inject $ Coin 1_000_000)
48+
tx <-
49+
submitTx $
50+
mkBasicTx mkBasicTxBody
51+
& bodyTxL . outputsTxBodyL .~ SSeq.singleton txOut
52+
let txIn = txInAt (0 :: Integer) tx
53+
submitTx_ @era $
54+
mkBasicTx mkBasicTxBody
55+
& bodyTxL . inputsTxBodyL .~ Set.singleton txIn
56+
& bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn

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

Lines changed: 12 additions & 66 deletions
Original file line numberDiff line numberDiff line change
@@ -12,30 +12,21 @@
1212

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

15-
import Cardano.Crypto.Hash (hashFromTextAsHex)
1615
import Cardano.Ledger.Address
1716
import Cardano.Ledger.Alonzo.Scripts
18-
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), unTxDatsL)
1917
import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..))
20-
import Cardano.Ledger.Babbage.Tx (hashScriptIntegrity)
2118
import Cardano.Ledger.Babbage.TxBody (referenceInputsTxBodyL)
2219
import Cardano.Ledger.Babbage.TxOut (referenceScriptTxOutL)
2320
import Cardano.Ledger.BaseTypes
2421
import Cardano.Ledger.Coin (Coin (..))
25-
import Cardano.Ledger.Conway.Core (AlonzoEraTxBody (..), AlonzoEraTxWits (..), ppMaxTxExUnitsL)
26-
import Cardano.Ledger.Conway.PParams (getLanguageView, ppMinFeeRefScriptCostPerByteL)
22+
import Cardano.Ledger.Conway.PParams (ppMinFeeRefScriptCostPerByteL)
2723
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
28-
import Cardano.Ledger.Hashes (unsafeMakeSafeHash)
2924
import Cardano.Ledger.MemoBytes (getMemoRawBytes)
30-
import Cardano.Ledger.Plutus (Data (..))
3125
import Cardano.Ledger.Plutus.Language (
32-
Language (..),
3326
Plutus (..),
34-
PlutusLanguage,
3527
SLanguage (..),
3628
hashPlutusScript,
3729
)
38-
import Cardano.Ledger.Plutus.Preprocessor.Binary.V2 (inputsIsSubsetOfRefInputsBytes)
3930
import Cardano.Ledger.Shelley.Core
4031
import Cardano.Ledger.Shelley.LedgerState
4132
import Cardano.Ledger.Shelley.Scripts (
@@ -44,22 +35,20 @@ import Cardano.Ledger.Shelley.Scripts (
4435
)
4536
import Cardano.Ledger.Shelley.UTxO (getShelleyMinFeeTxUtxo)
4637
import Cardano.Ledger.State (getMinFeeTxUtxo)
47-
import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
38+
import Cardano.Ledger.TxIn (TxIn (..))
4839
import Cardano.Ledger.Val
4940
import qualified Data.ByteString.Short as SBS (length)
5041
import Data.Functor ((<&>))
5142
import qualified Data.List.NonEmpty as NE
5243
import qualified Data.Map.Strict as Map
53-
import Data.Maybe (fromJust)
5444
import qualified Data.Sequence.Strict as SSeq
5545
import qualified Data.Set as Set
5646
import Lens.Micro ((&), (.~), (^.))
57-
import qualified PlutusLedgerApi.Common as P
5847
import Test.Cardano.Ledger.Conway.ImpTest
5948
import Test.Cardano.Ledger.Core.Rational ((%!))
6049
import Test.Cardano.Ledger.Core.Utils (txInAt)
6150
import Test.Cardano.Ledger.Imp.Common
62-
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum)
51+
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum, inputsIsSubsetOfRefInputs)
6352

6453
spec ::
6554
forall era.
@@ -86,62 +75,19 @@ spec =
8675
++ extraScripts
8776
describe "disjoint inputs and reference inputs" $ do
8877
let
89-
plutus = Plutus $ snd inputsIsSubsetOfRefInputsBytes
90-
scriptAddr :: forall (pv :: Language). PlutusLanguage pv => Addr
91-
scriptAddr =
92-
mkAddr
93-
(ScriptHashObj @'Payment $ hashPlutusScript @pv plutus)
94-
StakeRefNull
95-
--script :: forall (pv :: Language). PlutusLanguage pv => PlutusScript era
96-
--script = fromJust $ mkPlutusScript @era @pv plutus
97-
-- it "Same script can appear in regular and reference inputs in PlutusV2" $ do
98-
-- txIn <- sendCoinTo (scriptAddr @'PlutusV2) $ Coin 1_000_000
99-
-- submitTx_ $
100-
-- mkBasicTx mkBasicTxBody
101-
-- & bodyTxL . inputsTxBodyL .~ Set.singleton txIn
102-
-- & bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn
103-
-- & witsTxL . scriptTxWitsL .~ Map.singleton (hashPlutusScript @'PlutusV2 plutus) (PlutusScript $ script @'PlutusV2)
78+
scriptHash lang = hashPlutusScript (inputsIsSubsetOfRefInputs lang)
79+
tx :: TxIn -> Tx era
80+
tx txIn =
81+
mkBasicTx mkBasicTxBody
82+
& bodyTxL . inputsTxBodyL .~ Set.singleton txIn
83+
& bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn
10484
it "Same script cannot appear in regular and reference inputs in PlutusV3" $ do
105-
--maxExUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL
106-
txIn <- sendCoinTo (scriptAddr @'PlutusV3) $ Coin 1_000_000
107-
--collateralIn <- sendCoinTo (scriptAddr @'PlutusV3) $ Coin 1_000_000_000
108-
--pp <- getsPParams id
109-
let
110-
tx =
111-
mkBasicTx mkBasicTxBody
112-
& bodyTxL . inputsTxBodyL .~ Set.singleton txIn
113-
& bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn
114-
--langViews = Set.map (getLanguageView pp) (Set.singleton PlutusV2)
115-
--txWits =
116-
-- mkBasicTxWits
117-
-- & scriptTxWitsL
118-
-- .~ Map.singleton (hashPlutusScript @'PlutusV3 plutus) (PlutusScript $ script @'PlutusV3)
119-
-- & rdmrsTxWitsL .~ Redeemers (Map.singleton (SpendingPurpose (AsIx 0)) (Data $ P.I 0, maxExUnits))
120-
-- & datsTxWitsL . unTxDatsL .~ mempty
121-
--tx =
122-
-- mkBasicTx mkBasicTxBody
123-
-- & bodyTxL . inputsTxBodyL .~ Set.singleton txIn
124-
-- & bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn
125-
-- & bodyTxL . collateralInputsTxBodyL .~ Set.singleton collateralIn
126-
-- & bodyTxL . feeTxBodyL .~ Coin 100_000_000
127-
-- & bodyTxL . scriptIntegrityHashTxBodyL
128-
-- .~ hashScriptIntegrity @era langViews (txWits ^. rdmrsTxWitsL) (txWits ^. datsTxWitsL)
129-
-- & witsTxL .~ txWits
85+
txIn <- produceScript $ scriptHash SPlutusV3
13086
submitFailingTx @era
131-
tx
87+
(tx txIn)
13288
[ injectFailure $
13389
BabbageNonDisjointRefInputs
134-
( NE.fromList
135-
[ TxIn
136-
( TxId
137-
( unsafeMakeSafeHash . fromJust $
138-
hashFromTextAsHex
139-
"3b3a57c1fe445f8346b94a64ee39baf3f253e0932f37014c2735bb326d12be81"
140-
)
141-
)
142-
(TxIx 0)
143-
]
144-
)
90+
(txIn NE.:| [])
14591
]
14692
where
14793
checkMinFee :: HasCallStack => NativeScript era -> [Script era] -> ImpTestM era ()

0 commit comments

Comments
 (0)