From 0d9272a9d96c914f73e7d0ed165c842deefe81d3 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 19 Jun 2026 16:15:55 +0200 Subject: [PATCH] Fix PlutusV4 script handling and scrambled ToPlutusScriptPurpose type family --- .../20260619_fix_plutusv4_script_handling.yml | 6 + .gitignore | 2 + cardano-api/src/Cardano/Api/Experimental.hs | 1 + .../src/Cardano/Api/Experimental/Plutus.hs | 1 + .../Experimental/Plutus/Internal/Script.hs | 1 + .../Plutus/Internal/Shim/LegacyScripts.hs | 8 +- .../Experimental/Tx/Internal/AnyWitness.hs | 2 +- .../src/Cardano/Api/Plutus/Internal/Script.hs | 39 +++--- .../cardano-api-test/Test/Cardano/Api/CBOR.hs | 117 +++++++----------- 9 files changed, 81 insertions(+), 96 deletions(-) create mode 100644 .changes/20260619_fix_plutusv4_script_handling.yml diff --git a/.changes/20260619_fix_plutusv4_script_handling.yml b/.changes/20260619_fix_plutusv4_script_handling.yml new file mode 100644 index 0000000000..22a16c8aeb --- /dev/null +++ b/.changes/20260619_fix_plutusv4_script_handling.yml @@ -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. diff --git a/.gitignore b/.gitignore index ee16bc3aa7..6ffc2ad642 100644 --- a/.gitignore +++ b/.gitignore @@ -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 diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs index e51ab07634..a66cc09d70 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -20,6 +20,7 @@ module Cardano.Api.Experimental , EraCommonConstraints , obtainConwayConstraints , obtainCommonConstraints + , obtainLangConstraints , eraProtVerHigh , hashTxBody , AnchorDataFromCertificateError (..) diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus.hs index 838c78b187..74b3b3c664 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus.hs @@ -19,6 +19,7 @@ module Cardano.Api.Experimental.Plutus , legacyWitnessConversion , toPlutusSLanguage , fromPlutusSLanguage + , obtainLangConstraints , mkLegacyPolicyId -- * Plutus Script Witness diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs index a6074df96c..cd2850f5b0 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs @@ -24,6 +24,7 @@ module Cardano.Api.Experimental.Plutus.Internal.Script , plutusScriptInEraToScript , plutusLanguageToText , textToPlutusLanguage + , obtainLangConstraints ) where diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Shim/LegacyScripts.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Shim/LegacyScripts.hs index f81dfd1029..9e72cab3de 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Shim/LegacyScripts.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Shim/LegacyScripts.hs @@ -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 convertToNewScriptWitness :: AlonzoEraOnwards era diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs index 264f2dcbc7..7af8ebe606 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs @@ -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 diff --git a/cardano-api/src/Cardano/Api/Plutus/Internal/Script.hs b/cardano-api/src/Cardano/Api/Plutus/Internal/Script.hs index dff230b9c7..45c235bc31 100644 --- a/cardano-api/src/Cardano/Api/Plutus/Internal/Script.hs +++ b/cardano-api/src/Cardano/Api/Plutus/Internal/Script.hs @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 fromShelleyBasedScript :: ShelleyBasedEra era @@ -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 diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs index 4a02dd0f0f..ff32bbfee0 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs @@ -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 prop_decode_only_wrapped_plutus_script_V2_ByteStringToInteger_CBOR :: Property 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 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 @@ -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 @@ -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 + ]