Skip to content

Commit 1902bdc

Browse files
SoupstrawSoupstraw
committed
WIP
1 parent e5fd8f4 commit 1902bdc

File tree

4 files changed

+65
-23
lines changed

4 files changed

+65
-23
lines changed

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -167,6 +167,7 @@ library testlib
167167
base,
168168
bytestring,
169169
cardano-data:{cardano-data, testlib},
170+
cardano-crypto-class,
170171
cardano-ledger-allegra,
171172
cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib},
172173
cardano-ledger-babbage:{cardano-ledger-babbage, testlib},

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

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -54,7 +54,7 @@ import Cardano.Ledger.BaseTypes (
5454
strictMaybe,
5555
txIxToInt,
5656
)
57-
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
57+
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), natVersion)
5858
import Cardano.Ledger.Binary.Coders (
5959
Decode (..),
6060
Encode (..),
@@ -466,7 +466,8 @@ instance EraPlutusTxInfo 'PlutusV3 ConwayEra where
466466
refInputsInfo <- mapM (transTxInInfoV3 ltiUTxO) (Set.toList refInputs)
467467
let
468468
commonInputs = txInputs `Set.intersection` refInputs
469-
unless (Set.null commonInputs) . Left $ ReferenceInputsNotDisjointFromInputs commonInputs
469+
unless (pvMajor ltiProtVer < natVersion @11 || Set.null commonInputs) . Left $
470+
ReferenceInputsNotDisjointFromInputs commonInputs
470471
outputs <-
471472
zipWithM
472473
(Babbage.transTxOutV2 . TxOutFromOutput)

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

Lines changed: 60 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
{-# LANGUAGE FlexibleContexts #-}
44
{-# LANGUAGE LambdaCase #-}
55
{-# LANGUAGE NumericUnderscores #-}
6+
{-# LANGUAGE OverloadedLists #-}
67
{-# LANGUAGE OverloadedStrings #-}
78
{-# LANGUAGE PatternSynonyms #-}
89
{-# LANGUAGE ScopedTypeVariables #-}
@@ -11,16 +12,29 @@
1112

1213
module Test.Cardano.Ledger.Conway.Imp.UtxoSpec (spec) where
1314

15+
import Cardano.Crypto.Hash (hashFromTextAsHex)
1416
import Cardano.Ledger.Address
1517
import Cardano.Ledger.Alonzo.Scripts
18+
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), unTxDatsL)
19+
import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..))
20+
import Cardano.Ledger.Babbage.Tx (hashScriptIntegrity)
1621
import Cardano.Ledger.Babbage.TxBody (referenceInputsTxBodyL)
1722
import Cardano.Ledger.Babbage.TxOut (referenceScriptTxOutL)
1823
import Cardano.Ledger.BaseTypes
1924
import Cardano.Ledger.Coin (Coin (..))
20-
import Cardano.Ledger.Conway.PParams (ppMinFeeRefScriptCostPerByteL)
25+
import Cardano.Ledger.Conway.Core (AlonzoEraTxBody (..), AlonzoEraTxWits (..), ppMaxTxExUnitsL)
26+
import Cardano.Ledger.Conway.PParams (getLanguageView, ppMinFeeRefScriptCostPerByteL)
2127
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
28+
import Cardano.Ledger.Hashes (unsafeMakeSafeHash)
2229
import Cardano.Ledger.MemoBytes (getMemoRawBytes)
23-
import Cardano.Ledger.Plutus.Language (Language (..), Plutus (..), PlutusLanguage, SLanguage (..), hashPlutusScript)
30+
import Cardano.Ledger.Plutus (Data (..))
31+
import Cardano.Ledger.Plutus.Language (
32+
Language (..),
33+
Plutus (..),
34+
PlutusLanguage,
35+
SLanguage (..),
36+
hashPlutusScript,
37+
)
2438
import Cardano.Ledger.Plutus.Preprocessor.Binary.V2 (inputsIsSubsetOfRefInputsBytes)
2539
import Cardano.Ledger.Shelley.Core
2640
import Cardano.Ledger.Shelley.LedgerState
@@ -30,28 +44,26 @@ import Cardano.Ledger.Shelley.Scripts (
3044
)
3145
import Cardano.Ledger.Shelley.UTxO (getShelleyMinFeeTxUtxo)
3246
import Cardano.Ledger.State (getMinFeeTxUtxo)
33-
import Cardano.Ledger.TxIn (TxIn (..))
47+
import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
3448
import Cardano.Ledger.Val
3549
import qualified Data.ByteString.Short as SBS (length)
3650
import Data.Functor ((<&>))
51+
import qualified Data.List.NonEmpty as NE
3752
import qualified Data.Map.Strict as Map
53+
import Data.Maybe (fromJust)
3854
import qualified Data.Sequence.Strict as SSeq
3955
import qualified Data.Set as Set
4056
import Lens.Micro ((&), (.~), (^.))
57+
import qualified PlutusLedgerApi.Common as P
4158
import Test.Cardano.Ledger.Conway.ImpTest
4259
import Test.Cardano.Ledger.Core.Rational ((%!))
4360
import Test.Cardano.Ledger.Core.Utils (txInAt)
4461
import Test.Cardano.Ledger.Imp.Common
4562
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum)
46-
import Data.Maybe (fromJust)
47-
import Cardano.Ledger.Conway.Core (AlonzoEraTxWits(..), ppMaxTxExUnitsL, AlonzoEraTxBody (..))
48-
import Cardano.Ledger.Alonzo.TxWits (Redeemers(..))
49-
import Cardano.Ledger.Plutus (Data(..))
50-
import qualified PlutusLedgerApi.Common as P
5163

5264
spec ::
5365
forall era.
54-
ConwayEraImp era =>
66+
(ConwayEraImp era, InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era) =>
5567
SpecWith (ImpInit (LedgerSpec era))
5668
spec =
5769
describe "Reference scripts" $ do
@@ -80,29 +92,57 @@ spec =
8092
mkAddr
8193
(ScriptHashObj @'Payment $ hashPlutusScript @pv plutus)
8294
StakeRefNull
83-
script :: forall (pv :: Language). PlutusLanguage pv => PlutusScript era
84-
script = fromJust $ mkPlutusScript @era @pv plutus
85-
--it "Same script can appear in regular and reference inputs in PlutusV2" $ do
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
8698
-- txIn <- sendCoinTo (scriptAddr @'PlutusV2) $ Coin 1_000_000
8799
-- submitTx_ $
88100
-- mkBasicTx mkBasicTxBody
89101
-- & bodyTxL . inputsTxBodyL .~ Set.singleton txIn
90102
-- & bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn
91103
-- & witsTxL . scriptTxWitsL .~ Map.singleton (hashPlutusScript @'PlutusV2 plutus) (PlutusScript $ script @'PlutusV2)
92104
it "Same script cannot appear in regular and reference inputs in PlutusV3" $ do
93-
maxExUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL
105+
--maxExUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL
94106
txIn <- sendCoinTo (scriptAddr @'PlutusV3) $ Coin 1_000_000
95-
collateralIn <- sendCoinTo (scriptAddr @'PlutusV3) $ Coin 1_000_000_000
107+
--collateralIn <- sendCoinTo (scriptAddr @'PlutusV3) $ Coin 1_000_000_000
108+
--pp <- getsPParams id
96109
let
97-
tx =
110+
tx =
98111
mkBasicTx mkBasicTxBody
99112
& bodyTxL . inputsTxBodyL .~ Set.singleton txIn
100113
& bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn
101-
& bodyTxL . collateralInputsTxBodyL .~ Set.singleton collateralIn
102-
& bodyTxL . feeTxBodyL .~ Coin 100_000_000
103-
& witsTxL . scriptTxWitsL .~ Map.singleton (hashPlutusScript @'PlutusV3 plutus) (PlutusScript $ script @'PlutusV3)
104-
& witsTxL . rdmrsTxWitsL .~ Redeemers (Map.singleton (SpendingPurpose (AsIx 0)) (Data $ P.I 0, maxExUnits))
105-
submitTx_ @era tx
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
130+
submitFailingTx @era
131+
tx
132+
[ injectFailure $
133+
BabbageNonDisjointRefInputs
134+
( NE.fromList
135+
[ TxIn
136+
( TxId
137+
( unsafeMakeSafeHash . fromJust $
138+
hashFromTextAsHex
139+
"3b3a57c1fe445f8346b94a64ee39baf3f253e0932f37014c2735bb326d12be81"
140+
)
141+
)
142+
(TxIx 0)
143+
]
144+
)
145+
]
106146
where
107147
checkMinFee :: HasCallStack => NativeScript era -> [Script era] -> ImpTestM era ()
108148
checkMinFee scriptToSpend refScripts = do

‎libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/TreeDiff.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -233,4 +233,4 @@ requireExprEqualWithMessage fail_ message expected actual =
233233
if actual == expected then mempty else fail_ doc
234234
where
235235
doc = Pretty.width message (\w -> if w == 0 then diff else Pretty.line <> Pretty.indent 2 diff)
236-
diff = diffExpr expected actual
236+
diff = diffExpr actual expected

0 commit comments

Comments
 (0)