From 8465bdd7d81592ad86c55219d96ec5aa478aa906 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Fri, 26 Jan 2024 22:21:27 +0100 Subject: [PATCH] coin-selection: Check for Plutus script compatibility --- changelog.md | 1 + .../convex-coin-selection.cabal | 1 + .../lib/Convex/CoinSelection.hs | 20 ++++- .../lib/Convex/UTxOCompatibility.hs | 77 +++++++++++++++++++ 4 files changed, 97 insertions(+), 2 deletions(-) create mode 100644 src/coin-selection/lib/Convex/UTxOCompatibility.hs diff --git a/changelog.md b/changelog.md index 7062da2e..c84ac737 100644 --- a/changelog.md +++ b/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` diff --git a/src/coin-selection/convex-coin-selection.cabal b/src/coin-selection/convex-coin-selection.cabal index 614e270c..0d62c249 100644 --- a/src/coin-selection/convex-coin-selection.cabal +++ b/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, diff --git a/src/coin-selection/lib/Convex/CoinSelection.hs b/src/coin-selection/lib/Convex/CoinSelection.hs index 3c9007b0..3943d169 100644 --- a/src/coin-selection/lib/Convex/CoinSelection.hs +++ b/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,13 +394,15 @@ 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 @@ -405,6 +410,17 @@ balanceTx dbg returnUTxO0 walletUtxo txb = do 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) diff --git a/src/coin-selection/lib/Convex/UTxOCompatibility.hs b/src/coin-selection/lib/Convex/UTxOCompatibility.hs new file mode 100644 index 00000000..4a8382b6 --- /dev/null +++ b/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