coin-selection: Check for Plutus script compatibility

changelog.md

@@ -11,6 +11,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 
 - Move `Convex.BuildTx` and `Convex.CoinSelection.CardanoAPI` from `convex-coin-selection` to `convex-base`
 - Rename `Convex.CoinSelection.CardanoAPI` to `Convex.CoinSelection`
+* When selecting public-key UTxOs during coin selection, outputs that are incompatible with PlutusV1 scripts are excluded.
 - Added a `Tracer m TxBalancingMessage` argument to the coin selection functions. This prints out useful information about decisions taken during coin selection and balancing. Instantiate with `mempty` to ignore the messages.
 - Changed the `protocolParameters`, `ledgerProtocolParameters` lenses in `Convex.NodeParams` to update the other field too (making sure they are always in sync)
 - Export `Convex.Wallet.MockWallet.w4`

src/coin-selection/convex-coin-selection.cabal

@@ -31,6 +31,7 @@ library
       Convex.CoinSelection
       Convex.MockChain.CoinSelection
       Convex.Query
+      Convex.UTxOCompatibility
     hs-source-dirs: lib
     build-depends:
       aeson,

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

@@ -66,6 +66,8 @@ import           Convex.Class              (MonadBlockchain (..))
 import qualified Convex.Era                as Ledger.Era
 import qualified Convex.Lenses             as L
 import           Convex.Utils              (mapError)
+import           Convex.UTxOCompatibility  (UTxOCompatibility, compatibleWith,
+                                            txCompatibility)
 import           Convex.Utxos              (BalanceChanges (..), UtxoSet (..))
 import qualified Convex.Utxos              as Utxos
 import           Convex.Wallet             (Wallet)
@@ -148,6 +150,7 @@ balancingError = either (throwError . BalancingError . Text.pack . C.displayErro
 -- | Messages that are produced during coin selection and balancing
 data TxBalancingMessage =
   SelectingCoins
+  | CompatibilityLevel{ compatibility :: !UTxOCompatibility, droppedTxIns :: !Int } -- ^ The plutus compatibility level applied to the wallet tx outputs
   | PrepareInputs{walletBalance :: C.Value, transactionBalance :: C.Value} -- ^ Preparing to balance the transaction using the available wallet balance
   | StartBalancing{numInputs :: !Int, numOutputs :: !Int} -- ^ Balancing a transaction body
   | ExUnitsMap{ exUnits :: [(Text, Either String C.ExecutionUnits)] } -- ^ Execution units of the transaction, or error message in case of script error
@@ -391,20 +394,33 @@ balanceTx ::
 balanceTx dbg returnUTxO0 walletUtxo txb = do
   (params, ledgerPPs) <- queryProtocolParameters
   pools <- queryStakePools
+  availableUTxOs <- checkCompatibilityLevel dbg txb walletUtxo
+  -- compatibility level
   let txb0 = txb & L.txProtocolParams .~ C.BuildTxWith (Just params)
   -- TODO: Better error handling (better than 'fail')
   otherInputs <- lookupTxIns (requiredTxIns txb)
   let combinedTxIns =
-        let UtxoSet w = walletUtxo
+        let UTxO w = availableUTxOs
             UTxO o = otherInputs
-        in UTxO (Map.union (fmap fst w) o)
+        in UTxO (Map.union w o)
   (finalBody, returnUTxO1) <- mapError ACoinSelectionError (addMissingInputs (natTracer lift dbg) pools ledgerPPs combinedTxIns returnUTxO0 walletUtxo (flip setCollateral walletUtxo $ flip addOwnInput walletUtxo txb0))
   count <- requiredSignatureCount finalBody
   csi <- prepCSInputs count returnUTxO1 combinedTxIns finalBody
   start <- querySystemStart
   hist <- queryEraHistory
   mapError ABalancingError (balanceTransactionBody (natTracer lift dbg) start hist ledgerPPs pools csi)
 
+-- | Check the compatibility level of the transaction body
+--   and remove any incompatible UTxOs from the UTxO set.
+checkCompatibilityLevel :: Monad m => Tracer m TxBalancingMessage -> TxBodyContent BuildTx ERA -> UtxoSet C.CtxUTxO a -> m (UTxO BabbageEra)
+checkCompatibilityLevel tr txB (UtxoSet w) = do
+  let compatibility = txCompatibility txB
+      utxoIn = UTxO (fmap fst w)
+      UTxO utxoOut = compatibleWith compatibility utxoIn
+      droppedTxIns = Map.size w - Map.size utxoOut
+  traceWith tr CompatibilityLevel{compatibility, droppedTxIns}
+  pure (UTxO utxoOut)
+
 {-| Balance the transaction using the wallet's funds, then sign it.
 -}
 balanceForWallet :: (MonadBlockchain m, MonadError BalanceTxError m) => Tracer m TxBalancingMessage -> Wallet -> UtxoSet C.CtxUTxO a -> TxBodyContent BuildTx ERA -> m (C.Tx ERA, BalanceChanges)

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

@@ -0,0 +1,77 @@
+{-# LANGUAGE DeriveAnyClass     #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GADTs              #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE MonoLocalBinds     #-}
+{-# LANGUAGE NamedFieldPuns     #-}
+{-| Filter the UTxO set for outputs that are compatible
+    with specific versions of Plutus
+-}
+module Convex.UTxOCompatibility(
+  UTxOCompatibility(..),
+  compatibleWith,
+  deleteInlineDatums,
+  scriptWitnessCompat,
+  anyScriptWitnessCompat,
+  txCompatibility
+) where
+
+import           Cardano.Api         (BabbageEra, UTxO (..))
+import qualified Cardano.Api.Shelley as C
+import qualified Control.Lens        as L
+import qualified Convex.Lenses       as L
+import           Data.Aeson          (FromJSON, ToJSON)
+import qualified Data.Map            as Map
+import           Data.Maybe          (isJust)
+import           GHC.Generics        (Generic)
+
+-- | Compatibility setting for coin selection.
+--   Used to filter out incompatible UTxOs for
+--   coin selection.
+data UTxOCompatibility =
+  -- NOTE: The order of constructors is important
+  --       as it determines the 'Ord' instance, which
+  --       we use in 'txCompatibility'
+  PlutusV1Compatibility -- ^ Plutus V1 scripts can't be run in a transaction that also spends (script OR public key) outputs with inline datums.
+  | AnyCompatibility -- ^ All outputs
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving anyclass (ToJSON, FromJSON)
+
+-- | Delete incompatible outputs from the UTxO set
+compatibleWith :: UTxOCompatibility -> UTxO BabbageEra -> UTxO BabbageEra
+compatibleWith = \case
+  PlutusV1Compatibility -> deleteInlineDatums
+  AnyCompatibility -> id
+
+{-| Delete UTxOs that have inline datums, as this is not supported by Plutus V1
+-}
+deleteInlineDatums :: UTxO BabbageEra -> UTxO BabbageEra
+deleteInlineDatums (UTxO o) =
+  let hasInlineDatum = isJust . L.preview (L._TxOut . L._3 . L._TxOutDatumInline)
+  in UTxO (Map.filter (not . hasInlineDatum) o)
+
+anyScriptWitnessCompat :: forall era. C.AnyScriptWitness era -> UTxOCompatibility
+anyScriptWitnessCompat = \case
+  C.AnyScriptWitness wit -> scriptWitnessCompat wit
+
+-- | The highest possible compatibility level at which the script
+--   can be run
+scriptWitnessCompat :: forall witctx era. C.ScriptWitness witctx era -> UTxOCompatibility
+scriptWitnessCompat (C.PlutusScriptWitness lang _ _ _ _ _) = case lang of
+  C.PlutusScriptV1InAlonzo  -> PlutusV1Compatibility
+  C.PlutusScriptV1InBabbage -> PlutusV1Compatibility
+  C.PlutusScriptV2InBabbage -> AnyCompatibility
+  C.SimpleScriptV1InShelley -> AnyCompatibility
+  C.SimpleScriptV1InAllegra -> AnyCompatibility
+  C.SimpleScriptV2InAllegra -> AnyCompatibility
+  C.SimpleScriptV1InMary    -> AnyCompatibility
+  C.SimpleScriptV2InMary    -> AnyCompatibility
+  C.SimpleScriptV1InAlonzo  -> AnyCompatibility
+  C.SimpleScriptV2InAlonzo  -> AnyCompatibility
+  C.SimpleScriptV1InBabbage -> AnyCompatibility
+  C.SimpleScriptV2InBabbage -> AnyCompatibility
+scriptWitnessCompat (C.SimpleScriptWitness _ _ _) = AnyCompatibility
+
+-- | Compatibility level of the transaction
+txCompatibility :: C.TxBodyContent C.BuildTx C.BabbageEra -> UTxOCompatibility
+txCompatibility = foldr min AnyCompatibility . fmap (anyScriptWitnessCompat . snd) . C.collectTxBodyScriptWitnesses