From db59894b66b50e8188b7ac0adbf922d0e5b1b50c Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 2 Oct 2026 12:39:13 -0400 Subject: [PATCH 1/8] Add a type-level table of Plutus languages per ledger era PlutusLangInEra lang era is a Constraint-kinded closed type family listing the language/era pairs the ledger accepts, mirroring eraMaxLanguage. The PlutusLangsInEra class reflects it back as runtime evidence for code that only learns the language at runtime. Nothing uses it yet. Compiles. --- cardano-api/cardano-api.cabal | 1 + .../Experimental/Plutus/Internal/Language.hs | 89 +++++++++++++++++++ 2 files changed, 90 insertions(+) create mode 100644 cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Language.hs 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/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..9009297421 --- /dev/null +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Language.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Which Plutus languages each ledger era accepts, as a type-level table. +-- +-- The table mirrors ledger's 'L.eraMaxLanguage' and must be extended when a new +-- era or Plutus language lands. It is consulted in two ways: +-- +-- * At compile time, 'PlutusLangInEra' is a constraint on the 'PlutusScriptInEra' +-- constructor. A pairing the table does not list is a type error, so a script +-- with an unsupported language cannot be placed in a transaction for that era. +-- +-- * At runtime, 'plutusLangInEra' reflects the table back as a value. Code that +-- only learns the language at runtime, such as a deserialiser, uses it to +-- obtain the evidence the constructor demands. GHC checks each row of +-- 'plutusLangInEra' against the type family, so the two cannot disagree. +module Cardano.Api.Experimental.Plutus.Internal.Language + ( PlutusLangInEra + , PlutusLangInEraEvidence (..) + , PlutusLangsInEra (..) + ) +where + +import Cardano.Ledger.Api qualified as L +import Cardano.Ledger.Plutus.Language qualified as L + +import Data.Kind (Constraint, Type) +import GHC.TypeLits (ErrorMessage (..), TypeError) + +-- | Holds when the ledger era @era@ accepts Plutus scripts of language @lang@. +type family PlutusLangInEra (lang :: L.Language) (era :: Type) :: Constraint where + PlutusLangInEra 'L.PlutusV1 L.AlonzoEra = () + PlutusLangInEra 'L.PlutusV1 L.BabbageEra = () + PlutusLangInEra 'L.PlutusV2 L.BabbageEra = () + PlutusLangInEra 'L.PlutusV1 L.ConwayEra = () + PlutusLangInEra 'L.PlutusV2 L.ConwayEra = () + PlutusLangInEra 'L.PlutusV3 L.ConwayEra = () + PlutusLangInEra 'L.PlutusV1 L.DijkstraEra = () + PlutusLangInEra 'L.PlutusV2 L.DijkstraEra = () + PlutusLangInEra 'L.PlutusV3 L.DijkstraEra = () + PlutusLangInEra 'L.PlutusV4 L.DijkstraEra = () + PlutusLangInEra lang era = + TypeError + ( 'Text "Plutus language " + ':<>: 'ShowType lang + ':<>: 'Text " is not supported in the ledger era " + ':<>: 'ShowType era + ) + +-- | Runtime evidence that 'PlutusLangInEra' holds. Pattern matching on the +-- constructor brings the constraint into scope. +data PlutusLangInEraEvidence (lang :: L.Language) era where + PlutusLangInEraEvidence :: PlutusLangInEra lang era => PlutusLangInEraEvidence lang era + +-- | The value-level reflection of 'PlutusLangInEra', one instance per ledger era. +class PlutusLangsInEra era where + plutusLangInEra :: L.SLanguage lang -> Maybe (PlutusLangInEraEvidence lang era) + +instance PlutusLangsInEra L.AlonzoEra where + plutusLangInEra = \case + L.SPlutusV1 -> Just PlutusLangInEraEvidence + L.SPlutusV2 -> Nothing + L.SPlutusV3 -> Nothing + L.SPlutusV4 -> Nothing + +instance PlutusLangsInEra L.BabbageEra where + plutusLangInEra = \case + L.SPlutusV1 -> Just PlutusLangInEraEvidence + L.SPlutusV2 -> Just PlutusLangInEraEvidence + L.SPlutusV3 -> Nothing + L.SPlutusV4 -> Nothing + +instance PlutusLangsInEra L.ConwayEra where + plutusLangInEra = \case + L.SPlutusV1 -> Just PlutusLangInEraEvidence + L.SPlutusV2 -> Just PlutusLangInEraEvidence + L.SPlutusV3 -> Just PlutusLangInEraEvidence + L.SPlutusV4 -> Nothing + +instance PlutusLangsInEra L.DijkstraEra where + plutusLangInEra = \case + L.SPlutusV1 -> Just PlutusLangInEraEvidence + L.SPlutusV2 -> Just PlutusLangInEraEvidence + L.SPlutusV3 -> Just PlutusLangInEraEvidence + L.SPlutusV4 -> Just PlutusLangInEraEvidence From bb10b754a3efd12f6ae487a0e089b17f6e84297d Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 2 Oct 2026 12:40:08 -0400 Subject: [PATCH 2/8] Make fromPlutusRunnable total by requiring PlutusLangInEra fromPlutusRunnable now demands PlutusLangInEra lang era and returns PlutusScript era instead of Maybe. The only way ledger's mkPlutusScript returned Nothing was an unsupported language/era pairing, which the constraint now excludes, so the Nothing branch is unreachable. With the Left gone, the Either L.Language plumbing through getAnyWitnessScript, getTxScriptWitnessRequirements, collectTxBodyScriptWitnessRequirements and makeUnsignedTx is dropped and MakeUnsignedTxPlutusLanguageNotSupportedInEra is removed. Does not compile. The constraint has to come from somewhere: AnyScriptWitness.hs:263:31: error: Could not deduce 'PlutusLangInEra lang era' arising from a use of 'fromPlutusRunnable' from the context: L.AlonzoEraScript era or from: L.PlutusLanguage lang bound by a pattern with constructor: PlutusScriptInEra The caller only has the witness in hand, and lang is existential in AnyWitness. The evidence must travel inside the value: the next commit puts it on the PlutusScriptInEra constructor. --- .../Api/Experimental/AnyScriptWitness.hs | 71 +++++++++---------- .../Experimental/Tx/Internal/AnyWitness.hs | 12 ++-- .../Experimental/Tx/Internal/BodyContent.hs | 51 ++++++------- .../Tx/Internal/SubTransaction.hs | 6 +- .../Internal/TxScriptWitnessRequirements.hs | 24 +++---- 5 files changed, 75 insertions(+), 89 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs b/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs index 73e1f0d86d..f91cc2e489 100644 --- a/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs +++ b/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs @@ -22,6 +22,7 @@ module Cardano.Api.Experimental.AnyScriptWitness ) where +import Cardano.Api.Experimental.Plutus.Internal.Language import Cardano.Api.Experimental.Plutus.Internal.Script import Cardano.Api.Experimental.Plutus.Internal.ScriptWitness import Cardano.Api.Experimental.Simple.Script @@ -233,55 +234,51 @@ 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)) + -> 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 always resolves: the 'PlutusScriptInEra' it holds is the +-- proof that the era supports the language. 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 + => PlutusScriptWitness lang purpose era + -> Maybe (L.Script era) +resolvePlutusWitnessScript (PlutusScriptWitness slang (PScript (PlutusScriptInEra runnable)) _ _ _) = + Just . L.fromPlutusScript $ fromPlutusRunnable slang runnable +resolvePlutusWitnessScript (PlutusScriptWitness _ PReferenceScript{} _ _ _) = Nothing --- | '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. +-- | Convert a runnable script to the era's ledger script type. +-- +-- Ledger's 'L.mkPlutusScript' returns 'Nothing' when the era does not support +-- the language. 'PlutusLangInEra' excludes that pairing at the type level, so +-- the 'Nothing' branch is unreachable and the result is total. fromPlutusRunnable :: forall era lang - . L.AlonzoEraScript era + . (L.AlonzoEraScript era, L.PlutusLanguage lang, PlutusLangInEra lang 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 + -> L.PlutusScript era +fromPlutusRunnable slang runnable = + case L.mkPlutusScript $ L.plutusFromRunnable runnable of + Just script -> script + Nothing -> + error $ + "fromPlutusRunnable: unreachable, PlutusLangInEra excludes " + <> show (L.plutusLanguage slang) + <> " in this 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 2e8427933f..7af8ebe606 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs @@ -92,9 +92,9 @@ getAnyWitnessSimpleScript (AnyPlutusScriptWitness _) = Nothing getAnyWitnessPlutusScript :: L.AlonzoEraScript era => AnyWitness era - -> Either L.Language (Maybe (L.Script era)) -getAnyWitnessPlutusScript AnyKeyWitnessPlaceholder = Right Nothing -getAnyWitnessPlutusScript (AnySimpleScriptWitness _) = Right Nothing + -> Maybe (L.Script era) +getAnyWitnessPlutusScript AnyKeyWitnessPlaceholder = Nothing +getAnyWitnessPlutusScript (AnySimpleScriptWitness _) = Nothing getAnyWitnessPlutusScript ( AnyPlutusScriptWitness s @@ -115,9 +115,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 + :: L.AlonzoEraScript era => 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 From e93c04ac2dfed31d71f77730e0cfa4b5f3da2c3f Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 2 Oct 2026 12:42:46 -0400 Subject: [PATCH 3/8] Carry PlutusLangInEra inside the PlutusScriptInEra constructor The constraint is packed into the constructor so that any pattern match on PlutusScriptInEra brings it back into scope. This is what lets resolvePlutusWitnessScript call fromPlutusRunnable even though lang is existential in AnyWitness: the evidence travels with the value. Within this module GHC then demanded the constraint, in order, at: Script.hs:141 deserialiseFromCBOR Could not deduce 'PlutusLangInEra lang era' arising from a use of 'PlutusScriptInEra' Script.hs:90 HasTextEnvelope arising from the superclasses of an instance Script.hs:153 deserialisePlutusScriptInEra arising from 'deserialiseFromCBOR' Script.hs:214 decodeAnyPlutusScript arising from 'deserialisePlutusScriptInEra' Script.hs:239 serialiseAnyPlutusScriptToTextEnvelope arising from 'serialiseToTextEnvelope' Script.hs:258 deserialiseAnyPlutusScriptFromTextEnvelope arising from 'FromSomeType' Three kinds of fix, by what is in scope at each site: * lang and era are type variables of a signature or instance head: add the constraint to the context (CBOR instance, HasTextEnvelope instance, deserialisePlutusScriptInEra). * the value is already a PlutusScriptInEra: match the constructor (serialiseAnyPlutusScriptToTextEnvelope). * lang is existential, learned from an envelope type string at runtime: look up PlutusLangsInEra evidence and match it (decodeAnyPlutusScript, deserialiseAnyPlutusScriptFromTextEnvelope). An unsupported language is now a decoder error, or an envelope type that is not offered at all. Does not compile. Next module: AnyScript.hs:107 tryPlutusScript Could not deduce 'PlutusLangInEra l era' AnyScript.hs:133 deserialiseAnyPlutusScriptOfLanguage Could not deduce 'PlutusLangInEra lang (LedgerEra era)' AnyScript.hs:204 readTextEnvelopeScript Could not deduce 'PlutusLangsInEra (LedgerEra era)' --- .../Experimental/Plutus/Internal/Script.hs | 53 +++++++++++++++---- 1 file changed, 42 insertions(+), 11 deletions(-) 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..15ec4cb02b 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs @@ -7,6 +7,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Cardano.Api.Experimental.Plutus.Internal.Script ( AnyPlutusScript (..) @@ -15,9 +16,13 @@ module Cardano.Api.Experimental.Plutus.Internal.Script , deserialiseAnyPlutusScriptFromTextEnvelope , AnyPlutusScriptLanguage (..) , PlutusScriptInEra (..) + , PlutusLangInEra + , PlutusLangInEraEvidence (..) + , PlutusLangsInEra (..) , PlutusScriptOrReferenceInput (..) , AsType (..) , deserialisePlutusScriptInEra + , plutusLanguageNotSupportedInEraError , hashPlutusScriptInEra , plutusScriptInEraLanguage , plutusScriptInEraSLanguage @@ -29,6 +34,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) @@ -69,7 +75,9 @@ import Prettyprinter -- The serialized version of 'PlutusRunnable' encodes the script language. -- See `DecCBOR (PlutusRunnable l)` in cardano-ledger for more details. data PlutusScriptInEra (lang :: L.Language) era where - PlutusScriptInEra :: L.PlutusLanguage lang => PlutusRunnable lang -> PlutusScriptInEra lang era + PlutusScriptInEra + :: (L.PlutusLanguage lang, PlutusLangInEra lang era) + => PlutusRunnable lang -> PlutusScriptInEra lang era deriving instance Show (PlutusScriptInEra lang era) @@ -83,7 +91,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 + , PlutusLangInEra lang era + , HasTypeProxy (Plutus.SLanguage lang) + ) => HasTextEnvelope (PlutusScriptInEra lang era) where textEnvelopeTypes _ = @@ -114,6 +126,7 @@ instance , Typeable era , Typeable lang , Plutus.PlutusLanguage lang + , PlutusLangInEra lang era , HasTypeProxy (Plutus.SLanguage lang) ) => SerialiseAsCBOR (PlutusScriptInEra (lang :: L.Language) era) @@ -139,7 +152,7 @@ instance deserialisePlutusScriptInEra :: forall era lang - . (Plutus.PlutusLanguage lang, HasTypeProxy (Plutus.SLanguage lang)) + . (Plutus.PlutusLanguage lang, HasTypeProxy (Plutus.SLanguage lang), PlutusLangInEra lang era) => L.Era era => L.SLanguage lang -> BS.ByteString @@ -196,13 +209,26 @@ instance Eq (AnyPlutusScript era) where Nothing -> False decodeAnyPlutusScript - :: L.Era era + :: forall era + . (L.Era era, PlutusLangsInEra era) => ByteString -> AnyPlutusScriptLanguage -> Either CBOR.DecoderError (AnyPlutusScript era) decodeAnyPlutusScript bs (AnyPlutusScriptLanguage lang) = - AnyPlutusScript - <$> obtainLangConstraints lang (deserialisePlutusScriptInEra lang bs) + case plutusLangInEra @era lang of + Nothing -> Left $ plutusLanguageNotSupportedInEraError lang + Just PlutusLangInEraEvidence -> + AnyPlutusScript + <$> obtainLangConstraints lang (deserialisePlutusScriptInEra lang bs) + +-- | The decoder error reported when a script's language is not in the era's +-- 'PlutusLangInEra' table. +plutusLanguageNotSupportedInEraError :: L.SLanguage lang -> CBOR.DecoderError +plutusLanguageNotSupportedInEraError lang = + CBOR.DecoderErrorCustom "PlutusScriptInEra" $ + "Plutus language " + <> plutusLanguageToText (obtainLangConstraints lang (AnyPlutusScriptLanguage lang)) + <> " is not supported in this era" obtainLangConstraints :: L.SLanguage lang @@ -225,7 +251,7 @@ 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 @@ -234,18 +260,23 @@ serialiseAnyPlutusScriptToTextEnvelope mbDescr (AnyPlutusScript script) = -- 'Plutus.nonNativeLanguages', so new language versions are picked up automatically. deserialiseAnyPlutusScriptFromTextEnvelope :: forall era - . L.Era era + . (L.Era era, PlutusLangsInEra era) => TextEnvelope -> Either TextEnvelopeError (AnyPlutusScript era) deserialiseAnyPlutusScriptFromTextEnvelope = deserialiseFromTextEnvelopeAnyOf textEnvTypes where + -- Languages the era does not support are left out, so their envelope types + -- are rejected as unknown rather than decoded into an unusable script. 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 + Nothing -> [] + Just PlutusLangInEraEvidence -> + obtainLangConstraints slang $ + [FromSomeType (asType @(PlutusScriptInEra l era)) AnyPlutusScript] ) Plutus.nonNativeLanguages From 822a30535e23602300a88e22e382c46c57732106 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 2 Oct 2026 12:44:00 -0400 Subject: [PATCH 4/8] Discharge PlutusLangInEra at the AnyScript deserialisation boundary AnyScript is where cardano-cli reads script files for every era, so this is where the runtime check pays once. AnyScript.hs:133 deserialiseAnyPlutusScriptOfLanguage lang and era are both type variables. Look up PlutusLangsInEra evidence; Nothing becomes a decoder error. AnyScript.hs:107 tryPlutusScript the ledger's withPlutusScript hands over an existential language with no era evidence. Look it up; Nothing falls through to the next decoder. Ledger only yields scripts valid for the era, so this Nothing is unreachable, but GHC cannot know that. AnyScript.hs:204 readTextEnvelopeScript needs PlutusLangsInEra (LedgerEra era) from obtainCommonConstraints, so EraCommonConstraints gains it. The SerialiseAsCBOR (AnyScript era) instance gains PlutusLangsInEra era in its context for the same reason. Does not compile. GHC now stops at the function this chain started from: AnyScriptWitness.hs:273:6: error: [-Wredundant-constraints] Redundant constraint: PlutusLangInEra lang era In the type signature for: fromPlutusRunnable Nothing in the body consumes the constraint. Ledger's mkPlutusScript is value-level and still returns Maybe, so the constraint on the function does no work GHC can see. The next commit addresses that. --- .../src/Cardano/Api/Experimental/AnyScript.hs | 19 +++++++++++-------- .../src/Cardano/Api/Experimental/Era.hs | 2 ++ 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs b/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs index 87e7c01be2..3691842941 100644 --- a/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs +++ b/cardano-api/src/Cardano/Api/Experimental/AnyScript.hs @@ -75,7 +75,7 @@ instance Eq (AnyScript era) where _ == _ = False instance - L.AlonzoEraScript era + (L.AlonzoEraScript era, PlutusLangsInEra era) => SerialiseAsCBOR (AnyScript era) where serialiseToCBOR (AnySimpleScript (SimpleScript ns)) = @@ -102,10 +102,11 @@ 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 :: Plutus.Plutus l) -> do + PlutusLangInEraEvidence <- plutusLangInEra @era (Plutus.plutusSLanguage (Proxy @l)) let plutusRunnable = Plutus.decodePlutusRunnable (L.eraProtVerHigh @era) plutus - in AnyPlutusScript . PlutusScriptInEra - <$> (plutusRunnable <$ rightToMaybe (Plutus.plutusRunnableResult plutusRunnable)) + AnyPlutusScript . PlutusScriptInEra + <$> (plutusRunnable <$ rightToMaybe (Plutus.plutusRunnableResult plutusRunnable)) noParseError :: CBOR.DecoderError noParseError = @@ -128,10 +129,12 @@ 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 +deserialiseAnyPlutusScriptOfLanguage bs lang = obtainCommonConstraints (useEra @era) $ + case plutusLangInEra @(LedgerEra era) lang of + Nothing -> Left $ plutusLanguageNotSupportedInEraError lang + Just PlutusLangInEraEvidence -> do + s :: (PlutusScriptInEra lang (LedgerEra era)) <- deserialisePlutusScriptInEra lang bs + return $ AnyPlutusScript s data AnyScriptDecodeError = -- | A text envelope was decoded, but its Plutus CBOR payload could not be. diff --git a/cardano-api/src/Cardano/Api/Experimental/Era.hs b/cardano-api/src/Cardano/Api/Experimental/Era.hs index 6ee036d527..2a2486da40 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 (PlutusLangsInEra) 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) + , PlutusLangsInEra (LedgerEra era) , HasTypeProxy era , Ord (L.PlutusPurpose L.AsIx (LedgerEra era)) , L.GovState (LedgerEra era) ~ L.ConwayGovState (LedgerEra era) From c2be7b3a04be3bf31ebb4321bd91f800c03b59e8 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 2 Oct 2026 12:45:33 -0400 Subject: [PATCH 5/8] Move fromPlutusRunnable's restriction from a constraint to its argument type GHC rejected the previous signature: AnyScriptWitness.hs:273:6: error: [-Wredundant-constraints] Redundant constraint: PlutusLangInEra lang era In the type signature for: fromPlutusRunnable The constraint did no work in the body because ledger's mkPlutusScript is value-level and still returns Maybe. The restriction that actually holds is on the constructor, so fromPlutusRunnable now takes the PlutusScriptInEra lang era itself. That type is only inhabited for pairings in the PlutusLangInEra table, so the signature still excludes invalid pairings, and the Nothing branch stays unreachable. Does not compile. The legacy shim is next. GHC stops at its first error, the Either wrapper added by the PR around a function that no longer returns Either: LegacyScripts.hs:401:12: error: Couldn't match expected type: Either a0 (TxScriptWitnessRequirements ...) with actual type: TxScriptWitnessRequirements ... Behind it, mkPlutusScriptWitness builds PlutusScriptInEra four times with lang and era abstract over AlonzoEraOnwards, and will demand PlutusLangInEra plutuslang (ShelleyLedgerEra era). --- .../Api/Experimental/AnyScriptWitness.hs | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs b/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs index f91cc2e489..a7dc06bdd8 100644 --- a/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs +++ b/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module Cardano.Api.Experimental.AnyScriptWitness @@ -22,7 +23,6 @@ module Cardano.Api.Experimental.AnyScriptWitness ) where -import Cardano.Api.Experimental.Plutus.Internal.Language import Cardano.Api.Experimental.Plutus.Internal.Script import Cardano.Api.Experimental.Plutus.Internal.ScriptWitness import Cardano.Api.Experimental.Simple.Script @@ -259,26 +259,26 @@ resolvePlutusWitnessScript :: L.AlonzoEraScript era => PlutusScriptWitness lang purpose era -> Maybe (L.Script era) -resolvePlutusWitnessScript (PlutusScriptWitness slang (PScript (PlutusScriptInEra runnable)) _ _ _) = - Just . L.fromPlutusScript $ fromPlutusRunnable slang runnable +resolvePlutusWitnessScript (PlutusScriptWitness _ (PScript s) _ _ _) = + Just . L.fromPlutusScript $ fromPlutusRunnable s resolvePlutusWitnessScript (PlutusScriptWitness _ PReferenceScript{} _ _ _) = Nothing -- | Convert a runnable script to the era's ledger script type. -- --- Ledger's 'L.mkPlutusScript' returns 'Nothing' when the era does not support --- the language. 'PlutusLangInEra' excludes that pairing at the type level, so --- the 'Nothing' branch is unreachable and the result is total. +-- The argument type is the restriction: a 'PlutusScriptInEra' can only be +-- built for a language/era pairing in the 'PlutusLangInEra' table. Ledger's +-- 'L.mkPlutusScript' only returns 'Nothing' for a pairing outside that table, +-- so the 'Nothing' branch is unreachable and the result is total. fromPlutusRunnable :: forall era lang - . (L.AlonzoEraScript era, L.PlutusLanguage lang, PlutusLangInEra lang era) - => L.SLanguage lang - -> L.PlutusRunnable lang + . L.AlonzoEraScript era + => PlutusScriptInEra lang era -> L.PlutusScript era -fromPlutusRunnable slang runnable = +fromPlutusRunnable (PlutusScriptInEra runnable) = case L.mkPlutusScript $ L.plutusFromRunnable runnable of Just script -> script Nothing -> error $ "fromPlutusRunnable: unreachable, PlutusLangInEra excludes " - <> show (L.plutusLanguage slang) + <> show (L.plutusLanguage (L.plutusSLanguage (Proxy @lang))) <> " in this era" From 888d9614e3bf6c589914e18bbca5aa990de1edb2 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 2 Oct 2026 12:46:41 -0400 Subject: [PATCH 6/8] Derive PlutusLangInEra evidence from the legacy ScriptLanguageInEra proof The legacy Old.PlutusScriptWitness already carries a ScriptLanguageInEra lang era proof that the shim was discarding with a wildcard. Matching its ten Plutus constructors yields PlutusLangInEraEvidence for the ledger era; the seven simple-script constructors are closed with EmptyCase on the PlutusScriptVersion, which has no SimpleScript' inhabitant. mkPlutusScriptWitness gains PlutusLangInEra plutuslang (ShelleyLedgerEra era) in its context, discharged by matching the evidence in toNewPlutusScriptWitness. The error call the PR added to legacyWitnessToScriptRequirements is removed, since the Either it guarded is gone. This is why the PlutusLangInEra table has Alonzo and Babbage rows: the legacy createTransactionBody path reaches this shim for every era from Alonzo onwards. The library compiles. Tests and generators do not yet. --- .../Plutus/Internal/Shim/LegacyScripts.hs | 71 ++++++++++++------- 1 file changed, 47 insertions(+), 24 deletions(-) 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..e3ddd629db 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 @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -54,7 +55,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 +89,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 +161,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 +172,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 = @@ -181,16 +183,18 @@ toNewPlutusScriptWitness eon w l (Old.PScript (Old.PlutusScriptSerialised script 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 = + case legacyPlutusLangInEraEvidence langInEra l of + PlutusLangInEraEvidence -> + return $ + mkPlutusScriptWitness + eon + w + (toPlutusSLanguage l) + plutusScriptRunnable + datum + scriptRedeemer + execUnits +toNewPlutusScriptWitness _ w _ l (Old.PReferenceScript refInput) scriptRedeemer execUnits datum = return $ mkReferencePlutusScriptWitness w (toPlutusSLanguage l) refInput datum scriptRedeemer execUnits @@ -202,9 +206,36 @@ type family PlutusScriptFor thing where PlutusScriptFor VoterItem = VotingScript PlutusScriptFor ProposalItem = ProposingScript +-- | A legacy witness carries a 'Old.ScriptLanguageInEra' proof that the era +-- supports its language. This turns that proof into the evidence the +-- experimental 'PlutusScriptInEra' constructor demands. +legacyPlutusLangInEraEvidence + :: Old.ScriptLanguageInEra lang era + -> Old.PlutusScriptVersion lang + -> PlutusLangInEraEvidence (Old.ToLedgerPlutusLanguage lang) (ShelleyLedgerEra era) +legacyPlutusLangInEraEvidence langInEra v = case langInEra of + Old.PlutusScriptV1InAlonzo -> PlutusLangInEraEvidence + Old.PlutusScriptV1InBabbage -> PlutusLangInEraEvidence + Old.PlutusScriptV1InConway -> PlutusLangInEraEvidence + Old.PlutusScriptV1InDijkstra -> PlutusLangInEraEvidence + Old.PlutusScriptV2InBabbage -> PlutusLangInEraEvidence + Old.PlutusScriptV2InConway -> PlutusLangInEraEvidence + Old.PlutusScriptV2InDijkstra -> PlutusLangInEraEvidence + Old.PlutusScriptV3InConway -> PlutusLangInEraEvidence + Old.PlutusScriptV3InDijkstra -> PlutusLangInEraEvidence + Old.PlutusScriptV4InDijkstra -> PlutusLangInEraEvidence + -- There is no 'Old.PlutusScriptVersion SimpleScript'', so these arms are unreachable. + Old.SimpleScriptInShelley -> case v of {} + Old.SimpleScriptInAllegra -> case v of {} + Old.SimpleScriptInMary -> case v of {} + Old.SimpleScriptInAlonzo -> case v of {} + Old.SimpleScriptInBabbage -> case v of {} + Old.SimpleScriptInConway -> case v of {} + Old.SimpleScriptInDijkstra -> case v of {} + mkPlutusScriptWitness :: forall era thing plutuslang - . L.PlutusLanguage plutuslang + . (L.PlutusLanguage plutuslang, PlutusLangInEra plutuslang (ShelleyLedgerEra era)) => AlonzoEraOnwards era -> Witnessable thing (ShelleyLedgerEra era) -> L.SLanguage plutuslang @@ -382,8 +413,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 +421,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 From 8e6eb5493d9397a3fe5f185b8013d9fb197ec0b6 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 2 Oct 2026 12:51:11 -0400 Subject: [PATCH 7/8] Export the table, update generators, tests and the changelog Cardano.Api.Experimental and Cardano.Api.Experimental.Plutus export PlutusLangInEra, PlutusLangInEraEvidence and PlutusLangsInEra. assertValidPlutusScriptBytesExperimental is polymorphic in both lang and era, so it looks up evidence before deserialising. The PR's test that built a PlutusV4 inline witness in Conway no longer typechecks, which is the point of the change. It is replaced by a test that deserialising V4 bytes in Conway fails. Compiles. cardano-api-test and cardano-api-golden pass. --- ...l-tx-unsupported-plutus-language-error.yml | 7 ++-- .../gen/Test/Hedgehog/Roundtrip/CBOR.hs | 12 ++++-- cardano-api/src/Cardano/Api/Experimental.hs | 3 ++ .../src/Cardano/Api/Experimental/Plutus.hs | 3 ++ .../Api/Transaction/Body/Plutus/Scripts.hs | 41 +++++++------------ 5 files changed, 31 insertions(+), 35 deletions(-) diff --git a/.changes/experimental-tx-unsupported-plutus-language-error.yml b/.changes/experimental-tx-unsupported-plutus-language-error.yml index add22b86ed..f4e491b807 100644 --- a/.changes/experimental-tx-unsupported-plutus-language-error.yml +++ b/.changes/experimental-tx-unsupported-plutus-language-error.yml @@ -4,7 +4,6 @@ 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`. + The `PlutusScriptInEra` constructor now requires the type-level `PlutusLangInEra lang era` constraint, so a Plutus script in a language the era does not support cannot be placed in an experimental transaction. 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: `deserialiseAnyPlutusScriptOfLanguage`, `decodeAnyPlutusScript` and the `SerialiseAsCBOR` instances for `PlutusScriptInEra` and `AnyScript` reject an unsupported language, and `deserialiseAnyPlutusScriptFromTextEnvelope` no longer accepts envelope types for such languages. + New `PlutusLangsInEra` class and `PlutusLangInEraEvidence` witness provide the runtime evidence for code that learns the language at runtime. `EraCommonConstraints` now includes `PlutusLangsInEra (LedgerEra era)`. diff --git a/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs b/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs index aaa78242e5..f26e0f7860 100644 --- a/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs +++ b/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs @@ -111,7 +111,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.PlutusLangInEraEvidence -> + case 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 diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs index c460c78667..35800d385d 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -92,6 +92,9 @@ module Cardano.Api.Experimental -- ** Plutus related , AnyPlutusScriptLanguage (..) , PlutusScriptInEra (..) + , PlutusLangInEra + , PlutusLangInEraEvidence (..) + , PlutusLangsInEra (..) , PlutusScriptOrReferenceInput (..) , serialiseAnyPlutusScriptToTextEnvelope , deserialiseAnyPlutusScriptFromTextEnvelope diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus.hs index b46384f942..7d4bb93245 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus.hs @@ -5,6 +5,9 @@ module Cardano.Api.Experimental.Plutus , serialiseAnyPlutusScriptToTextEnvelope , deserialiseAnyPlutusScriptFromTextEnvelope , PlutusScriptInEra (..) + , PlutusLangInEra + , PlutusLangInEraEvidence (..) + , PlutusLangsInEra (..) , AnyPlutusScriptLanguage (..) , deserialisePlutusScriptInEra , hashPlutusScriptInEra 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..1391669741 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 @@ -225,32 +225,19 @@ 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 +-- | A Plutus script whose language the era does not support is representable +-- only through deserialisation, and that is where it must be rejected. V4 fails +-- in Conway. An inline witness of such a script cannot even be written, because +-- 'PlutusScriptInEra' demands 'PlutusLangInEra' at the type level. +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 deserialiseAnyPlutusScriptOfLanguage @ConwayEra v4Bytes L.SPlutusV4 of + Left _ -> success + Right _ -> do + annotate "PlutusV4 must not deserialise in Conway" + 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 +385,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 From 0e243ece673f5ea93b9f9809668607a2b5d22ef6 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Thu, 8 Oct 2026 09:58:20 +0200 Subject: [PATCH 8/8] Replace the Plutus language table with a constraint-carrying GADT PlutusLangInEra lang era is now a single-constructor GADT holding the language singleton, with the ledger's EraPlutusTxInfo lang era class as its context, so the ledger's instances are the table and cardano-api keeps no copy. An unsupported pairing has no ledger instance, so the closed type family, its TypeError and UndecidableInstances go. plutusLangInShelleyBasedEra gives the proof at runtime from a ShelleyBasedEra witness by asking the ledger's mkSupportedLanguage, and HasPlutusLangInEra wraps it for code that only has the ledger era, with instances for all seven eras. PlutusScriptInEra carries the ledger script next to the runnable, built by mkPlutusScriptInEra under the EraPlutusTxInfo constraint through the ledger's mkSupportedPlutusScript, so plutusScriptInEraToScript is a field read and fromPlutusRunnable goes. The unsupported language error names the era, and the text envelope decoder recognises the envelope's language before the type lookup so that error is reported instead of an unknown envelope type. The SerialiseAsCBOR and HasTextEnvelope instances of PlutusScriptInEra require EraPlutusTxInfo lang era, so they exist only for supported pairings and carry no runtime check. --- ...l-tx-unsupported-plutus-language-error.yml | 15 +- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 2 +- .../gen/Test/Hedgehog/Roundtrip/CBOR.hs | 5 +- cardano-api/src/Cardano/Api/Experimental.hs | 7 +- .../src/Cardano/Api/Experimental/AnyScript.hs | 28 ++- .../Api/Experimental/AnyScriptWitness.hs | 32 +--- .../src/Cardano/Api/Experimental/Era.hs | 4 +- .../src/Cardano/Api/Experimental/Plutus.hs | 7 +- .../Experimental/Plutus/Internal/Language.hs | 167 ++++++++++-------- .../Experimental/Plutus/Internal/Script.hs | 132 ++++++++------ .../Plutus/Internal/ScriptWitness.hs | 2 +- .../Plutus/Internal/Shim/LegacyScripts.hs | 60 +++---- .../Experimental/Tx/Internal/AnyWitness.hs | 5 +- .../src/Cardano/Api/Tx/Internal/Body.hs | 2 + .../Api/Transaction/Body/Plutus/Scripts.hs | 17 +- 15 files changed, 238 insertions(+), 247 deletions(-) diff --git a/.changes/experimental-tx-unsupported-plutus-language-error.yml b/.changes/experimental-tx-unsupported-plutus-language-error.yml index f4e491b807..868611b3f1 100644 --- a/.changes/experimental-tx-unsupported-plutus-language-error.yml +++ b/.changes/experimental-tx-unsupported-plutus-language-error.yml @@ -4,6 +4,15 @@ kind: - breaking - bugfix description: | - The `PlutusScriptInEra` constructor now requires the type-level `PlutusLangInEra lang era` constraint, so a Plutus script in a language the era does not support cannot be placed in an experimental transaction. 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: `deserialiseAnyPlutusScriptOfLanguage`, `decodeAnyPlutusScript` and the `SerialiseAsCBOR` instances for `PlutusScriptInEra` and `AnyScript` reject an unsupported language, and `deserialiseAnyPlutusScriptFromTextEnvelope` no longer accepts envelope types for such languages. - New `PlutusLangsInEra` class and `PlutusLangInEraEvidence` witness provide the runtime evidence for code that learns the language at runtime. `EraCommonConstraints` now includes `PlutusLangsInEra (LedgerEra 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/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 f26e0f7860..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 @@ -114,8 +113,8 @@ assertValidPlutusScriptBytesExperimental era scriptBytes lang = do Exp.obtainCommonConstraints era $ case Exp.plutusLangInEra @(Exp.LedgerEra era) lang of Nothing -> failWith Nothing "Plutus lang: language not supported in era" - Just Exp.PlutusLangInEraEvidence -> - case Exp.deserialisePlutusScriptInEra lang scriptBytes + 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 35800d385d..2d57c71355 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -92,9 +92,10 @@ module Cardano.Api.Experimental -- ** Plutus related , AnyPlutusScriptLanguage (..) , PlutusScriptInEra (..) - , PlutusLangInEra - , PlutusLangInEraEvidence (..) - , PlutusLangsInEra (..) + , 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 3691842941..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, PlutusLangsInEra 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,11 +101,10 @@ instance tryPlutusScript :: L.Script era -> Maybe (AnyScript era) tryPlutusScript script = do ps <- L.toPlutusScript script - L.withPlutusScript ps $ \(plutus :: Plutus.Plutus l) -> do - PlutusLangInEraEvidence <- plutusLangInEra @era (Plutus.plutusSLanguage (Proxy @l)) + L.withPlutusScript ps $ \plutus -> do let plutusRunnable = Plutus.decodePlutusRunnable (L.eraProtVerHigh @era) plutus - AnyPlutusScript . PlutusScriptInEra - <$> (plutusRunnable <$ rightToMaybe (Plutus.plutusRunnableResult plutusRunnable)) + AnyPlutusScript (PlutusScriptInEra plutusRunnable ps) + <$ rightToMaybe (Plutus.plutusRunnableResult plutusRunnable) noParseError :: CBOR.DecoderError noParseError = @@ -125,16 +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 = obtainCommonConstraints (useEra @era) $ - case plutusLangInEra @(LedgerEra era) lang of - Nothing -> Left $ plutusLanguageNotSupportedInEraError lang - Just PlutusLangInEraEvidence -> do - s :: (PlutusScriptInEra lang (LedgerEra 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 a7dc06bdd8..a158b13ca4 100644 --- a/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs +++ b/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs @@ -3,7 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module Cardano.Api.Experimental.AnyScriptWitness @@ -235,8 +234,7 @@ getAnyPlutusScriptData AnyPlutusProposingScriptWitness{} = mempty getAnyPlutusScriptData AnyPlutusVotingScriptWitness{} = mempty getAnyPlutusWitnessPlutusScript - :: L.AlonzoEraScript era - => AnyPlutusScriptWitness lang purpose era + :: AnyPlutusScriptWitness lang purpose era -> Maybe (L.Script era) getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV1 s)) = resolvePlutusWitnessScript s @@ -253,32 +251,10 @@ getAnyPlutusWitnessPlutusScript (AnyPlutusProposingScriptWitness s) = resolvePlu getAnyPlutusWitnessPlutusScript (AnyPlutusVotingScriptWitness s) = resolvePlutusWitnessScript s -- | A reference witness carries no script, so it resolves to 'Nothing'. --- An inline witness always resolves: the 'PlutusScriptInEra' it holds is the --- proof that the era supports the language. +-- An inline witness holds the ledger script, built when its era was checked. resolvePlutusWitnessScript - :: L.AlonzoEraScript era - => PlutusScriptWitness lang purpose era + :: PlutusScriptWitness lang purpose era -> Maybe (L.Script era) resolvePlutusWitnessScript (PlutusScriptWitness _ (PScript s) _ _ _) = - Just . L.fromPlutusScript $ fromPlutusRunnable s + Just $ plutusScriptInEraToScript s resolvePlutusWitnessScript (PlutusScriptWitness _ PReferenceScript{} _ _ _) = Nothing - --- | Convert a runnable script to the era's ledger script type. --- --- The argument type is the restriction: a 'PlutusScriptInEra' can only be --- built for a language/era pairing in the 'PlutusLangInEra' table. Ledger's --- 'L.mkPlutusScript' only returns 'Nothing' for a pairing outside that table, --- so the 'Nothing' branch is unreachable and the result is total. -fromPlutusRunnable - :: forall era lang - . L.AlonzoEraScript era - => PlutusScriptInEra lang era - -> L.PlutusScript era -fromPlutusRunnable (PlutusScriptInEra runnable) = - case L.mkPlutusScript $ L.plutusFromRunnable runnable of - Just script -> script - Nothing -> - error $ - "fromPlutusRunnable: unreachable, PlutusLangInEra excludes " - <> show (L.plutusLanguage (L.plutusSLanguage (Proxy @lang))) - <> " in this era" diff --git a/cardano-api/src/Cardano/Api/Experimental/Era.hs b/cardano-api/src/Cardano/Api/Experimental/Era.hs index 2a2486da40..32c9142155 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Era.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Era.hs @@ -46,7 +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 (PlutusLangsInEra) +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 @@ -319,7 +319,7 @@ type EraCommonConstraints era = , L.EraTxCert (LedgerEra era) , L.EraTxOut (LedgerEra era) , L.EraUTxO (LedgerEra era) - , PlutusLangsInEra (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 7d4bb93245..3cf9c5b9f4 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus.hs @@ -5,9 +5,10 @@ module Cardano.Api.Experimental.Plutus , serialiseAnyPlutusScriptToTextEnvelope , deserialiseAnyPlutusScriptFromTextEnvelope , PlutusScriptInEra (..) - , PlutusLangInEra - , PlutusLangInEraEvidence (..) - , PlutusLangsInEra (..) + , 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 index 9009297421..107c5eb179 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Language.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Language.hs @@ -1,89 +1,100 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} --- | Which Plutus languages each ledger era accepts, as a type-level table. +-- | Which Plutus languages each ledger era accepts. -- --- The table mirrors ledger's 'L.eraMaxLanguage' and must be extended when a new --- era or Plutus language lands. It is consulted in two ways: --- --- * At compile time, 'PlutusLangInEra' is a constraint on the 'PlutusScriptInEra' --- constructor. A pairing the table does not list is a type error, so a script --- with an unsupported language cannot be placed in a transaction for that era. --- --- * At runtime, 'plutusLangInEra' reflects the table back as a value. Code that --- only learns the language at runtime, such as a deserialiser, uses it to --- obtain the evidence the constructor demands. GHC checks each row of --- 'plutusLangInEra' against the type family, so the two cannot disagree. +-- 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 - , PlutusLangInEraEvidence (..) - , PlutusLangsInEra (..) + ( 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.Kind (Constraint, Type) -import GHC.TypeLits (ErrorMessage (..), TypeError) - --- | Holds when the ledger era @era@ accepts Plutus scripts of language @lang@. -type family PlutusLangInEra (lang :: L.Language) (era :: Type) :: Constraint where - PlutusLangInEra 'L.PlutusV1 L.AlonzoEra = () - PlutusLangInEra 'L.PlutusV1 L.BabbageEra = () - PlutusLangInEra 'L.PlutusV2 L.BabbageEra = () - PlutusLangInEra 'L.PlutusV1 L.ConwayEra = () - PlutusLangInEra 'L.PlutusV2 L.ConwayEra = () - PlutusLangInEra 'L.PlutusV3 L.ConwayEra = () - PlutusLangInEra 'L.PlutusV1 L.DijkstraEra = () - PlutusLangInEra 'L.PlutusV2 L.DijkstraEra = () - PlutusLangInEra 'L.PlutusV3 L.DijkstraEra = () - PlutusLangInEra 'L.PlutusV4 L.DijkstraEra = () - PlutusLangInEra lang era = - TypeError - ( 'Text "Plutus language " - ':<>: 'ShowType lang - ':<>: 'Text " is not supported in the ledger era " - ':<>: 'ShowType era - ) - --- | Runtime evidence that 'PlutusLangInEra' holds. Pattern matching on the --- constructor brings the constraint into scope. -data PlutusLangInEraEvidence (lang :: L.Language) era where - PlutusLangInEraEvidence :: PlutusLangInEra lang era => PlutusLangInEraEvidence lang era - --- | The value-level reflection of 'PlutusLangInEra', one instance per ledger era. -class PlutusLangsInEra era where - plutusLangInEra :: L.SLanguage lang -> Maybe (PlutusLangInEraEvidence lang era) - -instance PlutusLangsInEra L.AlonzoEra where - plutusLangInEra = \case - L.SPlutusV1 -> Just PlutusLangInEraEvidence - L.SPlutusV2 -> Nothing - L.SPlutusV3 -> Nothing - L.SPlutusV4 -> Nothing - -instance PlutusLangsInEra L.BabbageEra where - plutusLangInEra = \case - L.SPlutusV1 -> Just PlutusLangInEraEvidence - L.SPlutusV2 -> Just PlutusLangInEraEvidence - L.SPlutusV3 -> Nothing - L.SPlutusV4 -> Nothing - -instance PlutusLangsInEra L.ConwayEra where - plutusLangInEra = \case - L.SPlutusV1 -> Just PlutusLangInEraEvidence - L.SPlutusV2 -> Just PlutusLangInEraEvidence - L.SPlutusV3 -> Just PlutusLangInEraEvidence - L.SPlutusV4 -> Nothing - -instance PlutusLangsInEra L.DijkstraEra where - plutusLangInEra = \case - L.SPlutusV1 -> Just PlutusLangInEraEvidence - L.SPlutusV2 -> Just PlutusLangInEraEvidence - L.SPlutusV3 -> Just PlutusLangInEraEvidence - L.SPlutusV4 -> Just PlutusLangInEraEvidence +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 15ec4cb02b..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 #-} @@ -7,7 +8,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} module Cardano.Api.Experimental.Plutus.Internal.Script ( AnyPlutusScript (..) @@ -16,9 +16,10 @@ module Cardano.Api.Experimental.Plutus.Internal.Script , deserialiseAnyPlutusScriptFromTextEnvelope , AnyPlutusScriptLanguage (..) , PlutusScriptInEra (..) - , PlutusLangInEra - , PlutusLangInEraEvidence (..) - , PlutusLangsInEra (..) + , mkPlutusScriptInEra + , PlutusLangInEra (..) + , HasPlutusLangInEra (..) + , plutusLangInShelleyBasedEra , PlutusScriptOrReferenceInput (..) , AsType (..) , deserialisePlutusScriptInEra @@ -43,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 @@ -74,15 +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, PlutusLangInEra lang era) - => PlutusRunnable lang -> PlutusScriptInEra lang era + :: (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) @@ -93,7 +109,7 @@ instance instance ( Plutus.PlutusLanguage lang , L.Era era - , PlutusLangInEra lang era + , L.EraPlutusTxInfo lang era , HasTypeProxy (Plutus.SLanguage lang) ) => HasTextEnvelope (PlutusScriptInEra lang era) @@ -125,8 +141,7 @@ instance ( L.Era era , Typeable era , Typeable lang - , Plutus.PlutusLanguage lang - , PlutusLangInEra lang era + , L.EraPlutusTxInfo lang era , HasTypeProxy (Plutus.SLanguage lang) ) => SerialiseAsCBOR (PlutusScriptInEra (lang :: L.Language) era) @@ -134,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), PlutusLangInEra lang era) - => 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. @@ -196,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 @@ -210,25 +220,28 @@ instance Eq (AnyPlutusScript era) where decodeAnyPlutusScript :: forall era - . (L.Era era, PlutusLangsInEra era) + . (L.Era era, HasPlutusLangInEra era) => ByteString -> AnyPlutusScriptLanguage -> Either CBOR.DecoderError (AnyPlutusScript era) -decodeAnyPlutusScript bs (AnyPlutusScriptLanguage lang) = +decodeAnyPlutusScript bs (AnyPlutusScriptLanguage (lang :: L.SLanguage lang)) = case plutusLangInEra @era lang of - Nothing -> Left $ plutusLanguageNotSupportedInEraError lang - Just PlutusLangInEraEvidence -> + Nothing -> Left $ plutusLanguageNotSupportedInEraError @era lang + Just (PlutusLangInEra _) -> AnyPlutusScript - <$> obtainLangConstraints lang (deserialisePlutusScriptInEra lang bs) + <$> obtainLangConstraints lang (deserialisePlutusScriptInEra @era @lang bs) -- | The decoder error reported when a script's language is not in the era's --- 'PlutusLangInEra' table. -plutusLanguageNotSupportedInEraError :: L.SLanguage lang -> CBOR.DecoderError +-- '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 this era" + <> " is not supported in the " + <> Text.pack (L.eraName @era) + <> " era" obtainLangConstraints :: L.SLanguage lang @@ -256,27 +269,32 @@ serialiseAnyPlutusScriptToTextEnvelope mbDescr (AnyPlutusScript script@PlutusScr 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, PlutusLangsInEra 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 - -- Languages the era does not support are left out, so their envelope types - -- are rejected as unknown rather than decoded into an unusable script. + 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 = concatMap ( \l -> Plutus.withSLanguage l $ \(slang :: Plutus.SLanguage l) -> case plutusLangInEra @era slang of + Just (PlutusLangInEra _) -> + obtainLangConstraints slang [FromSomeType (asType @(PlutusScriptInEra l era)) AnyPlutusScript] Nothing -> [] - Just PlutusLangInEraEvidence -> - obtainLangConstraints slang $ - [FromSomeType (asType @(PlutusScriptInEra l era)) AnyPlutusScript] ) 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 e3ddd629db..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 @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -182,15 +181,23 @@ toNewPlutusScriptWitness eon w langInEra l (Old.PScript (Old.PlutusScriptSeriali Left e -> Left $ CBOR.DecoderErrorCustom "PlutusLedgerApi.Common.ScriptDecodeError" (Text.pack . show $ pretty e) - Right{} -> - case legacyPlutusLangInEraEvidence langInEra l of - PlutusLangInEraEvidence -> + 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 - (toPlutusSLanguage l) - plutusScriptRunnable + slang + (mkPlutusScriptInEra plutusScriptRunnable) datum scriptRedeemer execUnits @@ -206,47 +213,20 @@ type family PlutusScriptFor thing where PlutusScriptFor VoterItem = VotingScript PlutusScriptFor ProposalItem = ProposingScript --- | A legacy witness carries a 'Old.ScriptLanguageInEra' proof that the era --- supports its language. This turns that proof into the evidence the --- experimental 'PlutusScriptInEra' constructor demands. -legacyPlutusLangInEraEvidence - :: Old.ScriptLanguageInEra lang era - -> Old.PlutusScriptVersion lang - -> PlutusLangInEraEvidence (Old.ToLedgerPlutusLanguage lang) (ShelleyLedgerEra era) -legacyPlutusLangInEraEvidence langInEra v = case langInEra of - Old.PlutusScriptV1InAlonzo -> PlutusLangInEraEvidence - Old.PlutusScriptV1InBabbage -> PlutusLangInEraEvidence - Old.PlutusScriptV1InConway -> PlutusLangInEraEvidence - Old.PlutusScriptV1InDijkstra -> PlutusLangInEraEvidence - Old.PlutusScriptV2InBabbage -> PlutusLangInEraEvidence - Old.PlutusScriptV2InConway -> PlutusLangInEraEvidence - Old.PlutusScriptV2InDijkstra -> PlutusLangInEraEvidence - Old.PlutusScriptV3InConway -> PlutusLangInEraEvidence - Old.PlutusScriptV3InDijkstra -> PlutusLangInEraEvidence - Old.PlutusScriptV4InDijkstra -> PlutusLangInEraEvidence - -- There is no 'Old.PlutusScriptVersion SimpleScript'', so these arms are unreachable. - Old.SimpleScriptInShelley -> case v of {} - Old.SimpleScriptInAllegra -> case v of {} - Old.SimpleScriptInMary -> case v of {} - Old.SimpleScriptInAlonzo -> case v of {} - Old.SimpleScriptInBabbage -> case v of {} - Old.SimpleScriptInConway -> case v of {} - Old.SimpleScriptInDijkstra -> case v of {} - mkPlutusScriptWitness :: forall era thing plutuslang - . (L.PlutusLanguage plutuslang, PlutusLangInEra plutuslang (ShelleyLedgerEra era)) + . L.PlutusLanguage plutuslang => 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 @@ -292,7 +272,7 @@ mkPlutusScriptWitness eon w l plutusScriptRunnable d r e = AnyPlutusWithdrawingScriptWitness ( PlutusScriptWitness l - (PScript $ PlutusScriptInEra plutusScriptRunnable) + script' d r e @@ -302,7 +282,7 @@ mkPlutusScriptWitness eon w l plutusScriptRunnable d r e = AnyPlutusVotingScriptWitness ( PlutusScriptWitness l - (PScript $ PlutusScriptInEra plutusScriptRunnable) + script' d r e @@ -312,7 +292,7 @@ mkPlutusScriptWitness eon w l plutusScriptRunnable d r e = AnyPlutusProposingScriptWitness ( PlutusScriptWitness l - (PScript $ PlutusScriptInEra plutusScriptRunnable) + script' d r e 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 7af8ebe606..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,8 +90,7 @@ getAnyWitnessSimpleScript (AnySimpleScriptWitness simpleScriptOrRefInput) = getAnyWitnessSimpleScript (AnyPlutusScriptWitness _) = Nothing getAnyWitnessPlutusScript - :: L.AlonzoEraScript era - => AnyWitness era + :: AnyWitness era -> Maybe (L.Script era) getAnyWitnessPlutusScript AnyKeyWitnessPlaceholder = Nothing getAnyWitnessPlutusScript (AnySimpleScriptWitness _) = Nothing @@ -115,7 +114,7 @@ getAnyWitnessScriptData AnySimpleScriptWitness{} = mempty getAnyWitnessScriptData (AnyPlutusScriptWitness s) = getAnyPlutusScriptData s getAnyWitnessScript - :: L.AlonzoEraScript era => AnyWitness era -> Maybe (L.Script era) + :: AnyWitness era -> Maybe (L.Script era) getAnyWitnessScript AnyKeyWitnessPlaceholder = Nothing getAnyWitnessScript ss@(AnySimpleScriptWitness{}) = getAnyWitnessSimpleScript ss getAnyWitnessScript ps@(AnyPlutusScriptWitness{}) = getAnyWitnessPlutusScript ps 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 1391669741..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,19 +228,15 @@ prop_extractAllIndexedPlutusScriptWitnesses = length allGeneratedPlutusScriptWitnesses === length extractedPlutusScriptWitnesses --- | A Plutus script whose language the era does not support is representable --- only through deserialisation, and that is where it must be rejected. V4 fails --- in Conway. An inline witness of such a script cannot even be written, because --- 'PlutusScriptInEra' demands 'PlutusLangInEra' at the type level. +-- | 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 let v4Bytes = serialiseToCBOR v3ScriptInEra - case deserialiseAnyPlutusScriptOfLanguage @ConwayEra v4Bytes L.SPlutusV4 of - Left _ -> success - Right _ -> do - annotate "PlutusV4 must not deserialise in Conway" - failure + 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.