Fail instead of silently dropping Plutus scripts the era does not support

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

@@ -0,0 +1,12 @@
+project: cardano-api
+pr: 1363
+kind:
+  - breaking
+  - bugfix
+description: |
+  Plutus scripts in a language the era does not support are now rejected when decoded, with an error naming the language and the era.
+  Before, such a script was silently dropped from the witness set while its redeemer was kept, so the transaction failed on submission.
+  `PlutusScriptInEra` can only be built for a pairing the ledger supports, through the new `mkPlutusScriptInEra`, and it now holds the ledger script as well.
+  `deserialisePlutusScriptInEra` and `deserialiseAnyPlutusScriptOfLanguage` require `EraPlutusTxInfo lang era` and no longer take the language singleton.
+  New `PlutusLangInEra`, `plutusLangInEra` and `plutusLangInShelleyBasedEra` give that proof at runtime.
+  `decodeAnyPlutusScript` and `deserialiseAnyPlutusScriptFromTextEnvelope` now require `IsShelleyBasedEra` for the api era that matches the ledger era.

.changes/legacy-tx-body-unsupported-reference-script-language-error.yml

@@ -0,0 +1,8 @@
+project: cardano-api
+pr: 1363
+kind:
+  - breaking
+  - bugfix
+description: |
+  `createTransactionBody` now fails with `TxOutputReferenceScriptLanguageNotSupportedInEra` when a transaction output or the return collateral carries a reference script in a language the era does not support.
+  Before, the output was built without the script and no error was reported.

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/Hardcoded.hs

@@ -7,6 +7,8 @@ module Test.Gen.Cardano.Api.Hardcoded
   , v2EcdsaLoopPlutusScriptHexDoubleEncoded
   , v3AlwaysSucceedsPlutusScript
   , v3AlwaysSucceedsPlutusScriptDoubleEncoded
+  , v4AlwaysSucceedsPlutusScript
+  , v4AlwaysSucceedsPlutusScriptDoubleEncoded
   )
 where
 
@@ -45,3 +47,12 @@ v3AlwaysSucceedsPlutusScriptDoubleEncoded =
 
 v3AlwaysSucceedsPlutusScript :: ByteString
 v3AlwaysSucceedsPlutusScript = BS.drop 6 v3AlwaysSucceedsPlutusScriptDoubleEncoded
+
+-- | Compiled against PlutusLedgerApi.V4 with plutus-tx-plugin 1.70.0.0, from plinth-template's V4TestValidators.hs.
+-- Byte-identical to the V3 build, since the term ignores its argument.
+v4AlwaysSucceedsPlutusScriptDoubleEncoded :: ByteString
+v4AlwaysSucceedsPlutusScriptDoubleEncoded =
+  "46450101002499"
+
+v4AlwaysSucceedsPlutusScript :: ByteString
+v4AlwaysSucceedsPlutusScript = BS.drop 2 v4AlwaysSucceedsPlutusScriptDoubleEncoded

cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
@@ -361,13 +360,12 @@ genPlutusV3Script = do
   let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex
   return . PlutusScript PlutusScriptV3 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes
 
--- TODO: This is not generating v4 scripts.
 genPlutusV4Script :: Gen (Script PlutusScriptV4)
 genPlutusV4Script = do
-  v3AlwaysSucceedsPlutusScriptHex <-
-    Gen.element [v3AlwaysSucceedsPlutusScriptDoubleEncoded, v3AlwaysSucceedsPlutusScript]
-  let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex
-  return . PlutusScript PlutusScriptV4 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes
+  v4AlwaysSucceedsPlutusScriptHex <-
+    Gen.element [v4AlwaysSucceedsPlutusScriptDoubleEncoded, v4AlwaysSucceedsPlutusScript]
+  let v4ScriptBytes = Base16.decodeLenient v4AlwaysSucceedsPlutusScriptHex
+  return . PlutusScript PlutusScriptV4 . PlutusScriptSerialised $ SBS.toShort v4ScriptBytes
 
 genValidPlutusV3Script :: Gen (Script PlutusScriptV3)
 genValidPlutusV3Script = do
@@ -376,13 +374,12 @@ genValidPlutusV3Script = do
   let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex
   return . PlutusScript PlutusScriptV3 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes
 
--- TODO: This is not generating v4 scripts.
 genValidPlutusV4Script :: Gen (Script PlutusScriptV4)
 genValidPlutusV4Script = do
-  v3AlwaysSucceedsPlutusScriptHex <-
-    Gen.element [v3AlwaysSucceedsPlutusScript]
-  let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex
-  return . PlutusScript PlutusScriptV4 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes
+  v4AlwaysSucceedsPlutusScriptHex <-
+    Gen.element [v4AlwaysSucceedsPlutusScript]
+  let v4ScriptBytes = Base16.decodeLenient v4AlwaysSucceedsPlutusScriptHex
+  return . PlutusScript PlutusScriptV4 . PlutusScriptSerialised $ SBS.toShort v4ScriptBytes
 
 genScriptDataSchema :: Gen ScriptDataJsonSchema
 genScriptDataSchema = Gen.element [ScriptDataJsonNoSchema, ScriptDataJsonDetailedSchema]
@@ -1527,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
 
@@ -1600,27 +1597,9 @@ genScriptWitnessForStake sbe = do
         scriptRedeemer
         <$> genExecutionUnits
 
-genAnyPlutusScriptVersion :: Gen AnyPlutusScriptVersion
-genAnyPlutusScriptVersion = do
-  Gen.element [minBound .. maxBound]
-
-plutusScriptLangaugeInEra
-  :: Exp.Era era -> PlutusScriptVersion lang -> ScriptLanguageInEra lang era
-plutusScriptLangaugeInEra Exp.DijkstraEra l =
-  case l of
-    PlutusScriptV1 -> PlutusScriptV1InDijkstra
-    PlutusScriptV2 -> PlutusScriptV2InDijkstra
-    PlutusScriptV3 -> PlutusScriptV3InDijkstra
-    PlutusScriptV4 -> PlutusScriptV4InDijkstra
-plutusScriptLangaugeInEra Exp.ConwayEra l =
-  case l of
-    PlutusScriptV1 -> PlutusScriptV1InConway
-    PlutusScriptV2 -> PlutusScriptV2InConway
-    PlutusScriptV3 -> PlutusScriptV3InConway
-    PlutusScriptV4 -> case undefined :: ScriptLanguageInEra PlutusScriptV4 ConwayEra of {}
-
 genApiPlutusScriptWitness
-  :: WitCtx witctx -> Exp.Era era -> Gen (Api.ScriptWitness witctx era)
+  :: forall witctx era
+   . WitCtx witctx -> Exp.Era era -> Gen (Api.ScriptWitness witctx era)
 genApiPlutusScriptWitness witCtx era = do
   dat <- case witCtx of
     WitCtxTxIn -> do
@@ -1632,24 +1611,36 @@ genApiPlutusScriptWitness witCtx era = do
     WitCtxStake -> do
       pure NoScriptDatumForStake
 
-  AnyPlutusScriptVersion lang <- genAnyPlutusScriptVersion
-  PlutusScript plutusScriptVersion' plutusScript <-
-    PlutusScript lang <$> genValidPlutusScript lang
+  let genFor
+        :: forall lang
+         . IsPlutusScriptLanguage lang
+        => PlutusScriptVersion lang
+        -> ScriptLanguageInEra lang era
+        -> Gen (Api.ScriptWitness witctx era)
+      genFor lang langInEra = do
+        PlutusScript plutusScriptVersion' plutusScript <-
+          PlutusScript lang <$> genValidPlutusScript lang
+
+        plutusScriptOrReferenceInput <-
+          Gen.choice
+            [ pure $ PScript plutusScript
+            , PReferenceScript <$> genTxIn
+            ]
+
+        scriptRedeemer <- genHashableScriptData
+        PlutusScriptWitness
+          langInEra
+          plutusScriptVersion'
+          plutusScriptOrReferenceInput
+          dat
+          scriptRedeemer
+          <$> genExecutionUnits
 
-  plutusScriptOrReferenceInput <-
-    Gen.choice
-      [ pure $ PScript plutusScript
-      , PReferenceScript <$> genTxIn
-      ]
-
-  scriptRedeemer <- genHashableScriptData
-  PlutusScriptWitness
-    (plutusScriptLangaugeInEra era lang)
-    plutusScriptVersion'
-    plutusScriptOrReferenceInput
-    dat
-    scriptRedeemer
-    <$> genExecutionUnits
+  Gen.choice
+    [ genFor lang langInEra
+    | AnyPlutusScriptVersion lang <- [minBound .. maxBound]
+    , Just langInEra <- [scriptLanguageSupportedInEra (convert era) (PlutusScriptLanguage lang)]
+    ]
 
 genScriptWitnessForMint :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxMint era)
 genScriptWitnessForMint sbe = do

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 @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 (..)
+  , plutusLangInEra
+  , 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

@@ -234,49 +234,27 @@ 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)) =
-  let plutusScriptRunnable = getPlutusScriptRunnable s
-   in L.fromPlutusScript <$> (fromPlutusRunnable L.SPlutusV1 =<< plutusScriptRunnable)
+  resolvePlutusWitnessScript s
 getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV2 s)) =
-  let plutusScriptRunnable = getPlutusScriptRunnable s
-   in L.fromPlutusScript <$> (fromPlutusRunnable L.SPlutusV2 =<< plutusScriptRunnable)
+  resolvePlutusWitnessScript s
 getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV3 s)) =
-  let plutusScriptRunnable = getPlutusScriptRunnable s
-   in L.fromPlutusScript <$> (fromPlutusRunnable L.SPlutusV3 =<< plutusScriptRunnable)
+  resolvePlutusWitnessScript s
 getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV4 s)) =
-  let plutusScriptRunnable = getPlutusScriptRunnable s
-   in L.fromPlutusScript <$> (fromPlutusRunnable L.SPlutusV4 =<< plutusScriptRunnable)
-getAnyPlutusWitnessPlutusScript (AnyPlutusMintingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) =
-  let plutusScriptRunnable = getPlutusScriptRunnable s
-   in L.fromPlutusScript <$> (fromPlutusRunnable l =<< plutusScriptRunnable)
-getAnyPlutusWitnessPlutusScript (AnyPlutusWithdrawingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) =
-  let plutusScriptRunnable = getPlutusScriptRunnable s
-   in L.fromPlutusScript <$> (fromPlutusRunnable l =<< plutusScriptRunnable)
-getAnyPlutusWitnessPlutusScript (AnyPlutusCertifyingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) =
-  let plutusScriptRunnable = getPlutusScriptRunnable s
-   in L.fromPlutusScript <$> (fromPlutusRunnable l =<< plutusScriptRunnable)
-getAnyPlutusWitnessPlutusScript (AnyPlutusProposingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) =
-  let plutusScriptRunnable = getPlutusScriptRunnable s
-   in L.fromPlutusScript <$> (fromPlutusRunnable l =<< plutusScriptRunnable)
-getAnyPlutusWitnessPlutusScript (AnyPlutusVotingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) =
-  let plutusScriptRunnable = getPlutusScriptRunnable s
-   in L.fromPlutusScript <$> (fromPlutusRunnable l =<< plutusScriptRunnable)
+  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
 
--- It should be noted that 'PlutusRunnable' is constructed via deserialization. The deserialization
--- instance lives in ledger and will fail for an invalid script language/era pairing.
-fromPlutusRunnable
-  :: L.AlonzoEraScript era
-  => L.SLanguage lang
-  -> L.PlutusRunnable lang
-  -> Maybe (L.PlutusScript era)
-fromPlutusRunnable L.SPlutusV1 runnable =
-  L.mkPlutusScript $ L.plutusFromRunnable runnable
-fromPlutusRunnable L.SPlutusV2 runnable =
-  L.mkPlutusScript $ L.plutusFromRunnable runnable
-fromPlutusRunnable L.SPlutusV3 runnable =
-  L.mkPlutusScript $ L.plutusFromRunnable runnable
-fromPlutusRunnable L.SPlutusV4 runnable =
-  L.mkPlutusScript $ L.plutusFromRunnable runnable
+-- | 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
+  :: 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/Plutus.hs

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