coin-selection: Fix a bug where coin selection failed on singleton mu…

…lti-asset output (#116)

* coin-selection: Fix a bug where coin selection failed on singleton multi-asset output

* Fixes

changelog.md

@@ -11,6 +11,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
 
 ### Added
 

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

@@ -129,6 +129,8 @@ data CoinSelectionError =
   | BodyError Text
   | NotEnoughAdaOnlyOutputsFor C.Lovelace
   | NotEnoughMixedOutputsFor{ valuesNeeded :: [(C.PolicyId, C.AssetName, C.Quantity)], 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)
   deriving anyclass (ToJSON, FromJSON)
 
@@ -397,7 +399,11 @@ balanceTx dbg returnUTxO0 walletUtxo txb = do
         let UTxO w = availableUTxOs
             UTxO o = otherInputs
         in UTxO (Map.union w o)
-  (finalBody, returnUTxO1) <- mapError ACoinSelectionError (addMissingInputs (natTracer lift dbg) pools params combinedTxIns returnUTxO0 walletUtxo (flip setCollateral walletUtxo $ flip addOwnInput walletUtxo txb0))
+
+  (finalBody, returnUTxO1) <- mapError ACoinSelectionError $ do
+    bodyWithInputs <- addOwnInput txb0 walletUtxo
+    bodyWithCollat <- setCollateral bodyWithInputs walletUtxo
+    addMissingInputs (natTracer lift dbg) pools params combinedTxIns returnUTxO0 walletUtxo bodyWithCollat
   count <- requiredSignatureCount finalBody
   csi <- prepCSInputs count returnUTxO1 combinedTxIns finalBody
   start <- querySystemStart
@@ -437,21 +443,33 @@ signForWallet wallet (C.BalancedTxBody _ txbody _changeOutput _fee) =
   let wit = [C.makeShelleyKeyWitness C.ShelleyBasedEraBabbage txbody $ C.WitnessPaymentKey (Wallet.getWallet wallet)]
   in C.makeSignedTransaction wit txbody
 
-addOwnInput :: TxBodyContent BuildTx ERA -> UtxoSet ctx a -> TxBodyContent BuildTx ERA
-addOwnInput body (Utxos.onlyAda . Utxos.removeUtxos (spentTxIns body) -> UtxoSet{_utxos})
-  | Map.null _utxos = body
-  | not (List.null $ view L.txIns body) = body
-  | otherwise = execBuildTx (spendPublicKeyOutput (fst $ head $ Map.toList _utxos)) body
-
-setCollateral :: TxBodyContent BuildTx ERA -> UtxoSet ctx a -> TxBodyContent BuildTx ERA
+-- | If the transaction body has no inputs then we add one from the wallet's UTxO set.
+--   (we have to do this because 'C.evaluateTransactionBalance' fails on a tx body with
+--    no inputs)
+--   Throws an error if the transaction body has no inputs and the wallet UTxO set is empty.
+addOwnInput :: MonadError CoinSelectionError m => TxBodyContent BuildTx ERA -> UtxoSet ctx a -> m (TxBodyContent BuildTx ERA)
+addOwnInput body (Utxos.removeUtxos (spentTxIns body) -> UtxoSet{_utxos})
+  | not (List.null $ view L.txIns body) = pure body
+  | not (Map.null _utxos) =
+      -- Select ada-only outputs if possible
+      let availableUTxOs = List.sortOn (length . view (L._TxOut . _2 . L._TxOutValue . to C.valueToList) . fst . snd) (Map.toList _utxos)
+      in pure (execBuildTx (spendPublicKeyOutput (fst $ head availableUTxOs)) body)
+  | otherwise = throwError NoWalletUTxOs
+
+-- | Add a collateral input. Throws a 'NoAdaOnlyUTxOsForCollateral' error if a collateral input is required,
+--   but no suitable input is provided in the wallet UTxO set.
+setCollateral :: MonadError CoinSelectionError m => TxBodyContent BuildTx ERA -> UtxoSet ctx a -> m (TxBodyContent BuildTx ERA)
 setCollateral body (Utxos.onlyAda -> UtxoSet{_utxos}) =
-  if not (runsScripts body)
-    then body -- no script witnesses in inputs.
-    else
-      -- select the output with the largest amount of Ada
-      case listToMaybe $ List.sortOn (Down . C.selectLovelace . view (L._TxOut . _2 . L._TxOutValue) . fst . snd) $ Map.toList _utxos of
-        Nothing     -> body -- TODO: Throw error
-        Just (k, _) -> execBuildTx (addCollateral k) body
+  let noScripts = not (runsScripts body)
+      hasCollateral = not (view (L.txInsCollateral . L._TxInsCollateral . to List.null) body)
+  in
+    if noScripts || hasCollateral
+      then pure body -- no script witnesses in inputs.
+      else
+        -- select the output with the largest amount of Ada
+        case listToMaybe $ List.sortOn (Down . C.selectLovelace . view (L._TxOut . _2 . L._TxOutValue) . fst . snd) $ Map.toList _utxos of
+          Nothing     -> throwError NoAdaOnlyUTxOsForCollateral
+          Just (k, _) -> pure (execBuildTx (addCollateral k) body)
 
 {-| Whether the transaction runs any plutus scripts
 -}

src/coin-selection/test/Spec.hs

@@ -29,12 +29,14 @@ import           Convex.BuildTx                 (BuildTxT, addRequiredSignature,
                                                  spendPlutusV2Ref)
 import qualified Convex.BuildTx                 as BuildTx
 import           Convex.Class                   (MonadBlockchain (..),
-                                                 MonadMockchain (resolveDatumHash))
+                                                 MonadMockchain (resolveDatumHash),
+                                                 getUtxo, setUtxo)
 import           Convex.CoinSelection           (BalanceTxError, keyWitnesses,
                                                  publicKeyCredential)
 import qualified Convex.Lenses                  as L
 import           Convex.MockChain               (MockchainError (..),
-                                                 ValidationError (..))
+                                                 ValidationError (..),
+                                                 fromLedgerUTxO)
 import           Convex.MockChain.CoinSelection (balanceAndSubmit,
                                                  payToOperator', paymentTo)
 import qualified Convex.MockChain.Defaults      as Defaults
@@ -46,6 +48,7 @@ import           Convex.MockChain.Utils         (mockchainFails,
 import           Convex.NodeParams              (maxTxSize, protocolParameters)
 import           Convex.Query                   (balancePaymentCredentials)
 import           Convex.Utils                   (failOnError)
+import qualified Convex.Utxos                   as Utxos
 import           Convex.Wallet                  (Wallet)
 import qualified Convex.Wallet                  as Wallet
 import qualified Convex.Wallet.MockWallet       as Wallet
@@ -86,6 +89,7 @@ tests = testGroup "unit tests"
     , testCase "minting a token" (mockchainSucceeds $ failOnError mintingPlutus)
     , testCase "making payments with tokens" (mockchainSucceeds $ failOnError (mintingPlutus >>= spendTokens))
     , testCase "making payments with tokens (2)" (mockchainSucceeds $ failOnError (mintingPlutus >>= spendTokens2))
+    , testCase "spending a singleton output" (mockchainSucceeds $ failOnError (mintingPlutus >>= spendSingletonOutput))
     ]
   , testGroup "mockchain"
     [ testCase "resolveDatumHash" (mockchainSucceeds $ failOnError checkResolveDatumHash)
@@ -167,6 +171,7 @@ spendTokens _ = do
   _ <- nativeAssetPaymentTo 100 Wallet.w2 Wallet.w3
   nativeAssetPaymentTo 99 Wallet.w3 Wallet.w1
 
+
 spendTokens2 :: (MonadFail m, MonadMockchain m, MonadError BalanceTxError m) => C.TxId -> m C.TxId
 spendTokens2 txi = do
   let q  = 98
@@ -181,6 +186,22 @@ spendTokens2 txi = do
   void $ wTo `paymentTo` wFrom
   C.getTxId . C.getTxBody <$> balanceAndSubmit mempty wFrom tx
 
+-- | Put all of the Wallet 2's funds into a single UTxO with mixed assets
+--   Then make a transaction that splits this output into two
+spendSingletonOutput :: (MonadFail m, MonadMockchain m, MonadError BalanceTxError m) => C.TxId -> m ()
+spendSingletonOutput txi = do
+  void (nativeAssetPaymentTo 49 Wallet.w1 Wallet.w2 >> Wallet.w1 `paymentTo` Wallet.w2)
+  utxoSet <- Utxos.fromApiUtxo . fromLedgerUTxO C.ShelleyBasedEraBabbage <$> getUtxo
+  let k = Utxos.onlyCredential (Wallet.paymentCredential Wallet.w2) utxoSet
+  let totalVal = Utxos.totalBalance k
+      newOut = C.TxOut (Wallet.addressInEra Defaults.networkId Wallet.w2) (C.TxOutValueShelleyBased C.ShelleyBasedEraBabbage $ C.toMaryValue totalVal) C.TxOutDatumNone C.ReferenceScriptNone
+      utxoSetMinusW2 = Utxos.removeUtxos (Map.keysSet $ Utxos._utxos k) utxoSet
+      utxoSetPlusSingleOutput = utxoSetMinusW2 <> Utxos.singleton (C.TxIn txi $ C.TxIx 1000) (newOut, ())
+
+  setUtxo (C.toLedgerUTxO C.ShelleyBasedEraBabbage $ Utxos.toApiUtxo utxoSetPlusSingleOutput)
+  -- check that wallet 2 only
+  void $ nativeAssetPaymentTo 49 Wallet.w1 Wallet.w2
+
 nativeAssetPaymentTo :: (MonadMockchain m, MonadFail m, MonadError BalanceTxError m) => C.Quantity -> Wallet -> Wallet -> m C.TxId
 nativeAssetPaymentTo q wFrom wTo = do
   let vl = assetValue (C.hashScript $ C.PlutusScript C.PlutusScriptV1 mintingScript) "assetName" q