Translate some tests from BabbageFeatures to Imp test

eras/alonzo/impl/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## 1.14.0.0
 
+* Added `eraUnsupportedLanguage`
+* Changed return type of `mkPlutusScript` and `mkBinaryPlutusScript` from `Maybe` to `MonadFail`
 * Deprecate `Alonzo.TxSeq` in favour of `Alonzo.BlockBody`. #5156
   * Rename `AlonzoTxSeq` to `AlonzoBlockBody`
 * Rename `alonzoEqTxRaw` to `alonzoTxEqRaw`

eras/alonzo/impl/cardano-ledger-alonzo.cabal

@@ -140,6 +140,7 @@ library testlib
     -Wunused-packages
 
   build-depends:
+    FailT,
     HUnit,
     base,
     bytestring,

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs

@@ -31,6 +31,7 @@ module Cardano.Ledger.Alonzo.Scripts (
   eqAlonzoScriptRaw,
   AlonzoEraScript (..),
   eraLanguages,
+  eraUnsupportedLanguage,
   PlutusScript (..),
   withPlutusScriptLanguage,
   plutusScriptLanguage,
@@ -172,7 +173,7 @@ class
   fromPlutusScript = PlutusScript
 
   -- | Returns Nothing, whenver plutus language is not supported for this era.
-  mkPlutusScript :: PlutusLanguage l => Plutus l -> Maybe (PlutusScript era)
+  mkPlutusScript :: (PlutusLanguage l, MonadFail m) => Plutus l -> m (PlutusScript era)
 
   -- | Give a `PlutusScript` apply a function that can handle `Plutus` scripts of all
   -- known versions.
@@ -207,7 +208,11 @@ class
     PlutusPurpose AsIx (PreviousEra era) ->
     PlutusPurpose AsIx era
 
-mkBinaryPlutusScript :: AlonzoEraScript era => Language -> PlutusBinary -> Maybe (PlutusScript era)
+mkBinaryPlutusScript ::
+  (MonadFail m, AlonzoEraScript era) =>
+  Language ->
+  PlutusBinary ->
+  m (PlutusScript era)
 mkBinaryPlutusScript lang pb = withSLanguage lang (mkPlutusScript . (`asSLanguage` Plutus pb))
 
 -- | Apply a function to a plutus script, but only if it is of expected language version,
@@ -516,8 +521,8 @@ instance AlonzoEraScript AlonzoEra where
 
   mkPlutusScript plutus =
     case plutusSLanguage plutus of
-      SPlutusV1 -> Just $ AlonzoPlutusV1 plutus
-      _ -> Nothing
+      SPlutusV1 -> pure $ AlonzoPlutusV1 plutus
+      slang -> eraUnsupportedLanguage @AlonzoEra slang
 
   withPlutusScript (AlonzoPlutusV1 plutus) f = f plutus
 
@@ -584,10 +589,7 @@ decodePlutusScript ::
   Decoder s (PlutusScript era)
 decodePlutusScript slang = do
   pb <- decCBOR
-  case mkPlutusScript $ asSLanguage slang $ Plutus pb of
-    Nothing ->
-      fail $ show (plutusLanguage slang) ++ " is not supported in " ++ eraName @era ++ " era."
-    Just plutusScript -> pure plutusScript
+  mkPlutusScript $ asSLanguage slang $ Plutus pb
 
 instance AlonzoEraScript era => EncCBOR (AlonzoScript era)
 
@@ -642,6 +644,11 @@ eqAlonzoScriptRaw _ _ = False
 eraLanguages :: forall era. AlonzoEraScript era => [Language]
 eraLanguages = [minBound .. eraMaxLanguage @era]
 
+eraUnsupportedLanguage ::
+  forall era l m proxy a. (Era era, PlutusLanguage l, MonadFail m) => proxy l -> m a
+eraUnsupportedLanguage slang =
+  fail $ show (plutusLanguage slang) <> " isn't supported in the " <> eraName @era <> " era"
+
 -- | Having a Map with scripts and a script hash, lookup the plutus script. Returns
 -- Nothing when script is missing or it is not a PlutusScript
 lookupPlutusScript ::

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs

@@ -119,21 +119,20 @@ import Cardano.Ledger.Plutus.Language (
   PlutusLanguage,
   SLanguage (..),
   plutusBinary,
-  plutusLanguage,
  )
 import Cardano.Ledger.Shelley.TxWits (
   mapTraverseableDecoderA,
   shelleyEqTxWitsRaw,
  )
 import Control.DeepSeq (NFData)
 import Control.Monad (when, (>=>))
+import Control.Monad.Trans.Fail (runFail)
 import qualified Data.List.NonEmpty as NE
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.MapExtras (fromElems)
 import qualified Data.MapExtras as Map (fromElems)
 import Data.Maybe (mapMaybe)
-import Data.Proxy (Proxy (..))
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Typeable (Typeable)
@@ -569,12 +568,9 @@ instance AlonzoEraScript era => EncCBOR (AlonzoTxWitsRaw era) where
       toScript ::
         forall l h. PlutusLanguage l => Map.Map h (Plutus l) -> Map.Map h (Script era)
       toScript ps =
-        case traverse (fmap fromPlutusScript . mkPlutusScript) ps of
-          Nothing ->
-            error $
-              "Impossible: Re-constructing unsupported language: "
-                ++ show (plutusLanguage (Proxy @l))
-          Just plutusScripts -> plutusScripts
+        case runFail $ traverse (fmap fromPlutusScript . mkPlutusScript) ps of
+          Left e -> error $ "Impossible: Re-constructing unsupported language: " <> e
+          Right plutusScripts -> plutusScripts
 
 instance AlonzoEraScript era => DecCBOR (Annotator (RedeemersRaw era)) where
   decCBOR = do

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs

@@ -85,9 +85,9 @@ import Cardano.Ledger.Plutus.Language (
   Plutus (..),
   PlutusLanguage,
   asSLanguage,
-  plutusLanguage,
  )
 import Cardano.Ledger.Shelley.Rules (PredicateFailure, ShelleyUtxowPredFailure)
+import Control.Monad.Trans.Fail (runFail)
 import Data.Functor.Identity (Identity)
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import qualified Data.List.NonEmpty as NE (toList)
@@ -464,12 +464,7 @@ mkPlutusScript' ::
   (HasCallStack, AlonzoEraScript era, PlutusLanguage l) =>
   Plutus l ->
   Script era
-mkPlutusScript' plutus =
-  case mkPlutusScript plutus of
-    Nothing ->
-      error $
-        "Plutus version " ++ show (plutusLanguage plutus) ++ " is not supported in " ++ eraName @era
-    Just plutusScript -> fromPlutusScript plutusScript
+mkPlutusScript' = either error fromPlutusScript . runFail . mkPlutusScript
 {-# DEPRECATED mkPlutusScript' "In favor of `fromPlutusScript` . `mkSupportedPlutusScript`" #-}
 
 instance Arbitrary (TransitionConfig AlonzoEra) where

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs

@@ -149,8 +149,9 @@ impLookupPlutusScript ::
   AlonzoEraImp era =>
   ScriptHash ->
   Maybe (PlutusScript era)
-impLookupPlutusScript sh =
-  (\(ScriptTestContext plutus _) -> mkPlutusScript plutus) =<< impLookupScriptContext @era sh
+impLookupPlutusScript sh = do
+  ScriptTestContext plutus _ <- impLookupScriptContext @era sh
+  mkPlutusScript plutus
 
 impGetPlutusContexts ::
   forall era.
@@ -243,18 +244,8 @@ fixupScriptWits tx = impAnn "fixupScriptWits" $ do
   utxo <- getUTxO
   let ScriptsProvided provided = getScriptsProvided utxo tx
   let contextsToAdd = filter (\(_, sh, _) -> not (Map.member sh provided)) contexts
-  let
-    plutusToScript ::
-      forall l.
-      PlutusLanguage l =>
-      Plutus l ->
-      ImpTestM era (Script era)
-    plutusToScript p =
-      case mkPlutusScript @era p of
-        Just x -> pure $ fromPlutusScript x
-        Nothing -> error "Plutus version not supported by era"
   scriptWits <- forM contextsToAdd $ \(_, sh, ScriptTestContext plutus _) ->
-    (sh,) <$> plutusToScript plutus
+    (sh,) . fromPlutusScript <$> mkPlutusScript plutus
   pure $
     tx
       & witsTxL . scriptTxWitsL <>~ Map.fromList scriptWits

eras/babbage/impl/cardano-ledger-babbage.cabal

@@ -107,7 +107,10 @@ library testlib
     Test.Cardano.Ledger.Babbage.Era
     Test.Cardano.Ledger.Babbage.Imp
     Test.Cardano.Ledger.Babbage.Imp.UtxoSpec
+    Test.Cardano.Ledger.Babbage.Imp.UtxosSpec
     Test.Cardano.Ledger.Babbage.Imp.UtxowSpec
+    Test.Cardano.Ledger.Babbage.Imp.UtxowSpec.Invalid
+    Test.Cardano.Ledger.Babbage.Imp.UtxowSpec.Valid
     Test.Cardano.Ledger.Babbage.ImpTest
     Test.Cardano.Ledger.Babbage.Translation.TranslatableGen
     Test.Cardano.Ledger.Babbage.TreeDiff

eras/babbage/impl/src/Cardano/Ledger/Babbage/Scripts.hs

@@ -25,6 +25,7 @@ import Cardano.Ledger.Alonzo.Scripts (
   AlonzoScript (..),
   PlutusScript (..),
   alonzoScriptPrefixTag,
+  eraUnsupportedLanguage,
   isPlutusScript,
  )
 import Cardano.Ledger.Babbage.Era
@@ -63,9 +64,9 @@ instance AlonzoEraScript BabbageEra where
 
   mkPlutusScript plutus =
     case plutusSLanguage plutus of
-      SPlutusV1 -> Just $ BabbagePlutusV1 plutus
-      SPlutusV2 -> Just $ BabbagePlutusV2 plutus
-      _ -> Nothing
+      SPlutusV1 -> pure $ BabbagePlutusV1 plutus
+      SPlutusV2 -> pure $ BabbagePlutusV2 plutus
+      slang -> eraUnsupportedLanguage @BabbageEra slang
 
   withPlutusScript (BabbagePlutusV1 plutus) f = f plutus
   withPlutusScript (BabbagePlutusV2 plutus) f = f plutus

eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp.hs

@@ -7,17 +7,16 @@
 
 module Test.Cardano.Ledger.Babbage.Imp (spec) where
 
-import Cardano.Ledger.Alonzo.Plutus.Context (ContextError, EraPlutusTxInfo)
+import Cardano.Ledger.Alonzo.Plutus.Context (ContextError)
 import Cardano.Ledger.Alonzo.Rules (
   AlonzoUtxoPredFailure,
   AlonzoUtxosPredFailure,
   AlonzoUtxowPredFailure,
  )
-import Cardano.Ledger.Babbage.Core
-import Cardano.Ledger.Babbage.Rules (BabbageUtxowPredFailure (..))
+import Cardano.Ledger.Babbage.Core (BabbageEraTxBody, InjectRuleFailure)
+import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure)
 import Cardano.Ledger.Babbage.TxInfo (BabbageContextError)
 import Cardano.Ledger.BaseTypes (Inject)
-import Cardano.Ledger.Plutus (Language (..))
 import Cardano.Ledger.Shelley.Rules (
   ShelleyDelegPredFailure,
   ShelleyUtxoPredFailure,
@@ -26,26 +25,29 @@ import Cardano.Ledger.Shelley.Rules (
 import qualified Test.Cardano.Ledger.Alonzo.Imp as AlonzoImp
 import Test.Cardano.Ledger.Alonzo.ImpTest (AlonzoEraImp, LedgerSpec)
 import qualified Test.Cardano.Ledger.Babbage.Imp.UtxoSpec as Utxo
+import qualified Test.Cardano.Ledger.Babbage.Imp.UtxosSpec as Utxos
 import qualified Test.Cardano.Ledger.Babbage.Imp.UtxowSpec as Utxow
 import Test.Cardano.Ledger.Imp.Common
 
 spec ::
   forall era.
   ( AlonzoEraImp era
   , BabbageEraTxBody era
-  , EraPlutusTxInfo 'PlutusV2 era
   , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
+  , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
   , InjectRuleFailure "LEDGER" BabbageUtxowPredFailure era
   , Inject (BabbageContextError era) (ContextError era)
   ) =>
   Spec
 spec = do
   AlonzoImp.spec @era
-  describe "BabbageImpSpec" . withImpInit @(LedgerSpec era) $ do
-    Utxow.spec
-    Utxo.spec
+  withImpInit @(LedgerSpec era) $
+    describe "BabbageImpSpec" $ do
+      Utxo.spec
+      Utxow.spec
+      Utxos.spec @era

eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp/UtxoSpec.hs

@@ -1,30 +1,27 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Test.Cardano.Ledger.Babbage.Imp.UtxoSpec (spec) where
 
-import Cardano.Ledger.Babbage.Core (
-  BabbageEraTxBody (..),
-  BabbageEraTxOut (..),
-  EraTx (..),
-  EraTxBody (..),
-  EraTxOut (..),
-  ppProtocolVersionL,
- )
-import Cardano.Ledger.BaseTypes (Inject (..), ProtVer (..), natVersion)
-import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Babbage.Core
+import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..))
+import Cardano.Ledger.BaseTypes (Inject (..), ProtVer (..), StrictMaybe (..), natVersion)
+import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..))
 import Cardano.Ledger.Credential (StakeReference (..))
 import Cardano.Ledger.Plutus (
-  Data (..),
-  Datum (..),
+  Language (..),
   SLanguage (..),
-  dataToBinaryData,
   hashPlutusScript,
+  mkInlineDatum,
+  withSLanguage,
  )
+import qualified Data.ByteString as BS
 import qualified Data.Sequence.Strict as SSeq
 import qualified Data.Set as Set
 import Lens.Micro ((&), (.~))
@@ -33,16 +30,25 @@ import Test.Cardano.Ledger.Babbage.ImpTest (
   AlonzoEraImp,
   ImpInit,
   LedgerSpec,
+  freshKeyAddr_,
   getsPParams,
+  sendCoinTo,
+  submitFailingTx,
   submitTx,
   submitTx_,
  )
 import Test.Cardano.Ledger.Common (SpecWith, describe, it, when)
 import Test.Cardano.Ledger.Core.Utils (txInAt)
 import Test.Cardano.Ledger.Imp.Common (mkAddr)
-import Test.Cardano.Ledger.Plutus.Examples (inputsOverlapsWithRefInputs)
+import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsWithDatum, inputsOverlapsWithRefInputs)
 
-spec :: forall era. (AlonzoEraImp era, BabbageEraTxBody era) => SpecWith (ImpInit (LedgerSpec era))
+spec ::
+  forall era.
+  ( AlonzoEraImp era
+  , BabbageEraTxBody era
+  , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
+  ) =>
+  SpecWith (ImpInit (LedgerSpec era))
 spec = describe "UTXO" $ do
   describe "Reference scripts" $ do
     it "Reference inputs can overlap with regular inputs in PlutusV2" $ do
@@ -54,7 +60,7 @@ spec = describe "UTXO" $ do
                 StakeRefNull
             )
             (inject $ Coin 1_000_000)
-            & datumTxOutL .~ Datum (dataToBinaryData . Data $ PV1.I 0)
+            & datumTxOutL .~ mkInlineDatum (PV1.I 0)
       tx <-
         submitTx $
           mkBasicTx mkBasicTxBody
@@ -66,3 +72,38 @@ spec = describe "UTXO" $ do
           mkBasicTx mkBasicTxBody
             & bodyTxL . inputsTxBodyL .~ Set.singleton txIn
             & bodyTxL . referenceInputsTxBodyL .~ Set.singleton txIn
+
+  it "Incorrect collateral total" $ do
+    let scriptHash = withSLanguage PlutusV2 (hashPlutusScript . alwaysSucceedsWithDatum)
+        txOut =
+          mkBasicTxOut (mkAddr scriptHash StakeRefNull) mempty
+            & datumTxOutL .~ mkInlineDatum (PV1.I 1)
+        tx1 = mkBasicTx $ mkBasicTxBody & outputsTxBodyL .~ [txOut]
+    txIn <- txInAt 0 <$> submitTx tx1
+    addr <- freshKeyAddr_
+    coll <- sendCoinTo addr $ Coin 5_000_000
+    let collReturn = mkBasicTxOut addr . inject $ Coin 2_000_000
+        tx2 =
+          mkBasicTx $
+            mkBasicTxBody
+              & inputsTxBodyL .~ [txIn]
+              & collateralInputsTxBodyL .~ [coll]
+              & collateralReturnTxBodyL .~ SJust collReturn
+              & totalCollateralTxBodyL .~ SJust (Coin 1_000_000)
+    submitFailingTx
+      tx2
+      [injectFailure (IncorrectTotalCollateralField (DeltaCoin 3_000_000) (Coin 1_000_000))]
+
+  -- TxOut too large for the included ADA, using a large inline datum
+  it "Min-utxo value with output too large" $ do
+    pp <- getsPParams id
+    addr <- freshKeyAddr_
+    let
+      amount = inject $ Coin 5_000_000
+      largeDatum = PV1.B $ BS.replicate 1500 0
+      txOut = mkBasicTxOut addr amount & datumTxOutL .~ mkInlineDatum largeDatum
+    submitFailingTx
+      (mkBasicTx mkBasicTxBody & bodyTxL . outputsTxBodyL .~ [txOut])
+      [ injectFailure $
+          BabbageOutputTooSmallUTxO [(txOut, getMinCoinTxOut pp txOut)]
+      ]