Skip to content

Commit 00616ab

Browse files
carbolymercarbolymer
authored
Merge pull request #1237 from IntersectMBO/mgalazyn/fix/fix-plutus-v4-bugs
Fix PlutusV4 script handling and scrambled `ToPlutusScriptPurpose` type family
2 parents 3423816 + 0d9272a commit 00616ab

9 files changed

Lines changed: 81 additions & 96 deletions

File tree

‎.changes/20260619_fix_plutusv4_script_handling.yml‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
project: cardano-api
2+
pr: 1237
3+
kind:
4+
- bugfix
5+
description: |
6+
Fix PlutusV4 scripts being mislabelled as V3 in several conversion functions, causing silent hash mismatches for V4 reference scripts. Fix `toShelleyScript` and `getPlutusDatum` crashing for V4. Fix scrambled `ToPlutusScriptPurpose` type family.

‎.gitignore‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -77,6 +77,8 @@ cardano-tracer/cardano-tracer-test
7777
# IntellIJ project folder
7878
.idea/
7979

80+
.serena/
81+
8082
cardano-wasm/examples/*/cardano-wasm.wasm
8183
cardano-wasm/examples/*/cardano-wasm.js
8284
cardano-wasm/examples/*/*.d.ts

‎cardano-api/src/Cardano/Api/Experimental.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ module Cardano.Api.Experimental
2020
, EraCommonConstraints
2121
, obtainConwayConstraints
2222
, obtainCommonConstraints
23+
, obtainLangConstraints
2324
, eraProtVerHigh
2425
, hashTxBody
2526
, AnchorDataFromCertificateError (..)

‎cardano-api/src/Cardano/Api/Experimental/Plutus.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ module Cardano.Api.Experimental.Plutus
1919
, legacyWitnessConversion
2020
, toPlutusSLanguage
2121
, fromPlutusSLanguage
22+
, obtainLangConstraints
2223
, mkLegacyPolicyId
2324

2425
-- * Plutus Script Witness

‎cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,7 @@ module Cardano.Api.Experimental.Plutus.Internal.Script
2424
, plutusScriptInEraToScript
2525
, plutusLanguageToText
2626
, textToPlutusLanguage
27+
, obtainLangConstraints
2728
)
2829
where
2930

‎cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Shim/LegacyScripts.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -75,11 +75,11 @@ toAnyWitness eon (witnessable, BuildTxWith (Old.ScriptWitness _ oldApiPlutusScri
7575

7676
type family ToPlutusScriptPurpose witnessable = (purpose :: PlutusScriptPurpose) | purpose -> witnessable where
7777
ToPlutusScriptPurpose TxInItem = SpendingScript
78-
ToPlutusScriptPurpose CertItem = MintingScript
79-
ToPlutusScriptPurpose MintItem = CertifyingScript
78+
ToPlutusScriptPurpose CertItem = CertifyingScript
79+
ToPlutusScriptPurpose MintItem = MintingScript
8080
ToPlutusScriptPurpose WithdrawalItem = WithdrawingScript
81-
ToPlutusScriptPurpose VoterItem = ProposingScript
82-
ToPlutusScriptPurpose ProposalItem = VotingScript
81+
ToPlutusScriptPurpose VoterItem = VotingScript
82+
ToPlutusScriptPurpose ProposalItem = ProposingScript
8383

8484
convertToNewScriptWitness
8585
:: AlonzoEraOnwards era

‎cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -125,7 +125,7 @@ getPlutusDatum
125125
getPlutusDatum L.SPlutusV1 (SpendingScriptDatum d) = Just d
126126
getPlutusDatum L.SPlutusV2 (SpendingScriptDatum d) = Just d
127127
getPlutusDatum L.SPlutusV3 (SpendingScriptDatum d) = d
128-
getPlutusDatum L.SPlutusV4 (SpendingScriptDatum _d) = error "TODO Dijkstra: getPlutusDatum: era not supported"
128+
getPlutusDatum L.SPlutusV4 (SpendingScriptDatum d) = d
129129
getPlutusDatum _ InlineDatum = Nothing
130130
getPlutusDatum _ NoScriptDatum = Nothing
131131

‎cardano-api/src/Cardano/Api/Plutus/Internal/Script.hs‎

Lines changed: 22 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -290,6 +290,7 @@ instance Enum AnyScriptLanguage where
290290
toEnum 1 = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV1)
291291
toEnum 2 = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV2)
292292
toEnum 3 = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV3)
293+
toEnum 4 = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV4)
293294
toEnum err = error $ "AnyScriptLanguage.toEnum: bad argument: " <> show err
294295

295296
fromEnum (AnyScriptLanguage SimpleScriptLanguage) = 0
@@ -300,7 +301,7 @@ instance Enum AnyScriptLanguage where
300301

301302
instance Bounded AnyScriptLanguage where
302303
minBound = AnyScriptLanguage SimpleScriptLanguage
303-
maxBound = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV3)
304+
maxBound = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV4)
304305

305306
data AnyPlutusScriptVersion where
306307
AnyPlutusScriptVersion
@@ -310,6 +311,12 @@ data AnyPlutusScriptVersion where
310311

311312
deriving instance (Show AnyPlutusScriptVersion)
312313

314+
instance Pretty AnyPlutusScriptVersion where
315+
pretty (AnyPlutusScriptVersion PlutusScriptV1) = "PlutusScriptV1"
316+
pretty (AnyPlutusScriptVersion PlutusScriptV2) = "PlutusScriptV2"
317+
pretty (AnyPlutusScriptVersion PlutusScriptV3) = "PlutusScriptV3"
318+
pretty (AnyPlutusScriptVersion PlutusScriptV4) = "PlutusScriptV4"
319+
313320
instance Eq AnyPlutusScriptVersion where
314321
a == b = fromEnum a == fromEnum b
315322

@@ -320,6 +327,7 @@ instance Enum AnyPlutusScriptVersion where
320327
toEnum 0 = AnyPlutusScriptVersion PlutusScriptV1
321328
toEnum 1 = AnyPlutusScriptVersion PlutusScriptV2
322329
toEnum 2 = AnyPlutusScriptVersion PlutusScriptV3
330+
toEnum 3 = AnyPlutusScriptVersion PlutusScriptV4
323331
toEnum err = error $ "AnyPlutusScriptVersion.toEnum: bad argument: " <> show err
324332

325333
fromEnum (AnyPlutusScriptVersion PlutusScriptV1) = 0
@@ -329,7 +337,7 @@ instance Enum AnyPlutusScriptVersion where
329337

330338
instance Bounded AnyPlutusScriptVersion where
331339
minBound = AnyPlutusScriptVersion PlutusScriptV1
332-
maxBound = AnyPlutusScriptVersion PlutusScriptV3
340+
maxBound = AnyPlutusScriptVersion PlutusScriptV4
333341

334342
instance ToCBOR AnyPlutusScriptVersion where
335343
toCBOR = toCBOR . fromEnum
@@ -358,7 +366,8 @@ parsePlutusScriptVersion t =
358366
"PlutusScriptV1" -> return (AnyPlutusScriptVersion PlutusScriptV1)
359367
"PlutusScriptV2" -> return (AnyPlutusScriptVersion PlutusScriptV2)
360368
"PlutusScriptV3" -> return (AnyPlutusScriptVersion PlutusScriptV3)
361-
_ -> fail "Expected PlutusScriptVX, for X = 1, 2, or 3"
369+
"PlutusScriptV4" -> return (AnyPlutusScriptVersion PlutusScriptV4)
370+
_ -> fail "Expected PlutusScriptVX, for X = 1, 2, 3, or 4"
362371

363372
instance FromJSON AnyPlutusScriptVersion where
364373
parseJSON = Aeson.withText "PlutusScriptVersion" parsePlutusScriptVersion
@@ -385,7 +394,7 @@ fromAlonzoLanguage :: Plutus.Language -> AnyPlutusScriptVersion
385394
fromAlonzoLanguage Plutus.PlutusV1 = AnyPlutusScriptVersion PlutusScriptV1
386395
fromAlonzoLanguage Plutus.PlutusV2 = AnyPlutusScriptVersion PlutusScriptV2
387396
fromAlonzoLanguage Plutus.PlutusV3 = AnyPlutusScriptVersion PlutusScriptV3
388-
fromAlonzoLanguage Plutus.PlutusV4 = AnyPlutusScriptVersion PlutusScriptV3
397+
fromAlonzoLanguage Plutus.PlutusV4 = AnyPlutusScriptVersion PlutusScriptV4
389398

390399
class HasTypeProxy lang => IsScriptLanguage lang where
391400
scriptLanguage :: ScriptLanguage lang
@@ -1294,20 +1303,16 @@ toShelleyScript
12941303
Plutus.PlutusBinary script
12951304
toShelleyScript
12961305
( ScriptInEra
1297-
_langInEra
1306+
langInEra
12981307
( PlutusScript
12991308
PlutusScriptV4
1300-
(PlutusScriptSerialised _script)
1309+
(PlutusScriptSerialised script)
13011310
)
1302-
) = error "toShelleyScript: PlutusV4 not implemented yet."
1303-
1304-
-- TODO: Ledger needs to introduce a plutusV4 constructor
1305-
-- case langInEra of
1306-
-- PlutusScriptV4InConway ->
1307-
-- Alonzo.PlutusScript . Conway.ConwayPlutusV3 . Plutus.Plutus $ Plutus.PlutusBinary script
1308-
-- PlutusScriptV4InDijkstra ->
1309-
-- Alonzo.PlutusScript . Dijkstra.MkDijkstraPlutusScript . Conway.ConwayPlutusV3 . Plutus.Plutus $
1310-
-- Plutus.PlutusBinary script
1311+
) =
1312+
case langInEra of
1313+
PlutusScriptV4InDijkstra ->
1314+
Alonzo.PlutusScript . Dijkstra.DijkstraPlutusV4 . Plutus.Plutus $
1315+
Plutus.PlutusBinary script
13111316

13121317
fromShelleyBasedScript
13131318
:: ShelleyBasedEra era
@@ -1391,8 +1396,8 @@ fromShelleyBasedScript sbe script =
13911396
$ PlutusScriptSerialised s
13921397
Dijkstra.DijkstraPlutusV4 (PlutusScriptBinary s) ->
13931398
ScriptInEra
1394-
PlutusScriptV3InDijkstra
1395-
. PlutusScript PlutusScriptV3
1399+
PlutusScriptV4InDijkstra
1400+
. PlutusScript PlutusScriptV4
13961401
$ PlutusScriptSerialised s
13971402
Alonzo.NativeScript s ->
13981403
ScriptInEra SimpleScriptInDijkstra

‎cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs‎

Lines changed: 43 additions & 74 deletions
Original file line numberDiff line numberDiff line change
@@ -325,32 +325,14 @@ prop_decode_only_double_wrapped_plutus_script_bytes_CBOR = H.property $ do
325325
alwaysSucceedsDoubleEncoded
326326
Ledger.SPlutusV3
327327

328-
prop_decode_only_wrapped_plutus_script_V1_CBOR :: Property
329-
prop_decode_only_wrapped_plutus_script_V1_CBOR = H.property $ do
330-
PlutusScriptSerialised shortBs <- H.forAll $ genPlutusScript PlutusScriptV1
331-
H.decodeOnlyPlutusScriptBytes
332-
ShelleyBasedEraConway
333-
PlutusScriptV1
334-
(SBS.fromShort shortBs)
335-
(AsScript AsPlutusScriptV1)
336-
337-
H.assertValidPlutusScriptBytesExperimental
338-
Exp.ConwayEra
339-
(SBS.fromShort shortBs)
340-
Ledger.SPlutusV1
341-
342-
prop_decode_only_wrapped_plutus_script_V2_CBOR :: Property
343-
prop_decode_only_wrapped_plutus_script_V2_CBOR = H.property $ do
344-
PlutusScriptSerialised shortBs <- H.forAll $ genPlutusScript PlutusScriptV2
345-
H.decodeOnlyPlutusScriptBytes
346-
ShelleyBasedEraConway
347-
PlutusScriptV2
348-
(SBS.fromShort shortBs)
349-
(AsScript AsPlutusScriptV2)
350-
H.assertValidPlutusScriptBytesExperimental
351-
Exp.ConwayEra
352-
(SBS.fromShort shortBs)
353-
Ledger.SPlutusV2
328+
mkPlutusScriptCBORTest :: Exp.Some Exp.Era -> AnyPlutusScriptVersion -> Property
329+
mkPlutusScriptCBORTest (Exp.Some era) (AnyPlutusScriptVersion version) = Exp.obtainCommonConstraints era $ H.property $ do
330+
PlutusScriptSerialised shortBs <- H.forAll $ genPlutusScript version
331+
let scriptBytes = SBS.fromShort shortBs
332+
let sLang = Exp.toPlutusSLanguage version
333+
Exp.obtainLangConstraints sLang $ do
334+
H.decodeOnlyPlutusScriptBytes (convert era) version scriptBytes (AsScript asType)
335+
H.assertValidPlutusScriptBytesExperimental era scriptBytes sLang
354336

355337
prop_decode_only_wrapped_plutus_script_V2_ByteStringToInteger_CBOR :: Property
356338
prop_decode_only_wrapped_plutus_script_V2_ByteStringToInteger_CBOR = H.property $ do
@@ -365,20 +347,6 @@ prop_decode_only_wrapped_plutus_script_V2_ByteStringToInteger_CBOR = H.property
365347
v2Special
366348
Ledger.SPlutusV2
367349

368-
prop_decode_only_wrapped_plutus_script_V3_CBOR :: Property
369-
prop_decode_only_wrapped_plutus_script_V3_CBOR = H.property $ do
370-
PlutusScriptSerialised shortBs <- H.forAll $ genPlutusScript PlutusScriptV3
371-
H.decodeOnlyPlutusScriptBytes
372-
ShelleyBasedEraConway
373-
PlutusScriptV3
374-
(SBS.fromShort shortBs)
375-
(AsScript AsPlutusScriptV3)
376-
377-
H.assertValidPlutusScriptBytesExperimental
378-
Exp.ConwayEra
379-
(SBS.fromShort shortBs)
380-
Ledger.SPlutusV3
381-
382350
prop_double_encoded_sanity_check :: Property
383351
prop_double_encoded_sanity_check = H.propertyOnce $ do
384352
let fixed = removePlutusScriptDoubleEncoding exampleDoubleEncodedBytes
@@ -560,8 +528,7 @@ prop_canonicalise_cbor = property $ do
560528

561529
tests :: TestTree
562530
tests =
563-
testGroup
564-
"Test.Cardano.Api.Typed.CBOR"
531+
testGroup "Test.Cardano.Api.Typed.CBOR" $
565532
[ testGroup
566533
"canonicalise CBOR"
567534
[ testProperty "unit canonicalise map" unit_canonicalise_map
@@ -640,36 +607,38 @@ tests =
640607
, testProperty
641608
"decode only double wrapped plutus script bytes CBOR"
642609
prop_decode_only_double_wrapped_plutus_script_bytes_CBOR
643-
, testProperty
644-
"decode only wrapped plutus script V1 CBOR"
645-
prop_decode_only_wrapped_plutus_script_V1_CBOR
646-
, testProperty
647-
"decode only wrapped plutus script V2 CBOR"
648-
prop_decode_only_wrapped_plutus_script_V2_CBOR
649-
, testProperty
650-
"decode only wrapped plutus script V2 special CBOR"
651-
prop_decode_only_wrapped_plutus_script_V2_ByteStringToInteger_CBOR
652-
, testProperty
653-
"decode only wrapped plutus script V3 CBOR"
654-
prop_decode_only_wrapped_plutus_script_V3_CBOR
655-
, testProperty
656-
"double encoded sanity check"
657-
prop_double_encoded_sanity_check
658-
, testProperty
659-
"cddlTypeToEra for Tx types"
660-
prop_Tx_cddlTypeToEra
661-
, testProperty
662-
"cddlTypeToEra for TxWitness types"
663-
prop_TxWitness_cddlTypeToEra
664-
, testProperty "roundtrip ScriptData CBOR" prop_roundtrip_ScriptData_CBOR
665-
, testProperty "roundtrip UpdateProposal CBOR" prop_roundtrip_UpdateProposal_CBOR
666-
, testProperty "roundtrip TxWitness Cddl" prop_roundtrip_TxWitness_Cddl
667-
, testProperty "roundtrip tx CBOR" prop_roundtrip_tx_CBOR
668-
, testProperty "roundtrip tx out CBOR" prop_roundtrip_tx_out_CBOR
669-
, testProperty
670-
"roundtrip GovernancePoll CBOR"
671-
prop_roundtrip_GovernancePoll_CBOR
672-
, testProperty
673-
"roundtrip GovernancePollAnswer CBOR"
674-
prop_roundtrip_GovernancePollAnswer_CBOR
675610
]
611+
<> [ testProperty
612+
("decode only wrapped plutus script " <> show (pretty version) <> " CBOR")
613+
(mkPlutusScriptCBORTest someEra version)
614+
| (someEra, version) <-
615+
[ (Exp.Some Exp.ConwayEra, AnyPlutusScriptVersion PlutusScriptV1)
616+
, (Exp.Some Exp.ConwayEra, AnyPlutusScriptVersion PlutusScriptV2)
617+
, (Exp.Some Exp.ConwayEra, AnyPlutusScriptVersion PlutusScriptV3)
618+
, (Exp.Some Exp.DijkstraEra, AnyPlutusScriptVersion PlutusScriptV4)
619+
]
620+
]
621+
<> [ testProperty
622+
"decode only wrapped plutus script V2 special CBOR"
623+
prop_decode_only_wrapped_plutus_script_V2_ByteStringToInteger_CBOR
624+
, testProperty
625+
"double encoded sanity check"
626+
prop_double_encoded_sanity_check
627+
, testProperty
628+
"cddlTypeToEra for Tx types"
629+
prop_Tx_cddlTypeToEra
630+
, testProperty
631+
"cddlTypeToEra for TxWitness types"
632+
prop_TxWitness_cddlTypeToEra
633+
, testProperty "roundtrip ScriptData CBOR" prop_roundtrip_ScriptData_CBOR
634+
, testProperty "roundtrip UpdateProposal CBOR" prop_roundtrip_UpdateProposal_CBOR
635+
, testProperty "roundtrip TxWitness Cddl" prop_roundtrip_TxWitness_Cddl
636+
, testProperty "roundtrip tx CBOR" prop_roundtrip_tx_CBOR
637+
, testProperty "roundtrip tx out CBOR" prop_roundtrip_tx_out_CBOR
638+
, testProperty
639+
"roundtrip GovernancePoll CBOR"
640+
prop_roundtrip_GovernancePoll_CBOR
641+
, testProperty
642+
"roundtrip GovernancePollAnswer CBOR"
643+
prop_roundtrip_GovernancePollAnswer_CBOR
644+
]

0 commit comments

Comments
 (0)