Mockchain: Check tx units only if tx is valid

src/coin-selection/lib/Convex/CoinSelection.hs

@@ -226,8 +226,8 @@ data TxBalancingMessage
     PrepareInputs {availableBalance :: C.Value, transactionBalance :: C.Value}
   | -- | Balancing a transaction body
     StartBalancing {numInputs :: !Int, numOutputs :: !Int}
-  | -- | Execution units of the transaction, or error message in case of script error
-    ExUnitsMap {exUnits :: [(C.ScriptWitnessIndex, Either String C.ExecutionUnits)]}
+  | -- | Execution units of the transaction
+    ExUnitsMap {exUnits :: [(C.ScriptWitnessIndex, C.ExecutionUnits)]}
   | -- | The transaction fee
     Txfee {fee :: C.Quantity}
   | -- | The remaining balance (after paying the fee)
@@ -290,13 +290,14 @@ balanceTransactionBody
           csiUtxo
           txbody0
 
-    traceWith tracer $ ExUnitsMap $ fmap (second (first (C.docToString . C.prettyError) . fmap snd)) $ Map.toList exUnitsMap
-
     exUnitsMap' <- balancingError $
       case Map.mapEither id exUnitsMap of
         (failures, exUnitsMap') ->
-          handleExUnitsErrors C.ScriptValid failures $
-            fmap snd exUnitsMap' -- TODO: should this take the script validity from csiTxBody?
+          handleExUnitsErrors (C.txScriptValidityToScriptValidity $ C.txScriptValidity csiTxBody) failures $
+            fmap snd exUnitsMap'
+
+    traceWith tracer $ ExUnitsMap $ Map.toList exUnitsMap'
+
     txbodycontent1 <- balancingError $ substituteExecutionUnits exUnitsMap' csiTxBody
     let txbodycontent1' = txbodycontent1 & set L.txFee (Coin (2 ^ (32 :: Integer) - 1)) & over L.txOuts (|> changeOutputLarge)
 
@@ -381,20 +382,10 @@ handleExUnitsErrors C.ScriptValid failuresMap exUnitsMap =
     else Left (C.TxBodyScriptExecutionError failures)
  where
   failures :: [(C.ScriptWitnessIndex, C.ScriptExecutionError)]
-  failures = Map.toList failuresMap
+  failures = toList failuresMap
 handleExUnitsErrors C.ScriptInvalid failuresMap exUnitsMap
-  | null scriptFailures = Left C.TxBodyScriptBadScriptValidity
-  | null nonScriptFailures = Right exUnitsMap
-  | otherwise = Left (C.TxBodyScriptExecutionError nonScriptFailures)
- where
-  nonScriptFailures :: [(C.ScriptWitnessIndex, C.ScriptExecutionError)]
-  nonScriptFailures = filter (not . isScriptErrorEvaluationFailed) (Map.toList failuresMap)
-  scriptFailures :: [(C.ScriptWitnessIndex, C.ScriptExecutionError)]
-  scriptFailures = filter isScriptErrorEvaluationFailed (Map.toList failuresMap)
-  isScriptErrorEvaluationFailed :: (C.ScriptWitnessIndex, C.ScriptExecutionError) -> Bool
-  isScriptErrorEvaluationFailed (_, e) = case e of
-    C.ScriptErrorEvaluationFailed{} -> True
-    _ -> True
+  | null failuresMap = Left C.TxBodyScriptBadScriptValidity
+  | otherwise = Right $ Map.map (\_ -> C.ExecutionUnits 0 0) failuresMap <> exUnitsMap
 
 {- | Get the 'BalanceChanges' for a tx body. Returns 'Nothing' if
 a UTXO couldnt be found

src/mockchain/convex-mockchain.cabal

@@ -68,6 +68,7 @@ library
     , cardano-api
     , cardano-crypto-class         >=2.1.1.0
     , cardano-ledger-alonzo
+    , cardano-ledger-api
     , cardano-ledger-babbage
     , cardano-ledger-conway
     , cardano-ledger-core

src/mockchain/lib/Convex/MockChain.hs

@@ -72,6 +72,7 @@ module Convex.MockChain (
   evalMockchain0T,
 ) where
 
+import Cardano.Api.Experimental qualified as C
 import Cardano.Api.Shelley (
   AddressInEra,
   Hash (StakePoolKeyHash),
@@ -88,6 +89,7 @@ import Cardano.Ledger.Alonzo.Plutus.Evaluate (
   evalPlutusScripts,
  )
 import Cardano.Ledger.Alonzo.TxWits (unTxDats)
+import Cardano.Ledger.Api qualified as L
 import Cardano.Ledger.Babbage.Tx (IsValid (..))
 import Cardano.Ledger.BaseTypes (
   Globals (systemStart),
@@ -148,7 +150,7 @@ import Control.Lens (
   _1,
   _3,
  )
-import Control.Monad (forM)
+import Control.Monad (forM, void, when)
 import Control.Monad.Except (MonadError (throwError))
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Primitive (PrimMonad)
@@ -358,7 +360,7 @@ getTxExUnits NodeParams{npSystemStart, npEraHistory, npProtocolParameters} utxo
       Left e -> Left (Phase1Error e)
       Right rdmrs -> traverse (either (Left . Phase2Error) (Right . snd)) rdmrs
 
-applyTransaction :: forall era. (C.IsAlonzoBasedEra era) => NodeParams era -> MockChainState era -> C.Tx era -> Either (ValidationError era) (MockChainState era, Validated (Core.Tx (C.ShelleyLedgerEra era)))
+applyTransaction :: forall era. (C.IsEra era, C.IsAlonzoBasedEra era) => NodeParams era -> MockChainState era -> C.Tx era -> Either (ValidationError era) (MockChainState era, Validated (Core.Tx (C.ShelleyLedgerEra era)))
 applyTransaction params state' tx'@(C.ShelleyTx _era tx) = C.alonzoEraOnwardsConstraints @era C.alonzoBasedEra $ do
   let currentSlot = state' ^. env . L.slot
       utxoState_ = state' ^. poolState . L.utxoState
@@ -367,7 +369,10 @@ applyTransaction params state' tx'@(C.ShelleyTx _era tx) = C.alonzoEraOnwardsCon
   result <- applyTx params state' vtx scripts
 
   -- Not sure if this step is needed.
-  _ <- first VExUnits (getTxExUnits params utxo tx')
+  _ <-
+    when (C.obtainCommonConstraints (C.useEra @era) (tx ^. L.isValidTxL @(C.LedgerEra era)) == L.IsValid True) $
+      void $
+        first VExUnits (getTxExUnits params utxo tx')
 
   pure result
 
@@ -445,7 +450,7 @@ instance (Monad m) => MonadState (MockChainState era) (MockchainT era m) where
   get = MockchainT $ lift get
   put = MockchainT . lift . put
 
-instance (Monad m, C.IsAlonzoBasedEra era) => MonadBlockchain era (MockchainT era m) where
+instance (Monad m, C.IsAlonzoBasedEra era, C.IsEra era) => MonadBlockchain era (MockchainT era m) where
   sendTx tx = MockchainT $ C.alonzoEraOnwardsConstraints @era C.alonzoBasedEra $ do
     nps <- ask
     addDatumHashes tx
@@ -501,11 +506,11 @@ instance (Monad m, C.IsAlonzoBasedEra era) => MonadBlockchain era (MockchainT er
     let utime = either (error . (<>) "MockchainT: slotToUtcTime failed ") id (slotToUtcTime npEraHistory npSystemStart slotNo)
     return (slotNo, npSlotLength, utime)
 
-instance (Monad m, C.IsAlonzoBasedEra era) => MonadMockchain era (MockchainT era m) where
+instance (Monad m, C.IsAlonzoBasedEra era, C.IsEra era) => MonadMockchain era (MockchainT era m) where
   modifyMockChainState f = MockchainT $ state f
   askNodeParams = ask
 
-instance (Monad m, C.IsAlonzoBasedEra era, EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto, C.IsCardanoEra era, C.IsShelleyBasedEra era) => MonadUtxoQuery (MockchainT era m) where
+instance (Monad m, C.IsAlonzoBasedEra era, EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto, C.IsCardanoEra era, C.IsShelleyBasedEra era, C.IsEra era) => MonadUtxoQuery (MockchainT era m) where
   utxosByPaymentCredentials cred = do
     UtxoSet utxos <- fmap (onlyCredentials cred) utxoSet
     let