Build transactions with all-mixed-inputs (#126)

* Consider mixed inputs when balancing WIP

* Add failing test

* Fix coin selection

changelog.md

@@ -13,6 +13,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 * Updated the [conway genesis configuration file](node-config/mainnet/mainnet-conway-genesis.json) for mainnet
 * When selecting public-key UTxOs during coin selection, outputs that are incompatible with PlutusV1 scripts are excluded.
 * Fixed a bug in coin selection where the wallet's mixed inputs were not considered for a `TxBodyContent` with zero inputs
+* Improved the coin selection algorithm to correctly select mixed inputs for covering the transaction fees. Previously, only pure Ada inputs were considered for the fees.
 
 ### Added
 

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

@@ -52,8 +52,8 @@ import qualified Cardano.Ledger.Keys       as Keys
 import           Cardano.Slotting.Time     (SystemStart)
 import           Control.Lens              (_1, _2, at, makeLensesFor, over,
                                             preview, set, to, traversed, view,
-                                            (&), (.~), (<>~), (?~), (^.), (^..),
-                                            (|>))
+                                            (%~), (&), (.~), (<>~), (?~), (^.),
+                                            (^..), (|>))
 import           Control.Monad             (when)
 import           Control.Monad.Except      (MonadError (..))
 import           Control.Monad.Trans.Class (MonadTrans (..))
@@ -126,8 +126,8 @@ makeLensesFor
 data CoinSelectionError =
   UnsupportedBalance (C.TxOutValue ERA)
   | BodyError Text
-  | NotEnoughAdaOnlyOutputsFor C.Lovelace
-  | NotEnoughMixedOutputsFor{ valuesNeeded :: [(C.PolicyId, C.AssetName, C.Quantity)], valueProvided :: C.Value, txBalance :: C.Value }
+  | NotEnoughInputsFor{ lovelaceRequired :: C.Lovelace, lovelaceFound :: C.Lovelace }
+  | NotEnoughMixedOutputsFor{ valuesNeeded :: C.Value, valueProvided :: C.Value, txBalance :: C.Value }
   | NoWalletUTxOs -- ^ The wallet utxo set is empty
   | NoAdaOnlyUTxOsForCollateral -- ^ The transaction body needs a collateral input, but there are no inputs that hold nothing but Ada
   deriving stock (Show, Generic)
@@ -151,13 +151,13 @@ balancingError = either (throwError . BalancingError . Text.pack . C.docToString
 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
+  | PrepareInputs{availableBalance :: 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 :: [(C.ScriptWitnessIndex, Either String C.ExecutionUnits)] } -- ^ Execution units of the transaction, or error message in case of script error
   | Txfee{ fee :: C.Lovelace } -- ^ The transaction fee
   | TxRemainingBalance{ remainingBalance :: C.Value } -- ^ The remaining balance (after paying the fee)
-  | NoNonAdaAssetsMissing -- ^ The transaction was not missing any non-Ada assets.
-  | MissingNativeAssets [(C.PolicyId, C.AssetName, C.Quantity)] -- ^ The transaction is missing some non-Ada inputs, these will be covered from the wallet's UTxOs.
+  | NoAssetsMissing -- ^ The transaction was not missing any assets
+  | MissingAssets C.Value -- ^ The transaction is missing some inputs, these will be covered from the wallet's UTxOs.
   | MissingLovelace C.Lovelace -- ^ The transaction is missing some Ada. The amount will be covered from the wallet's UTxOs.
   deriving stock (Eq, Show, Generic)
   deriving anyclass (ToJSON)
@@ -402,7 +402,7 @@ balanceTx dbg returnUTxO0 walletUtxo txb = do
   (finalBody, returnUTxO1) <- mapError ACoinSelectionError $ do
     bodyWithInputs <- addOwnInput txb0 walletUtxo
     bodyWithCollat <- setCollateral bodyWithInputs walletUtxo
-    addMissingInputs (natTracer lift dbg) pools params combinedTxIns returnUTxO0 walletUtxo bodyWithCollat
+    balancePositive (natTracer lift dbg) pools params combinedTxIns returnUTxO0 walletUtxo bodyWithCollat
   count <- requiredSignatureCount finalBody
   csi <- prepCSInputs count returnUTxO1 combinedTxIns finalBody
   start <- querySystemStart
@@ -478,78 +478,65 @@ runsScripts body =
       minting   = body ^. (L.txMintValue . L._TxMintValue . _2)
   in not (null scriptIns && Map.null minting)
 
-{-| Add inputs to ensure that the balance is strictly positive
+{-| Add inputs to ensure that the balance is strictly positive. After calling @balancePositive@
+* The amount of Ada provided by the transaction's inputs minus (the amount of Ada produced by the transaction's outputs plus the change output) is greater than zero
+* For all native tokens @t@, the amount of @t@ provided by the transaction's inputs minus (the amount of @t@ produced by the transaction's outputs plus the change output plus the delta of @t@ minted / burned) is equal to zero
 -}
-addMissingInputs :: MonadError CoinSelectionError m => Tracer m TxBalancingMessage -> Set PoolId -> C.LedgerProtocolParameters BabbageEra -> C.UTxO ERA -> C.TxOut C.CtxTx C.BabbageEra -> UtxoSet ctx a -> TxBodyContent BuildTx ERA -> m (TxBodyContent BuildTx ERA, C.TxOut C.CtxTx C.BabbageEra)
-addMissingInputs dbg poolIds ledgerPPs utxo_ returnUTxO0 walletUtxo txBodyContent0 = do
+balancePositive :: MonadError CoinSelectionError m => Tracer m TxBalancingMessage -> Set PoolId -> C.LedgerProtocolParameters BabbageEra -> C.UTxO ERA -> C.TxOut C.CtxTx C.BabbageEra -> UtxoSet ctx a -> TxBodyContent BuildTx ERA -> m (TxBodyContent BuildTx ERA, C.TxOut C.CtxTx C.BabbageEra)
+balancePositive dbg poolIds ledgerPPs utxo_ returnUTxO0 walletUtxo txBodyContent0 = do
   txb <- either (throwError . bodyError) pure (C.createAndValidateTransactionBody C.ShelleyBasedEraBabbage txBodyContent0)
   let bal = C.evaluateTransactionBalance C.ShelleyBasedEraBabbage (C.unLedgerProtocolParameters ledgerPPs) poolIds mempty mempty utxo_ txb & view L._TxOutValue
       available = Utxos.removeUtxos (spentTxIns txBodyContent0) walletUtxo
+
+  -- minimum positive balance (in lovelace) that must be available to cover
+  -- * minimum deposit on the ada-only change output, if required, and
+  -- * transaction fee, incl. script fee if required
+  -- we set it to rather large value to ensure that we can build a valid transaction.
+  let threshold = negate (if runsScripts txBodyContent0 then 8_000_000 else 2_500_000)
+      balance = bal & L._Value . at C.AdaAssetId %~ maybe (Just threshold) (Just . (+) threshold)
+
   traceWith dbg PrepareInputs
-    { walletBalance      = Utxos.totalBalance walletUtxo
-    , transactionBalance = bal
+    { availableBalance   = Utxos.totalBalance available
+    , transactionBalance = balance
     }
-  (txBodyContent1, additionalBalance) <- addInputsForNonAdaAssets dbg bal walletUtxo txBodyContent0
-
-  let bal0 = bal <> additionalBalance
-  let (returnUTxO1, C.Lovelace deposit) = addOutputForNonAdaAssets ledgerPPs returnUTxO0 bal0
-
-      -- minimum positive balance (in lovelace) that must be available to cover
-      -- * minimum deposit on the ada-only change output, if required, and
-      -- * transaction fee, incl. script fee if required
-      -- we set it to rather large value to ensure that we can build a valid transaction.
-  let threshold =
-        if runsScripts txBodyContent1
-          then 8_000_000
-          else 2_500_000
-      C.Lovelace l = C.selectLovelace bal0
-      missingLovelace = C.Lovelace (deposit + threshold - l)
-
-  traceWith dbg (MissingLovelace missingLovelace)
-  (,returnUTxO1) <$> addAdaOnlyInputsFor missingLovelace available txBodyContent1
-
-{-| Select inputs from the wallet's UTXO set to cover the given amount of lovelace.
-Will only consider inputs that have no other assets besides Ada.
--}
-addAdaOnlyInputsFor :: MonadError CoinSelectionError m => C.Lovelace -> UtxoSet ctx a -> TxBodyContent BuildTx ERA -> m (TxBodyContent BuildTx ERA)
-addAdaOnlyInputsFor l availableUtxo txBodyContent =
-  case Wallet.selectAdaInputsCovering availableUtxo l of
-    Nothing -> throwError (NotEnoughAdaOnlyOutputsFor l)
-    Just (_, ins) -> pure (txBodyContent & over L.txIns (<> fmap spendPubKeyTxIn ins))
+  (txBodyContent1, additionalBalance) <- addInputsForAssets dbg balance available txBodyContent0
+
+  let bal0 = balance <> additionalBalance
+  let (returnUTxO1, _deposit) = addOutputForNonAdaAssets ledgerPPs returnUTxO0 bal0
+
+  pure (txBodyContent1, returnUTxO1)
 
 {-| Examine the negative part of the transaction balance and select inputs from
-the wallet's UTXO set to cover the non-Ada assets required by it. If there are no
-non-Ada asset then no inputs will be added.
+the wallet's UTXO set to cover the assets required by it. If there are no
+assets missing then no inputs will be added.
 -}
-addInputsForNonAdaAssets ::
+addInputsForAssets ::
   MonadError CoinSelectionError m =>
   Tracer m TxBalancingMessage ->
-  C.Value ->
-  UtxoSet ctx a ->
-  TxBodyContent BuildTx ERA ->
-  m (TxBodyContent BuildTx ERA, C.Value)
-addInputsForNonAdaAssets dbg txBal availableUtxo txBodyContent
-  | isNothing (C.valueToLovelace $ C.valueFromList $ fst $ splitValue txBal) = do
-      let nativeAsset (C.AdaAssetId, _) = Nothing
-          nativeAsset (C.AssetId p n, C.Quantity q) = Just (p, n, C.Quantity (abs q))
-          missingNativeAssets = mapMaybe nativeAsset (fst $ splitValue txBal)
-      traceWith dbg (MissingNativeAssets missingNativeAssets)
-      case Wallet.selectMixedInputsCovering availableUtxo missingNativeAssets of
-        Nothing -> throwError (NotEnoughMixedOutputsFor missingNativeAssets (Utxos.totalBalance availableUtxo) txBal)
-        Just (total, ins) -> pure (txBodyContent & over L.txIns (<> fmap spendPubKeyTxIn ins), total)
-  | otherwise = do
-      traceWith dbg NoNonAdaAssetsMissing
+  C.Value -> -- ^ The balance of the transaction
+  UtxoSet ctx a -> -- ^ UTxOs that we can spend to cover the negative part of the balance
+  TxBodyContent BuildTx ERA -> -- ^ Transaction body
+  m (TxBodyContent BuildTx ERA, C.Value) -- ^ Transaction body with additional inputs and the total value of the additional inputs
+addInputsForAssets dbg txBal availableUtxo txBodyContent
+  | null (fst $ splitValue txBal) = do
+      traceWith dbg NoAssetsMissing
       return (txBodyContent, mempty)
+  | otherwise = do
+      let missingAssets = fmap (second abs) $ fst $ splitValue txBal
+      traceWith dbg (MissingAssets $ C.valueFromList missingAssets)
+      case Wallet.selectMixedInputsCovering availableUtxo missingAssets of
+        Nothing -> throwError (NotEnoughMixedOutputsFor (C.valueFromList missingAssets) (Utxos.totalBalance availableUtxo) txBal)
+        Just (total, ins) -> pure (txBodyContent & over L.txIns (<> fmap spendPubKeyTxIn ins), total)
 
-{-| Examine the positive part of the transaction balance and add an output for
-any non-Ada asset it contains. If the positive part only contains Ada then no
-output is added.
+{-| Examine the positive part of the transaction balance and add any non-Ada assets it contains
+to the provided change output. If the positive part only contains Ada then the
+change output is returned unmodified.
 -}
 addOutputForNonAdaAssets ::
   C.LedgerProtocolParameters BabbageEra -> -- ^ Protocol parameters (for computing the minimum lovelace amount in the output)
-  C.TxOut C.CtxTx C.BabbageEra -> -- ^ Address of the newly created output
+  C.TxOut C.CtxTx C.BabbageEra -> -- ^ Change output. Overflow non-Ada assets will be added to this output's value.
   C.Value -> -- ^ The balance of the transaction
-  (C.TxOut C.CtxTx C.BabbageEra, C.Lovelace) -- ^ The modified transaction body and the lovelace portion of the change output's value. If no output was added then the amount will be 0.
+  (C.TxOut C.CtxTx C.BabbageEra, C.Lovelace) -- ^ The modified change output and the lovelace portion of the change output's value. If no output was added then the amount will be 0.
 addOutputForNonAdaAssets pparams returnUTxO (C.valueFromList . snd . splitValue -> positives)
   | isNothing (C.valueToLovelace positives) =
       let vlWithoutAda = positives & set (L._Value . at C.AdaAssetId) Nothing

src/coin-selection/test/Spec.hs

@@ -14,6 +14,7 @@ import           Cardano.Ledger.Shelley.Rules   (ShelleyLedgerPredFailure (..))
 import           Control.Lens                   (_3, _4, view, (&), (.~))
 import           Control.Monad                  (replicateM, void, when)
 import           Control.Monad.Except           (MonadError, runExceptT)
+import           Control.Monad.IO.Class         (MonadIO (..))
 import           Control.Monad.State.Strict     (execStateT, modify)
 import           Control.Monad.Trans.Class      (MonadTrans (..))
 import           Convex.BuildTx                 (BuildTxT, addRequiredSignature,
@@ -79,6 +80,7 @@ tests = testGroup "unit tests"
     [ testCase "spending a public key output" spendPublicKeyOutput
     , testCase "making several payments" makeSeveralPayments
     , testProperty "balance transactions with many addresses" balanceMultiAddress
+    , testCase "build a transaction without Ada-only inputs" buildTxMixedInputs
     ]
   , testGroup "scripts"
     [ testCase "paying to a plutus script" (mockchainSucceeds $ failOnError payToPlutusScript)
@@ -299,6 +301,31 @@ balanceMultiAddress = do
                 when (pkh `Set.member` txInputs || (C.verificationKeyHash . verificationKey $ oPaymentKey o) `Set.member` extraWits) (modify (signTxOperator o))
               void (sendTx finalTx)
 
+buildTxMixedInputs :: Assertion
+buildTxMixedInputs = mockchainSucceeds $ failOnError $ do
+  testWallet <- liftIO Wallet.generateWallet
+  -- configure the UTxO set to that the new wallet has two outputs, each with 40 native tokens and 10 Ada.
+  utxoSet <- Utxos.fromApiUtxo . fromLedgerUTxO C.ShelleyBasedEraBabbage <$> getUtxo
+  let utxoVal = assetValue (C.hashScript $ C.PlutusScript C.PlutusScriptV1 mintingScript) "assetName" 40 <> C.lovelaceToValue 10_000_000
+      newUTxO = C.TxOut (Wallet.addressInEra Defaults.networkId testWallet) (C.TxOutValueShelleyBased C.ShelleyBasedEraBabbage $ C.toMaryValue utxoVal) C.TxOutDatumNone C.ReferenceScriptNone
+      txi :: C.TxId = "771dfef6ad6f1fc51eb399c07ff89257b06ba9822aec8f83d89012f04eb738f2"
+  setUtxo
+    $ C.toLedgerUTxO C.ShelleyBasedEraBabbage
+    $ Utxos.toApiUtxo
+    $ utxoSet
+      <> Utxos.singleton (C.TxIn txi $ C.TxIx 1000) (newUTxO, ())
+      <> Utxos.singleton (C.TxIn txi $ C.TxIx 1001) (newUTxO, ())
+
+  -- pay 'utxoVal' to wallet 1.
+  -- this requires both outputs to be included in the final transaction
+  -- so that there is enough Ada for the transaction fees.
+  void
+    $ balanceAndSubmit mempty testWallet
+    $ BuildTx.buildTx
+    $ BuildTx.execBuildTx
+    $ payToAddress (Wallet.addressInEra Defaults.networkId Wallet.w1) utxoVal
+
+
 largeTransactionTest :: Assertion
 largeTransactionTest = do
   let largeDatum :: [Integer] = replicate 10_000 33

src/wallet/lib/Convex/Wallet.hs

@@ -142,17 +142,14 @@ selectAnyInputsCovering UtxoSet{_utxos} (C.Lovelace target) =
 {-| Select inputs that cover the given amount of non-Ada
 assets.
 -}
-selectMixedInputsCovering :: UtxoSet ctx a -> [(C.PolicyId, C.AssetName, C.Quantity)] -> Maybe (C.Value, [C.TxIn])
+selectMixedInputsCovering :: UtxoSet ctx a -> [(C.AssetId, C.Quantity)] -> Maybe (C.Value, [C.TxIn])
 selectMixedInputsCovering UtxoSet{_utxos} xs =
   let append (vl, txIns) (vl', txIn) = (vl <> vl', txIn : txIns)
       coversTarget (candidateVl, _txIns) =
-        all (\(policyId, assetName, quantity) -> C.selectAsset candidateVl (C.AssetId policyId assetName) >= quantity) xs
-      requiredAssets = foldMap (\(p, a, _) -> Set.singleton (p, a)) xs
-      nonAdaAssets = \case
-        C.AdaAssetId  -> Set.empty
-        C.AssetId p n -> Set.singleton (p, n)
+        all (\(assetId, quantity) -> C.selectAsset candidateVl assetId >= quantity) xs
+      requiredAssets = foldMap (\(a, _) -> Set.singleton a) xs
       relevantValue (txIn, view (L._TxOut . _2 . L._TxOutValue) -> txOutValue) =
-        let providedAssets = foldMap (nonAdaAssets . fst) (C.valueToList txOutValue)
+        let providedAssets = foldMap (Set.singleton . fst) (C.valueToList txOutValue)
         in if Set.null (Set.intersection requiredAssets providedAssets)
           then Nothing
           else Just (txOutValue, txIn)