Check the Plutus script language against the era when scripts are deserialised

.changes/experimental-tx-unsupported-plutus-language-error.yml

@@ -4,7 +4,15 @@ kind:
   - breaking
   - bugfix
 description: |
-  `makeUnsignedTx` now fails with `MakeUnsignedTxPlutusLanguageNotSupportedInEra` when an inline Plutus script uses a language the era does not support.
-  Before, the script was silently dropped from the witness set while its redeemer was kept, so the transaction failed on submission.
-  `getAnyWitnessScript` and `getAnyPlutusWitnessPlutusScript` now return `Either L.Language` instead of `Maybe`.
-  `getTxScriptWitnessRequirements` and `getTxScriptWitnessesRequirements` now return `Either L.Language (TxScriptWitnessRequirements era)` instead of `TxScriptWitnessRequirements era`.
+  A `PlutusScriptInEra` can now only be built from a `PlutusLangInEra lang era` proof that the era supports the script language.
+  The proof is a single-constructor GADT that holds the language singleton, and its context is the ledger's `EraPlutusTxInfo lang era` class, so cardano-api holds no table of its own.
+  So you cannot put a Plutus script in an experimental transaction if the era does not support its language.
+  Before, such a script was silently dropped from the witness set while its redeemer was kept, so the transaction failed on submission.
+  The check happens once at deserialisation: `decodeAnyPlutusScript`, `deserialiseAnyPlutusScriptFromTextEnvelope` and the `SerialiseAsCBOR` instance for `AnyScript` reject an unsupported language.
+  The `SerialiseAsCBOR` and `HasTextEnvelope` instances of `PlutusScriptInEra` exist only for language and era pairings the ledger supports, so a wrong pairing is a compile error.
+  `PlutusScriptInEra` now holds the ledger script next to the runnable, built by the new `mkPlutusScriptInEra` function.
+  `mkPlutusScriptInEra`, `deserialisePlutusScriptInEra` and `deserialiseAnyPlutusScriptOfLanguage` take the ledger's `EraPlutusTxInfo lang era` constraint and cannot fail on the language.
+  The new `plutusLangInShelleyBasedEra` function and the new `HasPlutusLangInEra` class give this proof to code that learns the language only at runtime.
+  They ask the ledger's `mkSupportedLanguage`, so cardano-api keeps no table at runtime either.
+  `deserialisePlutusScriptInEra` and `deserialiseAnyPlutusScriptOfLanguage` no longer take the language singleton.
+  `EraCommonConstraints` now includes `HasPlutusLangInEra (LedgerEra era)`.

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

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
 

cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs

@@ -101,7 +101,6 @@ decodeOnlyPlutusScriptBytes _ _ scriptBytes typeProxy = do
 assertValidPlutusScriptBytesExperimental
   :: forall era lang m
    . H.MonadTest m
-  => HasTypeProxy (Plutus.SLanguage lang)
   => Plutus.PlutusLanguage lang
   => Exp.Era era
   -> ByteString
@@ -111,7 +110,11 @@ assertValidPlutusScriptBytesExperimental
 assertValidPlutusScriptBytesExperimental era scriptBytes lang = do
   -- Decode a plutus script (double wrapped or "normal" plutus script) with the existing SerialiseAsCBOR instance for
   -- 'Script lang'. This should produce plutus script bytes that are not double encoded.
-  case Exp.obtainCommonConstraints era $ Exp.deserialisePlutusScriptInEra lang scriptBytes
-         :: Either DecoderError (Exp.PlutusScriptInEra lang (Exp.LedgerEra era)) of
-    Left e -> failWith Nothing $ "Plutus lang: Error decoding script bytes: " ++ show (e :: DecoderError)
-    Right (Exp.PlutusScriptInEra{}) -> H.success
+  Exp.obtainCommonConstraints era $
+    case Exp.plutusLangInEra @(Exp.LedgerEra era) lang of
+      Nothing -> failWith Nothing "Plutus lang: language not supported in era"
+      Just (Exp.PlutusLangInEra _) ->
+        case Exp.deserialisePlutusScriptInEra scriptBytes
+               :: Either DecoderError (Exp.PlutusScriptInEra lang (Exp.LedgerEra era)) of
+          Left e -> failWith Nothing $ "Plutus lang: Error decoding script bytes: " ++ show (e :: DecoderError)
+          Right (Exp.PlutusScriptInEra{}) -> H.success

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

@@ -92,6 +92,10 @@ module Cardano.Api.Experimental
     -- ** Plutus related
   , AnyPlutusScriptLanguage (..)
   , PlutusScriptInEra (..)
+  , mkPlutusScriptInEra
+  , PlutusLangInEra (..)
+  , HasPlutusLangInEra (..)
+  , plutusLangInShelleyBasedEra
   , PlutusScriptOrReferenceInput (..)
   , serialiseAnyPlutusScriptToTextEnvelope
   , deserialiseAnyPlutusScriptFromTextEnvelope

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -38,6 +39,7 @@ import Cardano.Api.Serialise.Json (JsonDecodeError (..), deserialiseFromJSON)
 import Cardano.Api.Serialise.TextEnvelope (TextEnvelope (..), TextEnvelopeType (..))
 import Cardano.Api.Serialise.TextEnvelope.Internal (textEnvelopeType)
 
+import Cardano.Ledger.Alonzo.Plutus.Context qualified as L (EraPlutusTxInfo)
 import Cardano.Ledger.Binary qualified as CBOR
 import Cardano.Ledger.Core qualified as L
 import Cardano.Ledger.Plutus.Language qualified as Plutus
@@ -74,10 +76,7 @@ instance Eq (AnyScript era) where
       Nothing -> False
   _ == _ = False
 
-instance
-  L.AlonzoEraScript era
-  => SerialiseAsCBOR (AnyScript era)
-  where
+instance L.AlonzoEraScript era => SerialiseAsCBOR (AnyScript era) where
   serialiseToCBOR (AnySimpleScript (SimpleScript ns)) =
     L.serialize' (L.eraProtVerHigh @era) (L.fromNativeScript ns :: L.Script era)
   serialiseToCBOR (AnyPlutusScript ps) =
@@ -102,10 +101,10 @@ instance
     tryPlutusScript :: L.Script era -> Maybe (AnyScript era)
     tryPlutusScript script = do
       ps <- L.toPlutusScript script
-      L.withPlutusScript ps $ \(plutus :: Plutus.Plutus l) ->
+      L.withPlutusScript ps $ \plutus -> do
         let plutusRunnable = Plutus.decodePlutusRunnable (L.eraProtVerHigh @era) plutus
-         in AnyPlutusScript . PlutusScriptInEra
-              <$> (plutusRunnable <$ rightToMaybe (Plutus.plutusRunnableResult plutusRunnable))
+        AnyPlutusScript (PlutusScriptInEra plutusRunnable ps)
+          <$ rightToMaybe (Plutus.plutusRunnableResult plutusRunnable)
 
     noParseError :: CBOR.DecoderError
     noParseError =
@@ -124,14 +123,14 @@ deserialiseAnySimpleScript
 deserialiseAnySimpleScript bs =
   AnySimpleScript <$> obtainCommonConstraints (useEra @era) (deserialiseSimpleScript bs)
 
+-- | Decode a Plutus script. The 'L.EraPlutusTxInfo' constraint fixes both the language
+-- and the era, so only malformed bytes fail.
 deserialiseAnyPlutusScriptOfLanguage
   :: forall era lang
-   . (IsEra era, Plutus.PlutusLanguage lang, HasTypeProxy (Plutus.SLanguage lang))
-  => BS.ByteString -> L.SLanguage lang -> Either CBOR.DecoderError (AnyScript (LedgerEra era))
-deserialiseAnyPlutusScriptOfLanguage bs lang = do
-  s :: (PlutusScriptInEra lang (LedgerEra era)) <-
-    obtainCommonConstraints (useEra @era) (deserialisePlutusScriptInEra lang bs)
-  return $ AnyPlutusScript s
+   . L.EraPlutusTxInfo lang (LedgerEra era)
+  => BS.ByteString -> Either CBOR.DecoderError (AnyScript (LedgerEra era))
+deserialiseAnyPlutusScriptOfLanguage bs =
+  AnyPlutusScript <$> deserialisePlutusScriptInEra @(LedgerEra era) @lang bs
 
 data AnyScriptDecodeError
   = -- | A text envelope was decoded, but its Plutus CBOR payload could not be.

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

@@ -233,55 +233,28 @@ getAnyPlutusScriptData AnyPlutusCertifyingScriptWitness{} = mempty
 getAnyPlutusScriptData AnyPlutusProposingScriptWitness{} = mempty
 getAnyPlutusScriptData AnyPlutusVotingScriptWitness{} = mempty
 
--- | Resolves the ledger script for a Plutus witness.
--- A reference witness has no script to resolve here, so it returns @Right Nothing@.
--- An inline witness returns @Right (Just script)@, or @Left lang@ when the era rejects the language.
 getAnyPlutusWitnessPlutusScript
-  :: L.AlonzoEraScript era
-  => AnyPlutusScriptWitness lang purpose era
-  -> Either L.Language (Maybe (L.Script era))
+  :: AnyPlutusScriptWitness lang purpose era
+  -> Maybe (L.Script era)
 getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV1 s)) =
-  resolvePlutusWitnessScript L.SPlutusV1 s
+  resolvePlutusWitnessScript s
 getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV2 s)) =
-  resolvePlutusWitnessScript L.SPlutusV2 s
+  resolvePlutusWitnessScript s
 getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV3 s)) =
-  resolvePlutusWitnessScript L.SPlutusV3 s
+  resolvePlutusWitnessScript s
 getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV4 s)) =
-  resolvePlutusWitnessScript L.SPlutusV4 s
-getAnyPlutusWitnessPlutusScript (AnyPlutusMintingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) =
-  resolvePlutusWitnessScript l s
-getAnyPlutusWitnessPlutusScript (AnyPlutusWithdrawingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) =
-  resolvePlutusWitnessScript l s
-getAnyPlutusWitnessPlutusScript (AnyPlutusCertifyingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) =
-  resolvePlutusWitnessScript l s
-getAnyPlutusWitnessPlutusScript (AnyPlutusProposingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) =
-  resolvePlutusWitnessScript l s
-getAnyPlutusWitnessPlutusScript (AnyPlutusVotingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) =
-  resolvePlutusWitnessScript l s
+  resolvePlutusWitnessScript s
+getAnyPlutusWitnessPlutusScript (AnyPlutusMintingScriptWitness s) = resolvePlutusWitnessScript s
+getAnyPlutusWitnessPlutusScript (AnyPlutusWithdrawingScriptWitness s) = resolvePlutusWitnessScript s
+getAnyPlutusWitnessPlutusScript (AnyPlutusCertifyingScriptWitness s) = resolvePlutusWitnessScript s
+getAnyPlutusWitnessPlutusScript (AnyPlutusProposingScriptWitness s) = resolvePlutusWitnessScript s
+getAnyPlutusWitnessPlutusScript (AnyPlutusVotingScriptWitness s) = resolvePlutusWitnessScript s
 
+-- | A reference witness carries no script, so it resolves to 'Nothing'.
+-- An inline witness holds the ledger script, built when its era was checked.
 resolvePlutusWitnessScript
-  :: L.AlonzoEraScript era
-  => L.SLanguage lang
-  -> PlutusScriptWitness lang purpose era
-  -> Either L.Language (Maybe (L.Script era))
-resolvePlutusWitnessScript slang s =
-  case getPlutusScriptRunnable s of
-    Nothing -> Right Nothing
-    Just runnable -> Just . L.fromPlutusScript <$> fromPlutusRunnable slang runnable
-
--- | 'PlutusRunnable' is built by deserialisation in the ledger, which rejects a language
--- the era does not support. That case is returned as 'Left' with the language.
-fromPlutusRunnable
-  :: forall era lang
-   . L.AlonzoEraScript era
-  => L.SLanguage lang
-  -> L.PlutusRunnable lang
-  -> Either L.Language (L.PlutusScript era)
-fromPlutusRunnable slang = case slang of
-  L.SPlutusV1 -> go
-  L.SPlutusV2 -> go
-  L.SPlutusV3 -> go
-  L.SPlutusV4 -> go
- where
-  go :: L.PlutusLanguage lang => L.PlutusRunnable lang -> Either L.Language (L.PlutusScript era)
-  go = maybe (Left $ L.plutusLanguage slang) Right . L.mkPlutusScript . L.plutusFromRunnable
+  :: PlutusScriptWitness lang purpose era
+  -> Maybe (L.Script era)
+resolvePlutusWitnessScript (PlutusScriptWitness _ (PScript s) _ _ _) =
+  Just $ plutusScriptInEraToScript s
+resolvePlutusWitnessScript (PlutusScriptWitness _ PReferenceScript{} _ _ _) = Nothing

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

@@ -46,6 +46,7 @@ import Cardano.Api.Era.Internal.Eon.ConwayEraOnwards
 import Cardano.Api.Era.Internal.Eon.MaryEraOnwards
 import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra (ShelleyBasedEra (..), ShelleyLedgerEra)
 import Cardano.Api.Error
+import Cardano.Api.Experimental.Plutus.Internal.Language (HasPlutusLangInEra)
 import Cardano.Api.HasTypeProxy
 import Cardano.Api.Ledger.Internal.Reexport qualified as L
 import Cardano.Api.Pretty.Internal.ShowOf
@@ -318,6 +319,7 @@ type EraCommonConstraints era =
   , L.EraTxCert (LedgerEra era)
   , L.EraTxOut (LedgerEra era)
   , L.EraUTxO (LedgerEra era)
+  , HasPlutusLangInEra (LedgerEra era)
   , HasTypeProxy era
   , Ord (L.PlutusPurpose L.AsIx (LedgerEra era))
   , L.GovState (LedgerEra era) ~ L.ConwayGovState (LedgerEra era)

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

@@ -5,6 +5,10 @@ module Cardano.Api.Experimental.Plutus
   , serialiseAnyPlutusScriptToTextEnvelope
   , deserialiseAnyPlutusScriptFromTextEnvelope
   , PlutusScriptInEra (..)
+  , mkPlutusScriptInEra
+  , PlutusLangInEra (..)
+  , HasPlutusLangInEra (..)
+  , plutusLangInShelleyBasedEra
   , AnyPlutusScriptLanguage (..)
   , deserialisePlutusScriptInEra
   , hashPlutusScriptInEra

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

@@ -0,0 +1,100 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- | Which Plutus languages each ledger era accepts.
+--
+-- The table is the ledger's 'L.EraPlutusTxInfo' instances, one per language and era it supports.
+-- The runtime lookup is the ledger's 'L.mkSupportedLanguage'.
+module Cardano.Api.Experimental.Plutus.Internal.Language
+  ( PlutusLangInEra (..)
+  , HasPlutusLangInEra (..)
+  , plutusLangInShelleyBasedEra
+  )
+where
+
+import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra (ShelleyBasedEra (..), ShelleyLedgerEra)
+
+import Cardano.Ledger.Alonzo.Plutus.Context qualified as L
+  ( EraPlutusContext (..)
+  , EraPlutusTxInfo
+  , SupportedLanguage (..)
+  )
+import Cardano.Ledger.Api qualified as L
+import Cardano.Ledger.Plutus.Language qualified as L
+
+import Data.Typeable (eqT, (:~:) (Refl))
+
+-- | Evidence that the ledger era @era@ accepts Plutus scripts of @lang@.
+-- The ledger's 'L.EraPlutusTxInfo' instances are the table; matching gives 'L.AlonzoEraScript'.
+data PlutusLangInEra (lang :: L.Language) era where
+  PlutusLangInEra :: L.EraPlutusTxInfo lang era => L.SLanguage lang -> PlutusLangInEra lang era
+
+deriving instance Show (PlutusLangInEra lang era)
+
+deriving instance Eq (PlutusLangInEra lang era)
+
+-- | The runtime side of the table, for code that learns the language late.
+plutusLangInShelleyBasedEra
+  :: L.PlutusLanguage lang
+  => ShelleyBasedEra era
+  -> L.SLanguage lang
+  -> Maybe (PlutusLangInEra lang (ShelleyLedgerEra era))
+plutusLangInShelleyBasedEra sbe slang = case sbe of
+  ShelleyBasedEraShelley -> Nothing
+  ShelleyBasedEraAllegra -> Nothing
+  ShelleyBasedEraMary -> Nothing
+  ShelleyBasedEraAlonzo -> supportedLanguageProof slang
+  ShelleyBasedEraBabbage -> supportedLanguageProof slang
+  ShelleyBasedEraConway -> supportedLanguageProof slang
+  ShelleyBasedEraDijkstra -> supportedLanguageProof slang
+
+-- | Ask the ledger whether the era runs the language and keep its proof.
+supportedLanguageProof
+  :: forall era lang
+   . (L.EraPlutusContext era, L.PlutusLanguage lang)
+  => L.SLanguage lang -> Maybe (PlutusLangInEra lang era)
+supportedLanguageProof slang = do
+  L.SupportedLanguage (_ :: L.SLanguage l) <- L.mkSupportedLanguage @era (L.plutusLanguage slang)
+  Refl <- eqT @lang @l
+  pure $ PlutusLangInEra slang
+
+-- | Hands out a 'PlutusLangInEra' proof for code that only has the ledger era type,
+-- by asking the ledger's 'L.mkSupportedLanguage'. Eras before Alonzo always give 'Nothing'.
+--
+-- With the language known only at the type level, take the singleton from 'L.PlutusLanguage':
+--
+-- > case plutusLangInEra @era (L.isLanguage @lang) of
+-- >   Just (PlutusLangInEra _) -> -- the era runs the language, 'L.EraPlutusTxInfo' is in scope
+-- >   Nothing -> -- it does not
+--
+-- When the pairing is static and supported, 'L.EraPlutusTxInfo' already holds and the proof
+-- needs no lookup:
+--
+-- > PlutusLangInEra L.isLanguage :: PlutusLangInEra lang era
+class HasPlutusLangInEra era where
+  plutusLangInEra :: L.PlutusLanguage lang => L.SLanguage lang -> Maybe (PlutusLangInEra lang era)
+
+instance HasPlutusLangInEra L.ShelleyEra where
+  plutusLangInEra = plutusLangInShelleyBasedEra ShelleyBasedEraShelley
+
+instance HasPlutusLangInEra L.AllegraEra where
+  plutusLangInEra = plutusLangInShelleyBasedEra ShelleyBasedEraAllegra
+
+instance HasPlutusLangInEra L.MaryEra where
+  plutusLangInEra = plutusLangInShelleyBasedEra ShelleyBasedEraMary
+
+instance HasPlutusLangInEra L.AlonzoEra where
+  plutusLangInEra = plutusLangInShelleyBasedEra ShelleyBasedEraAlonzo
+
+instance HasPlutusLangInEra L.BabbageEra where
+  plutusLangInEra = plutusLangInShelleyBasedEra ShelleyBasedEraBabbage
+
+instance HasPlutusLangInEra L.ConwayEra where
+  plutusLangInEra = plutusLangInShelleyBasedEra ShelleyBasedEraConway
+
+instance HasPlutusLangInEra L.DijkstraEra where
+  plutusLangInEra = plutusLangInShelleyBasedEra ShelleyBasedEraDijkstra