Skip to content

Fix PlutusV4 script handling and scrambled ToPlutusScriptPurpose type family #1237

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
carbolymer merged 1 commit into from
Jun 24, 2026
Merged

Fix PlutusV4 script handling and scrambled ToPlutusScriptPurpose type family #1237

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
6 changes: 6 additions & 0 deletions .changes/20260619_fix_plutusv4_script_handling.yml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,6 @@
project: cardano-api
pr: 1237
kind:
- bugfix
description: |
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.
2 changes: 2 additions & 0 deletions .gitignore
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -77,6 +77,8 @@ cardano-tracer/cardano-tracer-test
# IntellIJ project folder
.idea/

.serena/

cardano-wasm/examples/*/cardano-wasm.wasm
cardano-wasm/examples/*/cardano-wasm.js
cardano-wasm/examples/*/*.d.ts
Expand Down
1 change: 1 addition & 0 deletions cardano-api/src/Cardano/Api/Experimental.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -20,6 +20,7 @@ module Cardano.Api.Experimental
, EraCommonConstraints
, obtainConwayConstraints
, obtainCommonConstraints
, obtainLangConstraints
, eraProtVerHigh
, hashTxBody
, AnchorDataFromCertificateError (..)
Expand Down
1 change: 1 addition & 0 deletions cardano-api/src/Cardano/Api/Experimental/Plutus.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,7 @@ module Cardano.Api.Experimental.Plutus
, legacyWitnessConversion
, toPlutusSLanguage
, fromPlutusSLanguage
, obtainLangConstraints
, mkLegacyPolicyId

-- * Plutus Script Witness
Expand Down
1 change: 1 addition & 0 deletions cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -24,6 +24,7 @@ module Cardano.Api.Experimental.Plutus.Internal.Script
, plutusScriptInEraToScript
, plutusLanguageToText
, textToPlutusLanguage
, obtainLangConstraints
)
where

Expand Down
8 changes: 4 additions & 4 deletions cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Shim/LegacyScripts.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -75,11 +75,11 @@ toAnyWitness eon (witnessable, BuildTxWith (Old.ScriptWitness _ oldApiPlutusScri

type family ToPlutusScriptPurpose witnessable = (purpose :: PlutusScriptPurpose) | purpose -> witnessable where
ToPlutusScriptPurpose TxInItem = SpendingScript
ToPlutusScriptPurpose CertItem = MintingScript
ToPlutusScriptPurpose MintItem = CertifyingScript
ToPlutusScriptPurpose CertItem = CertifyingScript
ToPlutusScriptPurpose MintItem = MintingScript
ToPlutusScriptPurpose WithdrawalItem = WithdrawingScript
ToPlutusScriptPurpose VoterItem = ProposingScript
ToPlutusScriptPurpose ProposalItem = VotingScript
ToPlutusScriptPurpose VoterItem = VotingScript
ToPlutusScriptPurpose ProposalItem = ProposingScript

@carbolymer carbolymer Jun 19, 2026

Copy link
Copy Markdown
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm 99% sure that this was not right.


convertToNewScriptWitness
:: AlonzoEraOnwards era
Expand Down
2 changes: 1 addition & 1 deletion cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -125,7 +125,7 @@ getPlutusDatum
getPlutusDatum L.SPlutusV1 (SpendingScriptDatum d) = Just d
getPlutusDatum L.SPlutusV2 (SpendingScriptDatum d) = Just d
getPlutusDatum L.SPlutusV3 (SpendingScriptDatum d) = d
getPlutusDatum L.SPlutusV4 (SpendingScriptDatum _d) = error "TODO Dijkstra: getPlutusDatum: era not supported"
getPlutusDatum L.SPlutusV4 (SpendingScriptDatum d) = d
getPlutusDatum _ InlineDatum = Nothing
getPlutusDatum _ NoScriptDatum = Nothing

Expand Down
39 changes: 22 additions & 17 deletions cardano-api/src/Cardano/Api/Plutus/Internal/Script.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -290,6 +290,7 @@ instance Enum AnyScriptLanguage where
toEnum 1 = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV1)
toEnum 2 = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV2)
toEnum 3 = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV3)
toEnum 4 = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV4)
toEnum err = error $ "AnyScriptLanguage.toEnum: bad argument: " <> show err

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

instance Bounded AnyScriptLanguage where
minBound = AnyScriptLanguage SimpleScriptLanguage
maxBound = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV3)
maxBound = AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV4)

data AnyPlutusScriptVersion where
AnyPlutusScriptVersion
Expand All @@ -310,6 +311,12 @@ data AnyPlutusScriptVersion where

deriving instance (Show AnyPlutusScriptVersion)

instance Pretty AnyPlutusScriptVersion where
pretty (AnyPlutusScriptVersion PlutusScriptV1) = "PlutusScriptV1"
pretty (AnyPlutusScriptVersion PlutusScriptV2) = "PlutusScriptV2"
pretty (AnyPlutusScriptVersion PlutusScriptV3) = "PlutusScriptV3"
pretty (AnyPlutusScriptVersion PlutusScriptV4) = "PlutusScriptV4"

instance Eq AnyPlutusScriptVersion where
a == b = fromEnum a == fromEnum b

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

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

instance Bounded AnyPlutusScriptVersion where
minBound = AnyPlutusScriptVersion PlutusScriptV1
maxBound = AnyPlutusScriptVersion PlutusScriptV3
maxBound = AnyPlutusScriptVersion PlutusScriptV4

instance ToCBOR AnyPlutusScriptVersion where
toCBOR = toCBOR . fromEnum
Expand Down Expand Up @@ -358,7 +366,8 @@ parsePlutusScriptVersion t =
"PlutusScriptV1" -> return (AnyPlutusScriptVersion PlutusScriptV1)
"PlutusScriptV2" -> return (AnyPlutusScriptVersion PlutusScriptV2)
"PlutusScriptV3" -> return (AnyPlutusScriptVersion PlutusScriptV3)
_ -> fail "Expected PlutusScriptVX, for X = 1, 2, or 3"
"PlutusScriptV4" -> return (AnyPlutusScriptVersion PlutusScriptV4)
_ -> fail "Expected PlutusScriptVX, for X = 1, 2, 3, or 4"

instance FromJSON AnyPlutusScriptVersion where
parseJSON = Aeson.withText "PlutusScriptVersion" parsePlutusScriptVersion
Expand All @@ -385,7 +394,7 @@ fromAlonzoLanguage :: Plutus.Language -> AnyPlutusScriptVersion
fromAlonzoLanguage Plutus.PlutusV1 = AnyPlutusScriptVersion PlutusScriptV1
fromAlonzoLanguage Plutus.PlutusV2 = AnyPlutusScriptVersion PlutusScriptV2
fromAlonzoLanguage Plutus.PlutusV3 = AnyPlutusScriptVersion PlutusScriptV3
fromAlonzoLanguage Plutus.PlutusV4 = AnyPlutusScriptVersion PlutusScriptV3
fromAlonzoLanguage Plutus.PlutusV4 = AnyPlutusScriptVersion PlutusScriptV4

class HasTypeProxy lang => IsScriptLanguage lang where
scriptLanguage :: ScriptLanguage lang
Expand Down Expand Up @@ -1294,20 +1303,16 @@ toShelleyScript
Plutus.PlutusBinary script
toShelleyScript
( ScriptInEra
_langInEra
langInEra
( PlutusScript
PlutusScriptV4
(PlutusScriptSerialised _script)
(PlutusScriptSerialised script)
)
) = error "toShelleyScript: PlutusV4 not implemented yet."

-- TODO: Ledger needs to introduce a plutusV4 constructor
-- case langInEra of
-- PlutusScriptV4InConway ->
-- Alonzo.PlutusScript . Conway.ConwayPlutusV3 . Plutus.Plutus $ Plutus.PlutusBinary script
-- PlutusScriptV4InDijkstra ->
-- Alonzo.PlutusScript . Dijkstra.MkDijkstraPlutusScript . Conway.ConwayPlutusV3 . Plutus.Plutus $
-- Plutus.PlutusBinary script
) =
case langInEra of
PlutusScriptV4InDijkstra ->
Alonzo.PlutusScript . Dijkstra.DijkstraPlutusV4 . Plutus.Plutus $
Plutus.PlutusBinary script
Comment thread
carbolymer marked this conversation as resolved.

fromShelleyBasedScript
:: ShelleyBasedEra era
Expand Down Expand Up @@ -1391,8 +1396,8 @@ fromShelleyBasedScript sbe script =
$ PlutusScriptSerialised s
Dijkstra.DijkstraPlutusV4 (PlutusScriptBinary s) ->
ScriptInEra
PlutusScriptV3InDijkstra
. PlutusScript PlutusScriptV3
PlutusScriptV4InDijkstra
. PlutusScript PlutusScriptV4
$ PlutusScriptSerialised s
Alonzo.NativeScript s ->
ScriptInEra SimpleScriptInDijkstra
Expand Down
117 changes: 43 additions & 74 deletions cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -325,32 +325,14 @@ prop_decode_only_double_wrapped_plutus_script_bytes_CBOR = H.property $ do
alwaysSucceedsDoubleEncoded
Ledger.SPlutusV3

prop_decode_only_wrapped_plutus_script_V1_CBOR :: Property
prop_decode_only_wrapped_plutus_script_V1_CBOR = H.property $ do
PlutusScriptSerialised shortBs <- H.forAll $ genPlutusScript PlutusScriptV1
H.decodeOnlyPlutusScriptBytes
ShelleyBasedEraConway
PlutusScriptV1
(SBS.fromShort shortBs)
(AsScript AsPlutusScriptV1)

H.assertValidPlutusScriptBytesExperimental
Exp.ConwayEra
(SBS.fromShort shortBs)
Ledger.SPlutusV1

prop_decode_only_wrapped_plutus_script_V2_CBOR :: Property
prop_decode_only_wrapped_plutus_script_V2_CBOR = H.property $ do
PlutusScriptSerialised shortBs <- H.forAll $ genPlutusScript PlutusScriptV2
H.decodeOnlyPlutusScriptBytes
ShelleyBasedEraConway
PlutusScriptV2
(SBS.fromShort shortBs)
(AsScript AsPlutusScriptV2)
H.assertValidPlutusScriptBytesExperimental
Exp.ConwayEra
(SBS.fromShort shortBs)
Ledger.SPlutusV2
mkPlutusScriptCBORTest :: Exp.Some Exp.Era -> AnyPlutusScriptVersion -> Property
mkPlutusScriptCBORTest (Exp.Some era) (AnyPlutusScriptVersion version) = Exp.obtainCommonConstraints era $ H.property $ do
PlutusScriptSerialised shortBs <- H.forAll $ genPlutusScript version
let scriptBytes = SBS.fromShort shortBs
let sLang = Exp.toPlutusSLanguage version
Exp.obtainLangConstraints sLang $ do
H.decodeOnlyPlutusScriptBytes (convert era) version scriptBytes (AsScript asType)
H.assertValidPlutusScriptBytesExperimental era scriptBytes sLang
Comment thread
carbolymer marked this conversation as resolved.

prop_decode_only_wrapped_plutus_script_V2_ByteStringToInteger_CBOR :: Property
prop_decode_only_wrapped_plutus_script_V2_ByteStringToInteger_CBOR = H.property $ do
Expand All @@ -365,20 +347,6 @@ prop_decode_only_wrapped_plutus_script_V2_ByteStringToInteger_CBOR = H.property
v2Special
Ledger.SPlutusV2

prop_decode_only_wrapped_plutus_script_V3_CBOR :: Property
prop_decode_only_wrapped_plutus_script_V3_CBOR = H.property $ do
PlutusScriptSerialised shortBs <- H.forAll $ genPlutusScript PlutusScriptV3
H.decodeOnlyPlutusScriptBytes
ShelleyBasedEraConway
PlutusScriptV3
(SBS.fromShort shortBs)
(AsScript AsPlutusScriptV3)

H.assertValidPlutusScriptBytesExperimental
Exp.ConwayEra
(SBS.fromShort shortBs)
Ledger.SPlutusV3

prop_double_encoded_sanity_check :: Property
prop_double_encoded_sanity_check = H.propertyOnce $ do
let fixed = removePlutusScriptDoubleEncoding exampleDoubleEncodedBytes
Expand Down Expand Up @@ -560,8 +528,7 @@ prop_canonicalise_cbor = property $ do

tests :: TestTree
tests =
testGroup
"Test.Cardano.Api.Typed.CBOR"
testGroup "Test.Cardano.Api.Typed.CBOR" $
[ testGroup
"canonicalise CBOR"
[ testProperty "unit canonicalise map" unit_canonicalise_map
Expand Down Expand Up @@ -640,36 +607,38 @@ tests =
, testProperty
"decode only double wrapped plutus script bytes CBOR"
prop_decode_only_double_wrapped_plutus_script_bytes_CBOR
, testProperty
"decode only wrapped plutus script V1 CBOR"
prop_decode_only_wrapped_plutus_script_V1_CBOR
, testProperty
"decode only wrapped plutus script V2 CBOR"
prop_decode_only_wrapped_plutus_script_V2_CBOR
, testProperty
"decode only wrapped plutus script V2 special CBOR"
prop_decode_only_wrapped_plutus_script_V2_ByteStringToInteger_CBOR
, testProperty
"decode only wrapped plutus script V3 CBOR"
prop_decode_only_wrapped_plutus_script_V3_CBOR
, testProperty
"double encoded sanity check"
prop_double_encoded_sanity_check
, testProperty
"cddlTypeToEra for Tx types"
prop_Tx_cddlTypeToEra
, testProperty
"cddlTypeToEra for TxWitness types"
prop_TxWitness_cddlTypeToEra
, testProperty "roundtrip ScriptData CBOR" prop_roundtrip_ScriptData_CBOR
, testProperty "roundtrip UpdateProposal CBOR" prop_roundtrip_UpdateProposal_CBOR
, testProperty "roundtrip TxWitness Cddl" prop_roundtrip_TxWitness_Cddl
, testProperty "roundtrip tx CBOR" prop_roundtrip_tx_CBOR
, testProperty "roundtrip tx out CBOR" prop_roundtrip_tx_out_CBOR
, testProperty
"roundtrip GovernancePoll CBOR"
prop_roundtrip_GovernancePoll_CBOR
, testProperty
"roundtrip GovernancePollAnswer CBOR"
prop_roundtrip_GovernancePollAnswer_CBOR
]
<> [ testProperty
("decode only wrapped plutus script " <> show (pretty version) <> " CBOR")
(mkPlutusScriptCBORTest someEra version)
| (someEra, version) <-
[ (Exp.Some Exp.ConwayEra, AnyPlutusScriptVersion PlutusScriptV1)
, (Exp.Some Exp.ConwayEra, AnyPlutusScriptVersion PlutusScriptV2)
, (Exp.Some Exp.ConwayEra, AnyPlutusScriptVersion PlutusScriptV3)
, (Exp.Some Exp.DijkstraEra, AnyPlutusScriptVersion PlutusScriptV4)
]
]
<> [ testProperty
"decode only wrapped plutus script V2 special CBOR"
prop_decode_only_wrapped_plutus_script_V2_ByteStringToInteger_CBOR
, testProperty
"double encoded sanity check"
prop_double_encoded_sanity_check
, testProperty
"cddlTypeToEra for Tx types"
prop_Tx_cddlTypeToEra
, testProperty
"cddlTypeToEra for TxWitness types"
prop_TxWitness_cddlTypeToEra
, testProperty "roundtrip ScriptData CBOR" prop_roundtrip_ScriptData_CBOR
, testProperty "roundtrip UpdateProposal CBOR" prop_roundtrip_UpdateProposal_CBOR
, testProperty "roundtrip TxWitness Cddl" prop_roundtrip_TxWitness_Cddl
, testProperty "roundtrip tx CBOR" prop_roundtrip_tx_CBOR
, testProperty "roundtrip tx out CBOR" prop_roundtrip_tx_out_CBOR
, testProperty
"roundtrip GovernancePoll CBOR"
prop_roundtrip_GovernancePoll_CBOR
, testProperty
"roundtrip GovernancePollAnswer CBOR"
prop_roundtrip_GovernancePollAnswer_CBOR
]
Loading