diff --git a/.changes/experimental-tx-unsupported-plutus-language-error.yml b/.changes/experimental-tx-unsupported-plutus-language-error.yml index add22b86ed..868611b3f1 100644 --- a/.changes/experimental-tx-unsupported-plutus-language-error.yml +++ b/.changes/experimental-tx-unsupported-plutus-language-error.yml @@ -4,7 +4,15 @@ kind: - breaking - bugfix description: | - `makeUnsignedTx` now fails with `MakeUnsignedTxPlutusLanguageNotSupportedInEra` when an inline Plutus script uses a language the era does not support. - Before, the script was silently dropped from the witness set while its redeemer was kept, so the transaction failed on submission. - `getAnyWitnessScript` and `getAnyPlutusWitnessPlutusScript` now return `Either L.Language` instead of `Maybe`. - `getTxScriptWitnessRequirements` and `getTxScriptWitnessesRequirements` now return `Either L.Language (TxScriptWitnessRequirements era)` instead of `TxScriptWitnessRequirements era`. + A `PlutusScriptInEra` can now only be built from a `PlutusLangInEra lang era` proof that the era supports the script language. + The proof is a single-constructor GADT that holds the language singleton, and its context is the ledger's `EraPlutusTxInfo lang era` class, so cardano-api holds no table of its own. + So you cannot put a Plutus script in an experimental transaction if the era does not support its language. + Before, such a script was silently dropped from the witness set while its redeemer was kept, so the transaction failed on submission. + The check happens once at deserialisation: `decodeAnyPlutusScript`, `deserialiseAnyPlutusScriptFromTextEnvelope` and the `SerialiseAsCBOR` instance for `AnyScript` reject an unsupported language. + The `SerialiseAsCBOR` and `HasTextEnvelope` instances of `PlutusScriptInEra` exist only for language and era pairings the ledger supports, so a wrong pairing is a compile error. + `PlutusScriptInEra` now holds the ledger script next to the runnable, built by the new `mkPlutusScriptInEra` function. + `mkPlutusScriptInEra`, `deserialisePlutusScriptInEra` and `deserialiseAnyPlutusScriptOfLanguage` take the ledger's `EraPlutusTxInfo lang era` constraint and cannot fail on the language. + The new `plutusLangInShelleyBasedEra` function and the new `HasPlutusLangInEra` class give this proof to code that learns the language only at runtime. + They ask the ledger's `mkSupportedLanguage`, so cardano-api keeps no table at runtime either. + `deserialisePlutusScriptInEra` and `deserialiseAnyPlutusScriptOfLanguage` no longer take the language singleton. + `EraCommonConstraints` now includes `HasPlutusLangInEra (LedgerEra era)`. diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 3ffe96b917..12aa109de0 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -230,6 +230,7 @@ library Cardano.Api.Era.Internal.Eon.ShelleyToBabbageEra Cardano.Api.Era.Internal.Feature Cardano.Api.Experimental.Plutus.Internal.IndexedPlutusScriptWitness + Cardano.Api.Experimental.Plutus.Internal.Language Cardano.Api.Experimental.Plutus.Internal.Script Cardano.Api.Experimental.Plutus.Internal.ScriptWitness Cardano.Api.Experimental.Plutus.Internal.Shim.LegacyScripts diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 7623a9ec0a..3afc8894ee 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -1524,7 +1524,7 @@ genPlutusScriptInEra = do v3AlwaysSucceedsPlutusScriptHex <- Gen.element [v3AlwaysSucceedsPlutusScript, v3AlwaysSucceedsPlutusScriptDoubleEncoded] let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex - case Exp.deserialisePlutusScriptInEra L.SPlutusV3 v3ScriptBytes of + case Exp.deserialisePlutusScriptInEra v3ScriptBytes of Right p -> return p Left e -> error $ show e diff --git a/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs b/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs index aaa78242e5..da6a5c4a0c 100644 --- a/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs +++ b/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs @@ -101,7 +101,6 @@ decodeOnlyPlutusScriptBytes _ _ scriptBytes typeProxy = do assertValidPlutusScriptBytesExperimental :: forall era lang m . H.MonadTest m - => HasTypeProxy (Plutus.SLanguage lang) => Plutus.PlutusLanguage lang => Exp.Era era -> ByteString @@ -111,7 +110,11 @@ assertValidPlutusScriptBytesExperimental assertValidPlutusScriptBytesExperimental era scriptBytes lang = do -- Decode a plutus script (double wrapped or "normal" plutus script) with the existing SerialiseAsCBOR instance for -- 'Script lang'. This should produce plutus script bytes that are not double encoded. - case Exp.obtainCommonConstraints era $ Exp.deserialisePlutusScriptInEra lang scriptBytes - :: Either DecoderError (Exp.PlutusScriptInEra lang (Exp.LedgerEra era)) of - Left e -> failWith Nothing $ "Plutus lang: Error decoding script bytes: " ++ show (e :: DecoderError) - Right (Exp.PlutusScriptInEra{}) -> H.success + Exp.obtainCommonConstraints era $ + case Exp.plutusLangInEra @(Exp.LedgerEra era) lang of + Nothing -> failWith Nothing "Plutus lang: language not supported in era" + Just (Exp.PlutusLangInEra _) -> + case Exp.deserialisePlutusScriptInEra scriptBytes + :: Either DecoderError (Exp.PlutusScriptInEra lang (Exp.LedgerEra era)) of + Left e -> failWith Nothing $ "Plutus lang: Error decoding script bytes: " ++ show (e :: DecoderError) + Right (Exp.PlutusScriptInEra{}) -> H.success diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs index c460c78667..2d57c71355 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -92,6 +92,10 @@ module Cardano.Api.Experimental -- ** Plutus related , AnyPlutusScriptLanguage (..) , PlutusScriptInEra (..) + , mkPlutusScriptInEra + , PlutusLangInEra (..) + , HasPlutusLangInEra (..) + , plutusLangInShelleyBasedEra , PlutusScriptOrReferenceInput (..) , serialiseAnyPlutusScriptToTextEnvelope , deserialiseAnyPlutusScriptFromTextEnvelope diff --git a/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs b/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs index 87e7c01be2..634d578597 100644 --- a/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs +++ b/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -38,6 +39,7 @@ import Cardano.Api.Serialise.Json (JsonDecodeError (..), deserialiseFromJSON) import Cardano.Api.Serialise.TextEnvelope (TextEnvelope (..), TextEnvelopeType (..)) import Cardano.Api.Serialise.TextEnvelope.Internal (textEnvelopeType) +import Cardano.Ledger.Alonzo.Plutus.Context qualified as L (EraPlutusTxInfo) import Cardano.Ledger.Binary qualified as CBOR import Cardano.Ledger.Core qualified as L import Cardano.Ledger.Plutus.Language qualified as Plutus @@ -74,10 +76,7 @@ instance Eq (AnyScript era) where Nothing -> False _ == _ = False -instance - L.AlonzoEraScript era - => SerialiseAsCBOR (AnyScript era) - where +instance L.AlonzoEraScript era => SerialiseAsCBOR (AnyScript era) where serialiseToCBOR (AnySimpleScript (SimpleScript ns)) = L.serialize' (L.eraProtVerHigh @era) (L.fromNativeScript ns :: L.Script era) serialiseToCBOR (AnyPlutusScript ps) = @@ -102,10 +101,10 @@ instance tryPlutusScript :: L.Script era -> Maybe (AnyScript era) tryPlutusScript script = do ps <- L.toPlutusScript script - L.withPlutusScript ps $ \(plutus :: Plutus.Plutus l) -> + L.withPlutusScript ps $ \plutus -> do let plutusRunnable = Plutus.decodePlutusRunnable (L.eraProtVerHigh @era) plutus - in AnyPlutusScript . PlutusScriptInEra - <$> (plutusRunnable <$ rightToMaybe (Plutus.plutusRunnableResult plutusRunnable)) + AnyPlutusScript (PlutusScriptInEra plutusRunnable ps) + <$ rightToMaybe (Plutus.plutusRunnableResult plutusRunnable) noParseError :: CBOR.DecoderError noParseError = @@ -124,14 +123,14 @@ deserialiseAnySimpleScript deserialiseAnySimpleScript bs = AnySimpleScript <$> obtainCommonConstraints (useEra @era) (deserialiseSimpleScript bs) +-- | Decode a Plutus script. The 'L.EraPlutusTxInfo' constraint fixes both the language +-- and the era, so only malformed bytes fail. deserialiseAnyPlutusScriptOfLanguage :: forall era lang - . (IsEra era, Plutus.PlutusLanguage lang, HasTypeProxy (Plutus.SLanguage lang)) - => BS.ByteString -> L.SLanguage lang -> Either CBOR.DecoderError (AnyScript (LedgerEra era)) -deserialiseAnyPlutusScriptOfLanguage bs lang = do - s :: (PlutusScriptInEra lang (LedgerEra era)) <- - obtainCommonConstraints (useEra @era) (deserialisePlutusScriptInEra lang bs) - return $ AnyPlutusScript s + . L.EraPlutusTxInfo lang (LedgerEra era) + => BS.ByteString -> Either CBOR.DecoderError (AnyScript (LedgerEra era)) +deserialiseAnyPlutusScriptOfLanguage bs = + AnyPlutusScript <$> deserialisePlutusScriptInEra @(LedgerEra era) @lang bs data AnyScriptDecodeError = -- | A text envelope was decoded, but its Plutus CBOR payload could not be. diff --git a/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs b/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs index 73e1f0d86d..a158b13ca4 100644 --- a/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs +++ b/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs @@ -233,55 +233,28 @@ getAnyPlutusScriptData AnyPlutusCertifyingScriptWitness{} = mempty getAnyPlutusScriptData AnyPlutusProposingScriptWitness{} = mempty getAnyPlutusScriptData AnyPlutusVotingScriptWitness{} = mempty --- | Resolves the ledger script for a Plutus witness. --- A reference witness has no script to resolve here, so it returns @Right Nothing@. --- An inline witness returns @Right (Just script)@, or @Left lang@ when the era rejects the language. getAnyPlutusWitnessPlutusScript - :: L.AlonzoEraScript era - => AnyPlutusScriptWitness lang purpose era - -> Either L.Language (Maybe (L.Script era)) + :: AnyPlutusScriptWitness lang purpose era + -> Maybe (L.Script era) getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV1 s)) = - resolvePlutusWitnessScript L.SPlutusV1 s + resolvePlutusWitnessScript s getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV2 s)) = - resolvePlutusWitnessScript L.SPlutusV2 s + resolvePlutusWitnessScript s getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV3 s)) = - resolvePlutusWitnessScript L.SPlutusV3 s + resolvePlutusWitnessScript s getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV4 s)) = - resolvePlutusWitnessScript L.SPlutusV4 s -getAnyPlutusWitnessPlutusScript (AnyPlutusMintingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) = - resolvePlutusWitnessScript l s -getAnyPlutusWitnessPlutusScript (AnyPlutusWithdrawingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) = - resolvePlutusWitnessScript l s -getAnyPlutusWitnessPlutusScript (AnyPlutusCertifyingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) = - resolvePlutusWitnessScript l s -getAnyPlutusWitnessPlutusScript (AnyPlutusProposingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) = - resolvePlutusWitnessScript l s -getAnyPlutusWitnessPlutusScript (AnyPlutusVotingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) = - resolvePlutusWitnessScript l s + resolvePlutusWitnessScript s +getAnyPlutusWitnessPlutusScript (AnyPlutusMintingScriptWitness s) = resolvePlutusWitnessScript s +getAnyPlutusWitnessPlutusScript (AnyPlutusWithdrawingScriptWitness s) = resolvePlutusWitnessScript s +getAnyPlutusWitnessPlutusScript (AnyPlutusCertifyingScriptWitness s) = resolvePlutusWitnessScript s +getAnyPlutusWitnessPlutusScript (AnyPlutusProposingScriptWitness s) = resolvePlutusWitnessScript s +getAnyPlutusWitnessPlutusScript (AnyPlutusVotingScriptWitness s) = resolvePlutusWitnessScript s +-- | A reference witness carries no script, so it resolves to 'Nothing'. +-- An inline witness holds the ledger script, built when its era was checked. resolvePlutusWitnessScript - :: L.AlonzoEraScript era - => L.SLanguage lang - -> PlutusScriptWitness lang purpose era - -> Either L.Language (Maybe (L.Script era)) -resolvePlutusWitnessScript slang s = - case getPlutusScriptRunnable s of - Nothing -> Right Nothing - Just runnable -> Just . L.fromPlutusScript <$> fromPlutusRunnable slang runnable - --- | 'PlutusRunnable' is built by deserialisation in the ledger, which rejects a language --- the era does not support. That case is returned as 'Left' with the language. -fromPlutusRunnable - :: forall era lang - . L.AlonzoEraScript era - => L.SLanguage lang - -> L.PlutusRunnable lang - -> Either L.Language (L.PlutusScript era) -fromPlutusRunnable slang = case slang of - L.SPlutusV1 -> go - L.SPlutusV2 -> go - L.SPlutusV3 -> go - L.SPlutusV4 -> go - where - go :: L.PlutusLanguage lang => L.PlutusRunnable lang -> Either L.Language (L.PlutusScript era) - go = maybe (Left $ L.plutusLanguage slang) Right . L.mkPlutusScript . L.plutusFromRunnable + :: PlutusScriptWitness lang purpose era + -> Maybe (L.Script era) +resolvePlutusWitnessScript (PlutusScriptWitness _ (PScript s) _ _ _) = + Just $ plutusScriptInEraToScript s +resolvePlutusWitnessScript (PlutusScriptWitness _ PReferenceScript{} _ _ _) = Nothing diff --git a/cardano-api/src/Cardano/Api/Experimental/Era.hs b/cardano-api/src/Cardano/Api/Experimental/Era.hs index 6ee036d527..32c9142155 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Era.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Era.hs @@ -46,6 +46,7 @@ import Cardano.Api.Era.Internal.Eon.ConwayEraOnwards import Cardano.Api.Era.Internal.Eon.MaryEraOnwards import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra (ShelleyBasedEra (..), ShelleyLedgerEra) import Cardano.Api.Error +import Cardano.Api.Experimental.Plutus.Internal.Language (HasPlutusLangInEra) import Cardano.Api.HasTypeProxy import Cardano.Api.Ledger.Internal.Reexport qualified as L import Cardano.Api.Pretty.Internal.ShowOf @@ -318,6 +319,7 @@ type EraCommonConstraints era = , L.EraTxCert (LedgerEra era) , L.EraTxOut (LedgerEra era) , L.EraUTxO (LedgerEra era) + , HasPlutusLangInEra (LedgerEra era) , HasTypeProxy era , Ord (L.PlutusPurpose L.AsIx (LedgerEra era)) , L.GovState (LedgerEra era) ~ L.ConwayGovState (LedgerEra era) diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus.hs index b46384f942..3cf9c5b9f4 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus.hs @@ -5,6 +5,10 @@ module Cardano.Api.Experimental.Plutus , serialiseAnyPlutusScriptToTextEnvelope , deserialiseAnyPlutusScriptFromTextEnvelope , PlutusScriptInEra (..) + , mkPlutusScriptInEra + , PlutusLangInEra (..) + , HasPlutusLangInEra (..) + , plutusLangInShelleyBasedEra , AnyPlutusScriptLanguage (..) , deserialisePlutusScriptInEra , hashPlutusScriptInEra diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Language.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Language.hs new file mode 100644 index 0000000000..107c5eb179 --- /dev/null +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Language.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} + +-- | Which Plutus languages each ledger era accepts. +-- +-- The table is the ledger's 'L.EraPlutusTxInfo' instances, one per language and era it supports. +-- The runtime lookup is the ledger's 'L.mkSupportedLanguage'. +module Cardano.Api.Experimental.Plutus.Internal.Language + ( PlutusLangInEra (..) + , HasPlutusLangInEra (..) + , plutusLangInShelleyBasedEra + ) +where + +import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra (ShelleyBasedEra (..), ShelleyLedgerEra) + +import Cardano.Ledger.Alonzo.Plutus.Context qualified as L + ( EraPlutusContext (..) + , EraPlutusTxInfo + , SupportedLanguage (..) + ) +import Cardano.Ledger.Api qualified as L +import Cardano.Ledger.Plutus.Language qualified as L + +import Data.Typeable (eqT, (:~:) (Refl)) + +-- | Evidence that the ledger era @era@ accepts Plutus scripts of @lang@. +-- The ledger's 'L.EraPlutusTxInfo' instances are the table; matching gives 'L.AlonzoEraScript'. +data PlutusLangInEra (lang :: L.Language) era where + PlutusLangInEra :: L.EraPlutusTxInfo lang era => L.SLanguage lang -> PlutusLangInEra lang era + +deriving instance Show (PlutusLangInEra lang era) + +deriving instance Eq (PlutusLangInEra lang era) + +-- | The runtime side of the table, for code that learns the language late. +plutusLangInShelleyBasedEra + :: L.PlutusLanguage lang + => ShelleyBasedEra era + -> L.SLanguage lang + -> Maybe (PlutusLangInEra lang (ShelleyLedgerEra era)) +plutusLangInShelleyBasedEra sbe slang = case sbe of + ShelleyBasedEraShelley -> Nothing + ShelleyBasedEraAllegra -> Nothing + ShelleyBasedEraMary -> Nothing + ShelleyBasedEraAlonzo -> supportedLanguageProof slang + ShelleyBasedEraBabbage -> supportedLanguageProof slang + ShelleyBasedEraConway -> supportedLanguageProof slang + ShelleyBasedEraDijkstra -> supportedLanguageProof slang + +-- | Ask the ledger whether the era runs the language and keep its proof. +supportedLanguageProof + :: forall era lang + . (L.EraPlutusContext era, L.PlutusLanguage lang) + => L.SLanguage lang -> Maybe (PlutusLangInEra lang era) +supportedLanguageProof slang = do + L.SupportedLanguage (_ :: L.SLanguage l) <- L.mkSupportedLanguage @era (L.plutusLanguage slang) + Refl <- eqT @lang @l + pure $ PlutusLangInEra slang + +-- | Hands out a 'PlutusLangInEra' proof for code that only has the ledger era type, +-- by asking the ledger's 'L.mkSupportedLanguage'. Eras before Alonzo always give 'Nothing'. +-- +-- With the language known only at the type level, take the singleton from 'L.PlutusLanguage': +-- +-- > case plutusLangInEra @era (L.isLanguage @lang) of +-- > Just (PlutusLangInEra _) -> -- the era runs the language, 'L.EraPlutusTxInfo' is in scope +-- > Nothing -> -- it does not +-- +-- When the pairing is static and supported, 'L.EraPlutusTxInfo' already holds and the proof +-- needs no lookup: +-- +-- > PlutusLangInEra L.isLanguage :: PlutusLangInEra lang era +class HasPlutusLangInEra era where + plutusLangInEra :: L.PlutusLanguage lang => L.SLanguage lang -> Maybe (PlutusLangInEra lang era) + +instance HasPlutusLangInEra L.ShelleyEra where + plutusLangInEra = plutusLangInShelleyBasedEra ShelleyBasedEraShelley + +instance HasPlutusLangInEra L.AllegraEra where + plutusLangInEra = plutusLangInShelleyBasedEra ShelleyBasedEraAllegra + +instance HasPlutusLangInEra L.MaryEra where + plutusLangInEra = plutusLangInShelleyBasedEra ShelleyBasedEraMary + +instance HasPlutusLangInEra L.AlonzoEra where + plutusLangInEra = plutusLangInShelleyBasedEra ShelleyBasedEraAlonzo + +instance HasPlutusLangInEra L.BabbageEra where + plutusLangInEra = plutusLangInShelleyBasedEra ShelleyBasedEraBabbage + +instance HasPlutusLangInEra L.ConwayEra where + plutusLangInEra = plutusLangInShelleyBasedEra ShelleyBasedEraConway + +instance HasPlutusLangInEra L.DijkstraEra where + plutusLangInEra = plutusLangInShelleyBasedEra ShelleyBasedEraDijkstra 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 a0c942507c..fcdf6f5dc9 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -15,9 +16,14 @@ module Cardano.Api.Experimental.Plutus.Internal.Script , deserialiseAnyPlutusScriptFromTextEnvelope , AnyPlutusScriptLanguage (..) , PlutusScriptInEra (..) + , mkPlutusScriptInEra + , PlutusLangInEra (..) + , HasPlutusLangInEra (..) + , plutusLangInShelleyBasedEra , PlutusScriptOrReferenceInput (..) , AsType (..) , deserialisePlutusScriptInEra + , plutusLanguageNotSupportedInEraError , hashPlutusScriptInEra , plutusScriptInEraLanguage , plutusScriptInEraSLanguage @@ -29,6 +35,7 @@ module Cardano.Api.Experimental.Plutus.Internal.Script where import Cardano.Api.Experimental.Era +import Cardano.Api.Experimental.Plutus.Internal.Language import Cardano.Api.HasTypeProxy import Cardano.Api.Ledger.Internal.Reexport qualified as L import Cardano.Api.Plutus.Internal.Script (removePlutusScriptDoubleEncoding) @@ -37,6 +44,10 @@ import Cardano.Api.Serialise.TextEnvelope.Internal import Cardano.Api.Tx.Internal.TxIn (TxIn) import Cardano.Binary qualified as CBOR +import Cardano.Ledger.Alonzo.Plutus.Context qualified as L + ( EraPlutusTxInfo + , mkSupportedPlutusScript + ) import Cardano.Ledger.Core qualified as L import Cardano.Ledger.Plutus.Language (PlutusRunnable) import Cardano.Ledger.Plutus.Language qualified as L @@ -68,13 +79,26 @@ import Prettyprinter -- Where do we get the script language from? -- The serialized version of 'PlutusRunnable' encodes the script language. -- See `DecCBOR (PlutusRunnable l)` in cardano-ledger for more details. +-- +-- The second field is the same script as the ledger holds it. Build values with +-- 'mkPlutusScriptInEra', since only a supported language and era pairing has one. data PlutusScriptInEra (lang :: L.Language) era where - PlutusScriptInEra :: L.PlutusLanguage lang => PlutusRunnable lang -> PlutusScriptInEra lang era + PlutusScriptInEra + :: (L.PlutusLanguage lang, L.AlonzoEraScript era) + => PlutusRunnable lang + -> L.PlutusScript era + -> PlutusScriptInEra lang era deriving instance Show (PlutusScriptInEra lang era) deriving instance Eq (PlutusScriptInEra lang era) +-- | Build a script the ledger accepts in the era. +mkPlutusScriptInEra + :: L.EraPlutusTxInfo lang era => PlutusRunnable lang -> PlutusScriptInEra lang era +mkPlutusScriptInEra runnable = + PlutusScriptInEra runnable $ L.mkSupportedPlutusScript (L.plutusFromRunnable runnable) + instance (Typeable era, Typeable lang, HasTypeProxy (Plutus.SLanguage lang)) => HasTypeProxy (PlutusScriptInEra lang era) @@ -83,7 +107,11 @@ instance proxyToAsType _ = AsPlutusScriptInEra (proxyToAsType (Proxy @(L.SLanguage lang))) instance - (Plutus.PlutusLanguage lang, L.Era era, HasTypeProxy (Plutus.SLanguage lang)) + ( Plutus.PlutusLanguage lang + , L.Era era + , L.EraPlutusTxInfo lang era + , HasTypeProxy (Plutus.SLanguage lang) + ) => HasTextEnvelope (PlutusScriptInEra lang era) where textEnvelopeTypes _ = @@ -113,7 +141,7 @@ instance ( L.Era era , Typeable era , Typeable lang - , Plutus.PlutusLanguage lang + , L.EraPlutusTxInfo lang era , HasTypeProxy (Plutus.SLanguage lang) ) => SerialiseAsCBOR (PlutusScriptInEra (lang :: L.Language) era) @@ -121,57 +149,52 @@ instance -- The 'PlutusBinary' stored in the 'PlutusRunnable' already contains -- CBOR-wrapped Flat-encoded UPLC bytes (see 'Cardano.Ledger.Plutus.Language'), -- so we extract them directly rather than re-encoding with 'L.serialize''. - serialiseToCBOR (PlutusScriptInEra s) = + serialiseToCBOR (PlutusScriptInEra s _) = SBS.fromShort . L.unPlutusBinary . L.plutusBinary $ L.plutusFromRunnable s - deserialiseFromCBOR _ bs = do - let v = L.eraProtVerHigh @era - scriptShortBs = SBS.toShort $ removePlutusScriptDoubleEncoding $ LBS.fromStrict bs - let plutusScript :: Plutus.Plutus lang - plutusScript = L.Plutus $ L.PlutusBinary scriptShortBs - - let plutusRunnable = Plutus.decodePlutusRunnable v plutusScript - case Plutus.plutusRunnableResult plutusRunnable of - Left e -> - Left $ - CBOR.DecoderErrorCustom "PlutusLedgerApi.Common.ScriptDecodeError" (Text.pack . show $ pretty e) - Right{} -> Right $ PlutusScriptInEra plutusRunnable + deserialiseFromCBOR _ = deserialisePlutusScriptInEra +-- | Decode a script of a language the era supports. The 'L.EraPlutusTxInfo' +-- constraint is the proof, so only malformed bytes fail. deserialisePlutusScriptInEra :: forall era lang - . (Plutus.PlutusLanguage lang, HasTypeProxy (Plutus.SLanguage lang)) - => L.Era era - => L.SLanguage lang - -> BS.ByteString + . L.EraPlutusTxInfo lang era + => BS.ByteString -> Either CBOR.DecoderError (PlutusScriptInEra lang era) -deserialisePlutusScriptInEra _ bs = - deserialiseFromCBOR (AsPlutusScriptInEra (proxyToAsType (Proxy @(L.SLanguage lang)))) bs +deserialisePlutusScriptInEra bs = do + let v = L.eraProtVerHigh @era + scriptShortBs = SBS.toShort $ removePlutusScriptDoubleEncoding $ LBS.fromStrict bs + let plutusScript :: Plutus.Plutus lang + plutusScript = L.Plutus $ L.PlutusBinary scriptShortBs + + let plutusRunnable = Plutus.decodePlutusRunnable v plutusScript + case Plutus.plutusRunnableResult plutusRunnable of + Left e -> + Left $ + CBOR.DecoderErrorCustom "PlutusLedgerApi.Common.ScriptDecodeError" (Text.pack . show $ pretty e) + Right{} -> pure $ mkPlutusScriptInEra plutusRunnable hashPlutusScriptInEra :: forall era lang. IsEra era => PlutusScriptInEra lang (LedgerEra era) -> L.ScriptHash -hashPlutusScriptInEra (PlutusScriptInEra pr) = +hashPlutusScriptInEra (PlutusScriptInEra pr _) = case useEra @era of ConwayEra -> L.hashPlutusScript $ L.plutusFromRunnable pr DijkstraEra -> L.hashPlutusScript $ L.plutusFromRunnable pr plutusScriptInEraSLanguage :: forall lang era. L.PlutusLanguage lang => PlutusScriptInEra lang era -> L.SLanguage lang -plutusScriptInEraSLanguage (PlutusScriptInEra _) = +plutusScriptInEraSLanguage PlutusScriptInEra{} = L.plutusSLanguage (Proxy @lang) plutusScriptInEraLanguage :: forall lang era. L.PlutusLanguage lang => PlutusScriptInEra lang era -> L.Language -plutusScriptInEraLanguage (PlutusScriptInEra _) = +plutusScriptInEraLanguage PlutusScriptInEra{} = L.plutusLanguage (Proxy @lang) plutusScriptInEraToScript - :: forall lang era. L.AlonzoEraScript era => PlutusScriptInEra lang era -> L.Script era -plutusScriptInEraToScript (PlutusScriptInEra pr) = - case L.fromPlutusScript <$> L.mkPlutusScript (L.plutusFromRunnable pr) of - Nothing -> - error - "plutusScriptInEraToScript: Impossible as the failure would have occurred at the point of deserialising the PlutusRunnable value." - Just script -> script + :: forall lang era. PlutusScriptInEra lang era -> L.Script era +plutusScriptInEraToScript (PlutusScriptInEra _ script) = + L.fromPlutusScript script -- | You can provide the plutus script directly in the transaction -- or a reference input that points to the script in the UTxO. @@ -183,7 +206,7 @@ data PlutusScriptOrReferenceInput lang era data AnyPlutusScript era where AnyPlutusScript - :: (L.Era era, Typeable lang, L.PlutusLanguage lang) + :: (L.Era era, L.EraPlutusTxInfo lang era, Typeable lang, L.PlutusLanguage lang) => PlutusScriptInEra lang era -> AnyPlutusScript era instance Show (AnyPlutusScript era) where @@ -196,13 +219,29 @@ instance Eq (AnyPlutusScript era) where Nothing -> False decodeAnyPlutusScript - :: L.Era era + :: forall era + . (L.Era era, HasPlutusLangInEra era) => ByteString -> AnyPlutusScriptLanguage -> Either CBOR.DecoderError (AnyPlutusScript era) -decodeAnyPlutusScript bs (AnyPlutusScriptLanguage lang) = - AnyPlutusScript - <$> obtainLangConstraints lang (deserialisePlutusScriptInEra lang bs) +decodeAnyPlutusScript bs (AnyPlutusScriptLanguage (lang :: L.SLanguage lang)) = + case plutusLangInEra @era lang of + Nothing -> Left $ plutusLanguageNotSupportedInEraError @era lang + Just (PlutusLangInEra _) -> + AnyPlutusScript + <$> obtainLangConstraints lang (deserialisePlutusScriptInEra @era @lang bs) + +-- | The decoder error reported when a script's language is not in the era's +-- 'PlutusLangInEra' table. Names both the unsupported language and the era. +plutusLanguageNotSupportedInEraError + :: forall era lang. L.Era era => L.SLanguage lang -> CBOR.DecoderError +plutusLanguageNotSupportedInEraError lang = + CBOR.DecoderErrorCustom "PlutusScriptInEra" $ + "Plutus language " + <> plutusLanguageToText (obtainLangConstraints lang (AnyPlutusScriptLanguage lang)) + <> " is not supported in the " + <> Text.pack (L.eraName @era) + <> " era" obtainLangConstraints :: L.SLanguage lang @@ -225,27 +264,37 @@ instance Show AnyPlutusScriptLanguage where -- is determined by the Plutus language version of the script. serialiseAnyPlutusScriptToTextEnvelope :: Maybe TextEnvelopeDescr -> AnyPlutusScript era -> TextEnvelope -serialiseAnyPlutusScriptToTextEnvelope mbDescr (AnyPlutusScript script) = +serialiseAnyPlutusScriptToTextEnvelope mbDescr (AnyPlutusScript script@PlutusScriptInEra{}) = obtainLangConstraints (plutusScriptInEraSLanguage script) $ serialiseToTextEnvelope mbDescr script -- | Deserialise an 'AnyPlutusScript' from a 'TextEnvelope'. The text envelope type --- is matched against all known Plutus language versions derived from --- 'Plutus.nonNativeLanguages', so new language versions are picked up automatically. +-- is matched against the Plutus language versions from 'Plutus.nonNativeLanguages' +-- that the era supports, so new language versions are picked up automatically. deserialiseAnyPlutusScriptFromTextEnvelope :: forall era - . L.Era era + . (L.Era era, HasPlutusLangInEra era) => TextEnvelope -> Either TextEnvelopeError (AnyPlutusScript era) -deserialiseAnyPlutusScriptFromTextEnvelope = - deserialiseFromTextEnvelopeAnyOf textEnvTypes +deserialiseAnyPlutusScriptFromTextEnvelope te = + case textToPlutusLanguage (Text.pack envType) of + Just (AnyPlutusScriptLanguage slang) + | Nothing <- plutusLangInEra @era slang -> + Left . TextEnvelopeDecodeError $ plutusLanguageNotSupportedInEraError @era slang + _ -> deserialiseFromTextEnvelopeAnyOf textEnvTypes te where + TextEnvelopeType envType = teType te + + -- Only the era's languages are listed; an envelope for another language + -- is rejected above with 'plutusLanguageNotSupportedInEraError'. textEnvTypes :: [FromSomeType HasTextEnvelope (AnyPlutusScript era)] textEnvTypes = - map + concatMap ( \l -> Plutus.withSLanguage l $ \(slang :: Plutus.SLanguage l) -> - obtainLangConstraints slang $ - FromSomeType (asType @(PlutusScriptInEra l era)) AnyPlutusScript + case plutusLangInEra @era slang of + Just (PlutusLangInEra _) -> + obtainLangConstraints slang [FromSomeType (asType @(PlutusScriptInEra l era)) AnyPlutusScript] + Nothing -> [] ) Plutus.nonNativeLanguages diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs index 44fdef219c..39b4a19391 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs @@ -155,7 +155,7 @@ getSpendingPlutusWitnessData (PlutusScriptWitness L.SPlutusV4 _ d _ _) = NoScriptDatum -> mempty getPlutusScriptRunnable :: PlutusScriptWitness lang purpose era -> Maybe (L.PlutusRunnable lang) -getPlutusScriptRunnable (PlutusScriptWitness _ (PScript (PlutusScriptInEra plutusScriptRunnable)) _ _ _) = +getPlutusScriptRunnable (PlutusScriptWitness _ (PScript (PlutusScriptInEra plutusScriptRunnable _)) _ _ _) = Just plutusScriptRunnable getPlutusScriptRunnable (PlutusScriptWitness _ PReferenceScript{} _ _ _) = Nothing 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 b08c50bd18..f246ed4920 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 @@ -54,7 +54,6 @@ import Cardano.Ledger.Plutus.Language qualified as L import Data.Text qualified as Text import Data.Typeable -import GHC.Stack (HasCallStack) -- | This module is concerned with converting legacy api scripts and by extension -- script witnesses to the new api. @@ -89,13 +88,14 @@ convertToNewScriptWitness -> Either CBOR.DecoderError (Witnessable thing (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era)) -convertToNewScriptWitness eon (Old.PlutusScriptWitness _ v scriptOrRefInput datum scriptRedeemer execUnits) witnessable = do +convertToNewScriptWitness eon (Old.PlutusScriptWitness langInEra v scriptOrRefInput datum scriptRedeemer execUnits) witnessable = do let d = createPlutusScriptDatum witnessable v datum newScriptWitness <- obtainConstraints v $ toNewPlutusScriptWitness eon witnessable + langInEra v scriptOrRefInput scriptRedeemer @@ -160,6 +160,7 @@ toNewPlutusScriptWitness . L.PlutusLanguage (Old.ToLedgerPlutusLanguage lang) => AlonzoEraOnwards era -> Witnessable thing (ShelleyLedgerEra era) + -> Old.ScriptLanguageInEra lang era -> Old.PlutusScriptVersion lang -> Old.PlutusScriptOrReferenceInput lang -> ScriptRedeemer @@ -170,7 +171,7 @@ toNewPlutusScriptWitness ( AnyWitness (ShelleyLedgerEra era) ) -toNewPlutusScriptWitness eon w l (Old.PScript (Old.PlutusScriptSerialised scriptShortBs)) scriptRedeemer execUnits datum = do +toNewPlutusScriptWitness eon w langInEra l (Old.PScript (Old.PlutusScriptSerialised scriptShortBs)) scriptRedeemer execUnits datum = do let protocolVersion = getVersion eon plutusScript = L.Plutus $ L.PlutusBinary scriptShortBs plutusScriptRunnable = @@ -180,17 +181,27 @@ toNewPlutusScriptWitness eon w l (Old.PScript (Old.PlutusScriptSerialised script Left e -> Left $ CBOR.DecoderErrorCustom "PlutusLedgerApi.Common.ScriptDecodeError" (Text.pack . show $ pretty e) - Right{} -> - return $ - mkPlutusScriptWitness - eon - w - (toPlutusSLanguage l) - plutusScriptRunnable - datum - scriptRedeemer - execUnits -toNewPlutusScriptWitness _ w l (Old.PReferenceScript refInput) scriptRedeemer execUnits datum = + Right{} -> do + let slang = toPlutusSLanguage l + -- The legacy proof rules this failure out, but one runtime lookup path + -- keeps the shim simple. + notSupported :: CBOR.DecoderError + notSupported = + alonzoEraOnwardsConstraints eon $ + plutusLanguageNotSupportedInEraError @(ShelleyLedgerEra era) slang + case plutusLangInShelleyBasedEra (Old.eraOfScriptLanguageInEra langInEra) slang of + Nothing -> Left notSupported + Just (PlutusLangInEra _) -> + return $ + mkPlutusScriptWitness + eon + w + slang + (mkPlutusScriptInEra plutusScriptRunnable) + datum + scriptRedeemer + execUnits +toNewPlutusScriptWitness _ w _ l (Old.PReferenceScript refInput) scriptRedeemer execUnits datum = return $ mkReferencePlutusScriptWitness w (toPlutusSLanguage l) refInput datum scriptRedeemer execUnits @@ -208,14 +219,14 @@ mkPlutusScriptWitness => AlonzoEraOnwards era -> Witnessable thing (ShelleyLedgerEra era) -> L.SLanguage plutuslang - -> L.PlutusRunnable plutuslang + -> PlutusScriptInEra plutuslang (ShelleyLedgerEra era) -> PlutusScriptDatum plutuslang (PlutusScriptFor thing) -> ScriptRedeemer -> ExecutionUnits -> AnyWitness (ShelleyLedgerEra era) -mkPlutusScriptWitness eon w l plutusScriptRunnable d r e = +mkPlutusScriptWitness eon w l script d r e = let script' :: PlutusScriptOrReferenceInput plutuslang (ShelleyLedgerEra era) - script' = (PScript $ PlutusScriptInEra plutusScriptRunnable) + script' = PScript script in case w of WitTxIn{} -> let @@ -261,7 +272,7 @@ mkPlutusScriptWitness eon w l plutusScriptRunnable d r e = AnyPlutusWithdrawingScriptWitness ( PlutusScriptWitness l - (PScript $ PlutusScriptInEra plutusScriptRunnable) + script' d r e @@ -271,7 +282,7 @@ mkPlutusScriptWitness eon w l plutusScriptRunnable d r e = AnyPlutusVotingScriptWitness ( PlutusScriptWitness l - (PScript $ PlutusScriptInEra plutusScriptRunnable) + script' d r e @@ -281,7 +292,7 @@ mkPlutusScriptWitness eon w l plutusScriptRunnable d r e = AnyPlutusProposingScriptWitness ( PlutusScriptWitness l - (PScript $ PlutusScriptInEra plutusScriptRunnable) + script' d r e @@ -382,8 +393,7 @@ legacyWitnessConversion legacyWitnessConversion eon = mapM (toAnyWitness eon) legacyWitnessToScriptRequirements - :: HasCallStack - => AlonzoEraOnwards era + :: AlonzoEraOnwards era -> [(Witnessable witnessable (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness ctx era))] -> Either CBOR.DecoderError (TxScriptWitnessRequirements (ShelleyLedgerEra era)) legacyWitnessToScriptRequirements eon wits = do @@ -391,14 +401,7 @@ legacyWitnessToScriptRequirements eon wits = do return $ alonzoEraOnwardsConstraints eon $ obtainMonoidConstraint eon $ - -- Legacy witnesses carry a 'ScriptLanguageInEra' proof, so the era already - -- supports every language reachable here. This 'Left' cannot occur. - either - ( \lang -> - error $ "legacyWitnessToScriptRequirements: unreachable, language/era proof excludes " <> show lang - ) - id - (getTxScriptWitnessesRequirements r) + getTxScriptWitnessesRequirements r -- Misc helpers 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 2e8427933f..a129377a44 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs @@ -90,11 +90,10 @@ getAnyWitnessSimpleScript (AnySimpleScriptWitness simpleScriptOrRefInput) = getAnyWitnessSimpleScript (AnyPlutusScriptWitness _) = Nothing getAnyWitnessPlutusScript - :: L.AlonzoEraScript era - => AnyWitness era - -> Either L.Language (Maybe (L.Script era)) -getAnyWitnessPlutusScript AnyKeyWitnessPlaceholder = Right Nothing -getAnyWitnessPlutusScript (AnySimpleScriptWitness _) = Right Nothing + :: AnyWitness era + -> Maybe (L.Script era) +getAnyWitnessPlutusScript AnyKeyWitnessPlaceholder = Nothing +getAnyWitnessPlutusScript (AnySimpleScriptWitness _) = Nothing getAnyWitnessPlutusScript ( AnyPlutusScriptWitness s @@ -115,9 +114,9 @@ getAnyWitnessScriptData AnySimpleScriptWitness{} = mempty getAnyWitnessScriptData (AnyPlutusScriptWitness s) = getAnyPlutusScriptData s getAnyWitnessScript - :: L.AlonzoEraScript era => AnyWitness era -> Either L.Language (Maybe (L.Script era)) -getAnyWitnessScript AnyKeyWitnessPlaceholder = Right Nothing -getAnyWitnessScript ss@(AnySimpleScriptWitness{}) = Right $ getAnyWitnessSimpleScript ss + :: AnyWitness era -> Maybe (L.Script era) +getAnyWitnessScript AnyKeyWitnessPlaceholder = Nothing +getAnyWitnessScript ss@(AnySimpleScriptWitness{}) = getAnyWitnessSimpleScript ss getAnyWitnessScript ps@(AnyPlutusScriptWitness{}) = getAnyWitnessPlutusScript ps getPlutusDatum diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent.hs index 460de55ee8..b1b69cb827 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent.hs @@ -233,7 +233,6 @@ import Control.Monad import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Types (Pair, Parser) -import Data.Bifunctor (first) import Data.ByteString.Base16 qualified as Base16 import Data.ByteString.Short qualified as SBS import Data.Functor @@ -267,9 +266,6 @@ data MakeUnsignedTxError -- eras, so this is only detected when the body is built. -- The field names are those of the 'TxBodyContent' record. MakeUnsignedTxFieldsNotSupportedInEra (Some Era) (NonEmpty Text) - | -- | An inline Plutus script witness uses a language the era does not - -- support. - MakeUnsignedTxPlutusLanguageNotSupportedInEra L.Language (Some Era) deriving (Eq, Show) instance Error MakeUnsignedTxError where @@ -286,14 +282,6 @@ instance Error MakeUnsignedTxError where , " era: " , pretty . Text.intercalate ", " $ NonEmpty.toList fields ] - prettyError (MakeUnsignedTxPlutusLanguageNotSupportedInEra language (Some era)) = - mconcat - [ "Plutus script language " - , pshow language - , " is not supported in the " - , pretty era - , " era." - ] makeUnsignedTx :: forall era @@ -301,9 +289,7 @@ makeUnsignedTx -> TxBodyContent (LedgerEra era) -> Either MakeUnsignedTxError (UnsignedTx (LedgerEra era)) makeUnsignedTx era bc = obtainCommonConstraints era $ do - TxScriptWitnessRequirements languages scripts datums redeemers <- - first (\language -> MakeUnsignedTxPlutusLanguageNotSupportedInEra language (Some era)) $ - collectTxBodyScriptWitnessRequirements bc + let TxScriptWitnessRequirements languages scripts datums redeemers = collectTxBodyScriptWitnessRequirements bc -- cardano-api types let apiMintValue = txMintValue bc @@ -1345,7 +1331,7 @@ collectTxBodyScriptWitnessRequirements :: forall l era . IsEra era => BodyContent l (LedgerEra era) - -> Either L.Language (TxScriptWitnessRequirements (LedgerEra era)) + -> TxScriptWitnessRequirements (LedgerEra era) collectTxBodyScriptWitnessRequirements BodyContent { bcIns @@ -1356,7 +1342,7 @@ collectTxBodyScriptWitnessRequirements , bcVotingProcedures , bcProposalProcedures , bcSupplementalDatums - } = obtainCommonConstraints (useEra @era) $ obtainMonoidConstraint (useEra @era) $ do + } = obtainCommonConstraints (useEra @era) $ do let supplementaldatums = TxScriptWitnessRequirements mempty @@ -1364,17 +1350,26 @@ collectTxBodyScriptWitnessRequirements (getDatums bcInsReference bcSupplementalDatums) mempty - txInWits <- getTxScriptWitnessesRequirements $ extractWitnessableTxIns bcIns - txWithdrawalWits <- getTxScriptWitnessesRequirements $ extractWitnessableWithdrawals bcWithdrawals - txCertWits <- getTxScriptWitnessesRequirements $ extractWitnessableCertificates bcCertificates - txMintWits <- - getTxScriptWitnessesRequirements - [(wit, anyScriptWitnessToAnyWitness sw) | (wit, sw) <- extractWitnessableMints bcMintValue] - txVotingWits <- getTxScriptWitnessesRequirements $ extractWitnessableVotes bcVotingProcedures - txProposalWits <- - getTxScriptWitnessesRequirements $ extractWitnessableProposals bcProposalProcedures - - Right $ + let txInWits = + obtainMonoidConstraint (useEra @era) getTxScriptWitnessesRequirements $ + extractWitnessableTxIns bcIns + txWithdrawalWits = + obtainMonoidConstraint (useEra @era) getTxScriptWitnessesRequirements $ + extractWitnessableWithdrawals bcWithdrawals + txCertWits = + obtainMonoidConstraint (useEra @era) getTxScriptWitnessesRequirements $ + extractWitnessableCertificates bcCertificates + txMintWits = + obtainMonoidConstraint (useEra @era) getTxScriptWitnessesRequirements $ + [(wit, anyScriptWitnessToAnyWitness sw) | (wit, sw) <- extractWitnessableMints bcMintValue] + txVotingWits = + obtainMonoidConstraint (useEra @era) getTxScriptWitnessesRequirements $ + extractWitnessableVotes bcVotingProcedures + txProposalWits = + obtainMonoidConstraint (useEra @era) getTxScriptWitnessesRequirements $ + extractWitnessableProposals bcProposalProcedures + + obtainMonoidConstraint (useEra @era) $ mconcat [ supplementaldatums , txInWits diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/SubTransaction.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/SubTransaction.hs index f48bd6049a..c4d4b63048 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/SubTransaction.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/SubTransaction.hs @@ -81,7 +81,6 @@ import Cardano.Ledger.Dijkstra.TxBody qualified as L ( DijkstraEraTxBody (accountBalanceIntervalsTxBodyL, requiredTopLevelGuardsL) ) -import Data.Bifunctor (first) import Data.ByteString.Lazy qualified as LBS import Data.Maybe (fromMaybe) import GHC.Exts (IsList (..)) @@ -154,9 +153,8 @@ makeUnsignedSubTx :: SubTxBodyContent (LedgerEra DijkstraEra) -> Either MakeUnsignedTxError UnsignedSubTx makeUnsignedSubTx st = do - TxScriptWitnessRequirements languages scripts datums redeemers <- - first (\language -> MakeUnsignedTxPlutusLanguageNotSupportedInEra language (Some DijkstraEra)) $ - collectTxBodyScriptWitnessRequirements @_ @DijkstraEra st + let TxScriptWitnessRequirements languages scripts datums redeemers = + collectTxBodyScriptWitnessRequirements @_ @DijkstraEra st scriptIntegrityHash <- convPParamsToScriptIntegrityHash @DijkstraEra diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/TxScriptWitnessRequirements.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/TxScriptWitnessRequirements.hs index 910674545a..f306112b02 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/TxScriptWitnessRequirements.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/TxScriptWitnessRequirements.hs @@ -69,28 +69,24 @@ getTxScriptWitnessRequirements :: L.AlonzoEraScript era => Monoid (TxScriptWitnessRequirements era) => [(Witnessable witnessable era, AnyWitness era)] - -> Either L.Language (TxScriptWitnessRequirements era) -getTxScriptWitnessRequirements wits = do - reqs <- - traverse - ( \(_, anyWit) -> do - script <- getAnyWitnessScript anyWit - return $ - TxScriptWitnessRequirements + -> TxScriptWitnessRequirements era +getTxScriptWitnessRequirements wits = + let TxScriptWitnessRequirements l s d _ = + mconcat + [ TxScriptWitnessRequirements (maybe mempty Set.singleton $ getAnyWitnessPlutusLanguage anyWit) - (maybe mempty return script) + (maybe mempty return $ getAnyWitnessScript anyWit) (getAnyWitnessScriptData anyWit) mempty - ) - wits - let TxScriptWitnessRequirements l s d _ = mconcat reqs - return $ TxScriptWitnessRequirements l s d (getAnyWitnessRedeemerPointerMap wits) + | (_, anyWit) <- wits + ] + in TxScriptWitnessRequirements l s d (getAnyWitnessRedeemerPointerMap wits) getTxScriptWitnessesRequirements :: L.AlonzoEraScript era => Monoid (TxScriptWitnessRequirements era) => [(Witnessable witnessable era, AnyWitness era)] - -> Either L.Language (TxScriptWitnessRequirements era) + -> TxScriptWitnessRequirements era getTxScriptWitnessesRequirements wits = getTxScriptWitnessRequirements wits diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs index 40342f5cd2..4aa99d66b8 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs @@ -2602,6 +2602,8 @@ toAuxiliaryData sbe txMetadata txAuxScripts = ShelleyBasedEraConway -> guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss ShelleyBasedEraDijkstra -> + -- TODO: cardano-ledger-dijkstra 0.4.0.0 reads auxiliary scripts up to eraMaxLanguage + -- (still PlutusV3), so PlutusV4 is dropped on read-back; fixed by ledger PR 6109. guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss -- ---------------------------------------------------------------------------- diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs index da9dfac3ec..074d6fba5e 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-deprecations #-} @@ -22,6 +23,7 @@ import Cardano.Api.Ledger qualified as L import Cardano.Api.Plutus qualified as Script import Cardano.Api.Serialise.Cbor (SerialiseAsCBOR (..)) +import Cardano.Ledger.Binary qualified as CBOR import Cardano.Ledger.Conway qualified as L import Cardano.Ledger.Conway.Scripts qualified as L import Cardano.Ledger.Dijkstra.Scripts qualified as L @@ -34,6 +36,7 @@ import Data.Function import Data.List qualified as List import Data.Map.Strict qualified as Map import Data.Proxy (Proxy (..)) +import Data.Text qualified as Text import Data.Word (Word32) import Test.Gen.Cardano.Api.Experimental qualified as Exp @@ -225,32 +228,15 @@ prop_extractAllIndexedPlutusScriptWitnesses = length allGeneratedPlutusScriptWitnesses === length extractedPlutusScriptWitnesses --- | An inline Plutus witness must be rejected, not dropped while its redeemer --- is kept, when the era does not support its language. V4 fails in Conway. -prop_makeUnsignedTx_rejects_unsupported_plutus_language :: Property -prop_makeUnsignedTx_rejects_unsupported_plutus_language = property $ do - srcTxIn <- forAll genTxIn +-- | V4 bytes must not decode in Conway when the language only arrives at runtime. +prop_deserialise_rejects_unsupported_plutus_language :: Property +prop_deserialise_rejects_unsupported_plutus_language = property $ do v3ScriptInEra <- forAll genPlutusScriptInEra - v4ScriptInEra <- - H.leftFail $ deserialisePlutusScriptInEra L.SPlutusV4 (serialiseToCBOR v3ScriptInEra) - let dummyRedeemer = Script.unsafeHashableScriptData $ Script.ScriptDataConstructor 0 [] - plutusWit = - Exp.AnyPlutusScriptWitness $ - AnyPlutusSpendingScriptWitness $ - PlutusSpendingScriptWitnessV4 $ - PlutusScriptWitness - L.SPlutusV4 - (PScript v4ScriptInEra) - NoScriptDatum - dummyRedeemer - (Script.ExecutionUnits 0 0) - txBodyContent = - Exp.defaultTxBodyContent - & Exp.setTxProtocolParams exampleProtocolParams - & Exp.setTxIns [(srcTxIn, plutusWit)] - & Exp.setTxFee 0 - Exp.makeUnsignedTx ConwayEra txBodyContent - === Left (Exp.MakeUnsignedTxPlutusLanguageNotSupportedInEra L.PlutusV4 (Some ConwayEra)) + let v4Bytes = serialiseToCBOR v3ScriptInEra + case decodeAnyPlutusScript @L.ConwayEra v4Bytes (AnyPlutusScriptLanguage L.SPlutusV4) of + Left (CBOR.DecoderErrorCustom "PlutusScriptInEra" msg) + | "Conway" `Text.isInfixOf` msg -> success + other -> annotateShow other >> failure -- | A reference witness only records the language and redeemer in the body, -- so 'Exp.makeUnsignedTx' must accept it even where the era forbids an inline witness of that language. @@ -398,8 +384,8 @@ tests = "prop_extractAllIndexedPlutusScriptWitnesses" prop_extractAllIndexedPlutusScriptWitnesses , testProperty - "prop_makeUnsignedTx_rejects_unsupported_plutus_language" - prop_makeUnsignedTx_rejects_unsupported_plutus_language + "prop_deserialise_rejects_unsupported_plutus_language" + prop_deserialise_rejects_unsupported_plutus_language , testProperty "prop_makeUnsignedTx_accepts_reference_plutus_v4_witness" prop_makeUnsignedTx_accepts_reference_plutus_v4_witness