diff --git a/lib/byron/test/integration/Test/Integration/Byron/Scenario/API/Transactions.hs b/lib/byron/test/integration/Test/Integration/Byron/Scenario/API/Transactions.hs index e86ceb58067..a251a557b0b 100644 --- a/lib/byron/test/integration/Test/Integration/Byron/Scenario/API/Transactions.hs +++ b/lib/byron/test/integration/Test/Integration/Byron/Scenario/API/Transactions.hs @@ -79,7 +79,6 @@ import Test.Integration.Framework.DSL , fixtureRandomWallet , fixtureRandomWalletAddrs , fixtureRandomWalletMws - , fixtureRandomWalletWith , getFromResponse , icarusAddresses , json @@ -93,9 +92,7 @@ import Test.Integration.Framework.Request ( RequestException ) import Test.Integration.Framework.TestData ( errMsg403Fee - , errMsg403InputsDepleted , errMsg403NotEnoughMoney_ - , errMsg403UTxO , errMsg403WrongPass , errMsg404NoWallet ) @@ -137,12 +134,9 @@ spec = do , fixtureRandomWalletAddrs @n ] - scenario_TRANS_CREATE_02x @n - -- TRANS_CREATE_03 requires actually being able to compute exact fees, which -- is not really possible w/ cardano-node. So, skipping. - scenario_TRANS_CREATE_04a @n scenario_TRANS_CREATE_04b @n scenario_TRANS_CREATE_04c @n scenario_TRANS_CREATE_04d @n @@ -158,7 +152,6 @@ spec = do , icarusAddresses @n . entropyToMnemonic <$> genEntropy ] - scenario_TRANS_ESTIMATE_04a @n scenario_TRANS_ESTIMATE_04b @n scenario_TRANS_ESTIMATE_04c @n @@ -294,50 +287,6 @@ scenario_TRANS_ESTIMATE_01_02 fixtureSource fixtures = it title $ \ctx -> do where title = "TRANS_ESTIMATE_01/02 - " ++ show (length fixtures) ++ " recipient(s)" -scenario_TRANS_CREATE_02x - :: forall (n :: NetworkDiscriminant) t. - ( DecodeAddress n - , EncodeAddress n - , PaymentAddress n ByronKey - ) - => SpecWith (Context t) -scenario_TRANS_CREATE_02x = it title $ \ctx -> do - -- SETUP - (wSrc, payments) <- fixtureSingleUTxO @n ctx - - -- ACTION - r <- postByronTransaction @n ctx wSrc payments fixturePassphrase - - -- ASSERTIONS - verify r - [ expectResponseCode HTTP.status403 - , expectErrorMessage errMsg403UTxO - ] - where - title = "TRANS_CREATE_02x - Multi-output failure w/ single UTxO" - -scenario_TRANS_CREATE_04a - :: forall (n :: NetworkDiscriminant) t. - ( DecodeAddress n - , EncodeAddress n - , PaymentAddress n ByronKey - ) - => SpecWith (Context t) -scenario_TRANS_CREATE_04a = it title $ \ctx -> do - -- SETUP - (wSrc, payments) <- fixtureErrInputsDepleted @n ctx - - -- ACTION - r <- postByronTransaction @n ctx wSrc payments fixturePassphrase - - -- ASSERTIONS - verify r - [ expectResponseCode HTTP.status403 - , expectErrorMessage errMsg403InputsDepleted - ] - where - title = "TRANS_CREATE_04 - Error shown when ErrInputsDepleted encountered" - scenario_TRANS_CREATE_04b :: forall (n :: NetworkDiscriminant) t. ( DecodeAddress n @@ -404,28 +353,6 @@ scenario_TRANS_CREATE_04d = it title $ \ctx -> do where title = "TRANS_CREATE_04 - Wrong password" -scenario_TRANS_ESTIMATE_04a - :: forall (n :: NetworkDiscriminant) t. - ( DecodeAddress n - , EncodeAddress n - , PaymentAddress n ByronKey - ) - => SpecWith (Context t) -scenario_TRANS_ESTIMATE_04a = it title $ \ctx -> do - -- SETUP - (wSrc, payments) <- fixtureErrInputsDepleted @n ctx - - -- ACTION - r <- estimateByronTransaction ctx wSrc payments - - -- ASSERTIONS - verify r - [ expectResponseCode HTTP.status403 - , expectErrorMessage errMsg403InputsDepleted - ] - where - title = "TRANS_ESTIMATE_04 - Error shown when ErrInputsDepleted encountered" - scenario_TRANS_ESTIMATE_04b :: forall (n :: NetworkDiscriminant) t. ( DecodeAddress n @@ -814,45 +741,6 @@ scenario_TRANS_REG_1670 fixture = it title $ \ctx -> do -- More Elaborated Fixtures -- --- | Returns a source wallet and a list of payments. --- --- NOTE: Random or Icarus wallets can be used interchangeably here. -fixtureSingleUTxO - :: forall (n :: NetworkDiscriminant) t. - ( DecodeAddress n - , EncodeAddress n - , PaymentAddress n ByronKey - ) - => Context t - -> IO (ApiByronWallet, [Aeson.Value]) -fixtureSingleUTxO ctx = do - wSrc <- fixtureRandomWalletWith @n ctx [1_000_000] - addrs <- randomAddresses @n . entropyToMnemonic <$> genEntropy - let payments = - [ mkPayment @n (head addrs) 100_000 - , mkPayment @n (head addrs) 100_000 - ] - pure (wSrc, payments) - --- | Returns a source wallet and a list of payments. If submitted, the payments --- should result in an error 403. --- --- NOTE: Random or Icarus wallets can be used interchangeably here. -fixtureErrInputsDepleted - :: forall (n :: NetworkDiscriminant) t. - ( DecodeAddress n - , EncodeAddress n - , PaymentAddress n ByronKey - ) - => Context t - -> IO (ApiByronWallet, [Aeson.Value]) -fixtureErrInputsDepleted ctx = do - wSrc <- fixtureRandomWalletWith @n ctx [12_000_000, 20_000_000, 17_000_000] - addrs <- randomAddresses @n . entropyToMnemonic <$> genEntropy - let amnts = [40_000_000, 22, 22] :: [Natural] - let payments = flip map (zip addrs amnts) $ uncurry (mkPayment @n) - pure (wSrc, payments) - -- | Returns a source wallet and a list of payments. -- -- NOTE: Random or Icarus wallets can be used interchangeably here. diff --git a/lib/byron/test/integration/Test/Integration/Byron/Scenario/CLI/Transactions.hs b/lib/byron/test/integration/Test/Integration/Byron/Scenario/CLI/Transactions.hs index 82b4839b836..83ca0a12c26 100644 --- a/lib/byron/test/integration/Test/Integration/Byron/Scenario/CLI/Transactions.hs +++ b/lib/byron/test/integration/Test/Integration/Byron/Scenario/CLI/Transactions.hs @@ -101,10 +101,8 @@ import Test.Integration.Framework.TestData ( cmdOk , errMsg400StartTimeLaterThanEndTime , errMsg403Fee - , errMsg403InputsDepleted , errMsg403NoPendingAnymore , errMsg403NotEnoughMoney_ - , errMsg403UTxO , errMsg403WrongPass , errMsg404CannotFindTx , errMsg404NoWallet @@ -146,12 +144,9 @@ spec = describe "BYRON_TXS_CLI" $ do , fixtureRandomWalletAddrs @n ] - scenario_TRANS_CREATE_02x @n - -- TRANS_CREATE_03 requires actually being able to compute exact fees, which -- is not really possible w/ cardano-node. So, skipping. - scenario_TRANS_CREATE_04a @n scenario_TRANS_CREATE_04b @n scenario_TRANS_CREATE_04c @n scenario_TRANS_CREATE_04d @n @@ -167,7 +162,6 @@ spec = describe "BYRON_TXS_CLI" $ do , icarusAddresses @n . entropyToMnemonic <$> genEntropy ] - scenario_TRANS_ESTIMATE_04a @n scenario_TRANS_ESTIMATE_04b @n scenario_TRANS_ESTIMATE_04c @n @@ -613,53 +607,6 @@ scenario_TRANS_ESTIMATE_01_02 fixtureSource fixtures = it title $ \ctx -> do where title = "CLI_TRANS_ESTIMATE_01/02 - " ++ show (length fixtures) ++ " recipient(s)" -scenario_TRANS_CREATE_02x - :: forall (n :: NetworkDiscriminant) t. - ( DecodeAddress n - , EncodeAddress n - , PaymentAddress n ByronKey - , KnownCommand t - ) - => SpecWith (Context t) -scenario_TRANS_CREATE_02x = it title $ \ctx -> do - -- SETUP - (wSrc, payments) <- fixtureSingleUTxO @n ctx - - -- ACTION - let args = T.unpack <$> ((wSrc ^. walletId) : payments) - (c, out, err) <- postTransactionViaCLI @t ctx (T.unpack fixturePassphrase) args - - -- ASSERTIONS - T.unpack err `shouldContain` errMsg403UTxO - c `shouldBe` ExitFailure 1 - out `shouldBe` mempty - - where - title = "CLI_TRANS_CREATE_02x - Multi-output failure w/ single UTxO" - -scenario_TRANS_CREATE_04a - :: forall (n :: NetworkDiscriminant) t. - ( DecodeAddress n - , EncodeAddress n - , PaymentAddress n ByronKey - , KnownCommand t - ) - => SpecWith (Context t) -scenario_TRANS_CREATE_04a = it title $ \ctx -> do - -- SETUP - (wSrc, payments) <- fixtureErrInputsDepleted @n ctx - - -- ACTION - let args = T.unpack <$> ((wSrc ^. walletId) : payments) - (c, out, err) <- postTransactionViaCLI @t ctx (T.unpack fixturePassphrase) args - - -- ASSERTIONS - T.unpack err `shouldContain` errMsg403InputsDepleted - c `shouldBe` ExitFailure 1 - out `shouldBe` mempty - where - title = "CLI_TRANS_CREATE_04 - Error shown when ErrInputsDepleted encountered" - scenario_TRANS_CREATE_04b :: forall (n :: NetworkDiscriminant) t. ( DecodeAddress n @@ -729,29 +676,6 @@ scenario_TRANS_CREATE_04d = it title $ \ctx -> do where title = "CLI_TRANS_CREATE_04 - Wrong password" -scenario_TRANS_ESTIMATE_04a - :: forall (n :: NetworkDiscriminant) t. - ( DecodeAddress n - , EncodeAddress n - , PaymentAddress n ByronKey - , KnownCommand t - ) - => SpecWith (Context t) -scenario_TRANS_ESTIMATE_04a = it title $ \ctx -> do - -- SETUP - (wSrc, payments) <- fixtureErrInputsDepleted @n ctx - - -- ACTION - let args = T.unpack <$> ((wSrc ^. walletId) : payments) - (Exit c, Stdout out, Stderr err) <- postTransactionFeeViaCLI @t ctx args - - -- ASSERTIONS - err `shouldContain` errMsg403InputsDepleted - c `shouldBe` ExitFailure 1 - out `shouldBe` mempty - where - title = "CLI_TRANS_ESTIMATE_04 - Error shown when ErrInputsDepleted encountered" - scenario_TRANS_ESTIMATE_04b :: forall (n :: NetworkDiscriminant) t. ( DecodeAddress n @@ -835,47 +759,6 @@ scenario_TRANS_CREATE_07 = it title $ \ctx -> do -- More Elaborated Fixtures -- --- | Returns a source wallet and a list of payments. --- --- NOTE: Random or Icarus wallets can be used interchangeably here. -fixtureSingleUTxO - :: forall (n :: NetworkDiscriminant) t. - ( DecodeAddress n - , EncodeAddress n - , PaymentAddress n ByronKey - ) - => Context t - -> IO (ApiByronWallet, [Text]) -fixtureSingleUTxO ctx = do - wSrc <- fixtureRandomWalletWith @n ctx [1_000_000] - addrs <- randomAddresses @n . entropyToMnemonic <$> genEntropy - let addrStr = encodeAddress @n (head addrs) - let payments = - [ "--payment", "100000@" <> addrStr - , "--payment", "100000@" <> addrStr - ] - pure (wSrc, payments) - --- | Returns a source wallet and a list of payments. If submitted, the payments --- should result in an error 403. --- --- NOTE: Random or Icarus wallets can be used interchangeably here. -fixtureErrInputsDepleted - :: forall (n :: NetworkDiscriminant) t. - ( DecodeAddress n - , EncodeAddress n - , PaymentAddress n ByronKey - ) - => Context t - -> IO (ApiByronWallet, [Text]) -fixtureErrInputsDepleted ctx = do - wSrc <- fixtureRandomWalletWith @n ctx [12_000_000, 20_000_000, 17_000_000] - addrs <- randomAddresses @n . entropyToMnemonic <$> genEntropy - -- let addrStrs = encodeAddress @n <$> (addrs) - let amnts = [40_000_000, 22, 22] :: [Natural] - let payments = flip map (zip addrs amnts) $ uncurry (mkPaymentCmd @n) - pure (wSrc, join payments) - -- | Returns a source wallet and a list of payments. -- -- NOTE: Random or Icarus wallets can be used interchangeably here. diff --git a/lib/byron/test/unit/Cardano/Wallet/Byron/TransactionSpec.hs b/lib/byron/test/unit/Cardano/Wallet/Byron/TransactionSpec.hs index e730e2db88b..1f069bd9279 100644 --- a/lib/byron/test/unit/Cardano/Wallet/Byron/TransactionSpec.hs +++ b/lib/byron/test/unit/Cardano/Wallet/Byron/TransactionSpec.hs @@ -390,7 +390,7 @@ genSelection = do genSelectionFor :: NonEmpty TxOut -> Gen CoinSelection genSelectionFor outs = do utxo <- vectorOf (NE.length outs * 3) genCoin >>= genUTxO @n @k - case runIdentity $ runExceptT $ largestFirst opts outs utxo of + case runIdentity $ runExceptT $ largestFirst opts outs (Quantity 0) utxo of Left _ -> genSelectionFor outs Right (s,_) -> return s diff --git a/lib/core-integration/src/Test/Integration/Framework/TestData.hs b/lib/core-integration/src/Test/Integration/Framework/TestData.hs index a262269f4d4..0df15da3bc6 100644 --- a/lib/core-integration/src/Test/Integration/Framework/TestData.hs +++ b/lib/core-integration/src/Test/Integration/Framework/TestData.hs @@ -49,7 +49,6 @@ module Test.Integration.Framework.TestData , errMsg403NotAByronWallet , errMsg403NotEnoughMoney , errMsg403NotEnoughMoney_ - , errMsg403UTxO , errMsg403WrongPass , errMsg403NoPendingAnymore , errMsg404NoSuchPool @@ -285,8 +284,9 @@ errMsg403NotAByronWallet = errMsg403NotEnoughMoney_ :: String errMsg403NotEnoughMoney_ = - "I can't process this payment because there's \ - \not enough UTxO available in the wallet." + "I cannot select enough UTxO from your wallet to construct an adequate \ + \transaction. Try sending a smaller amount or increasing the number of \ + \available UTxO." errMsg403NotEnoughMoney :: Int -> Int -> String errMsg403NotEnoughMoney has needs = "I can't process this payment because there's\ @@ -332,11 +332,6 @@ _errMsg403InpsOrOutsExceeded (maxNumInps, maxNumOuts) = \ more than " ++ show maxNumInps ++ " or the number of outputs\ \ exceeds " ++ show maxNumOuts ++ "." -errMsg403UTxO :: String -errMsg403UTxO = "When creating new transactions, I'm not able to re-use the\ - \ same UTxO for different outputs. Here, I only have 1\ - \ available, but there are 2 outputs." - errMsg403WrongPass :: String errMsg403WrongPass = "The given encryption passphrase doesn't match the one\ \ I use to encrypt the root private key of the given wallet" diff --git a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Transactions.hs b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Transactions.hs index caca33e0120..c58a9dc5b68 100644 --- a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Transactions.hs +++ b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Transactions.hs @@ -100,7 +100,6 @@ import Test.Integration.Framework.TestData , errMsg403InputsDepleted , errMsg403NoPendingAnymore , errMsg403NotEnoughMoney - , errMsg403UTxO , errMsg403WrongPass , errMsg404CannotFindTx , errMsg404NoWallet @@ -303,40 +302,6 @@ spec = do (`shouldBe` Quantity (2*amt)) ] - it "TRANS_CREATE_02 - Multiple Output Txs don't work on single UTxO" $ \ctx -> do - wSrc <- fixtureWalletWith @n ctx [2_124_333] - wDest <- emptyWallet ctx - addrs <- listAddresses @n ctx wDest - - let destination1 = (addrs !! 1) ^. #id - let destination2 = (addrs !! 2) ^. #id - let payload = Json [json|{ - "payments": [ - { - "address": #{destination1}, - "amount": { - "quantity": 1, - "unit": "lovelace" - } - }, - { - "address": #{destination2}, - "amount": { - "quantity": 1, - "unit": "lovelace" - } - } - ], - "passphrase": "Secure Passphrase" - }|] - - r <- request @(ApiTransaction n) ctx - (Link.createTransaction @'Shelley wSrc) Default payload - verify r - [ expectResponseCode HTTP.status403 - , expectErrorMessage errMsg403UTxO - ] - it "TRANS_CREATE_03 - 0 balance after transaction" $ \ctx -> do let (feeMin, _) = ctx ^. #_feeEstimator $ PaymentDescription 1 1 0 let amt = 1 @@ -643,39 +608,6 @@ spec = do between (feeMin - (2*amt), feeMax + (2*amt)) ] - it "TRANS_ESTIMATE_02 - Multiple Output Fee Estimation don't work on single UTxO" $ \ctx -> do - wSrc <- fixtureWalletWith @n ctx [2_124_333] - wDest <- emptyWallet ctx - addrs <- listAddresses @n ctx wDest - - let destination1 = (addrs !! 1) ^. #id - let destination2 = (addrs !! 2) ^. #id - let payload = Json [json|{ - "payments": [ - { - "address": #{destination1}, - "amount": { - "quantity": 1, - "unit": "lovelace" - } - }, - { - "address": #{destination2}, - "amount": { - "quantity": 1, - "unit": "lovelace" - } - } - ] - }|] - - r <- request @ApiFee ctx - (Link.getTransactionFee @'Shelley wSrc) Default payload - verify r - [ expectResponseCode HTTP.status403 - , expectErrorMessage errMsg403UTxO - ] - it "TRANS_ESTIMATE_03 - we see result when we can't cover fee" $ \ctx -> do let (feeMin, feeMax) = ctx ^. #_feeEstimator $ PaymentDescription 1 1 0 wSrc <- fixtureWalletWith @n ctx [feeMin `div` 2] diff --git a/lib/core-integration/src/Test/Integration/Scenario/CLI/Shelley/Transactions.hs b/lib/core-integration/src/Test/Integration/Scenario/CLI/Shelley/Transactions.hs index 93932735734..5b1496cc2e2 100644 --- a/lib/core-integration/src/Test/Integration/Scenario/CLI/Shelley/Transactions.hs +++ b/lib/core-integration/src/Test/Integration/Scenario/CLI/Shelley/Transactions.hs @@ -87,7 +87,6 @@ import Test.Integration.Framework.TestData , errMsg403InputsDepleted , errMsg403NoPendingAnymore , errMsg403NotEnoughMoney - , errMsg403UTxO , errMsg403WrongPass , errMsg404CannotFindTx , errMsg404NoWallet @@ -194,24 +193,6 @@ spec = do (#balance . #getApiT . #total) (`shouldBe` Quantity (2*amt)) ] - it "TRANS_CREATE_02 - Multiple Output Txs don't work on single UTxO" $ \ctx -> do - wSrc <- fixtureWalletWith @n ctx [2_124_333] - wDest <- emptyWallet ctx - addrs <- listAddresses @n ctx wDest - - let addr1 = encodeAddress @n (getApiT $ fst $ addrs !! 1 ^. #id) - let addr2 = encodeAddress @n (getApiT $ fst $ addrs !! 2 ^. #id) - let args = T.unpack <$> - [ wSrc ^. walletId - , "--payment", "12333@" <> addr1 - , "--payment", "4666@" <> addr2 - ] - - (c, out, err) <- postTransactionViaCLI @t ctx "cardano-wallet" args - (T.unpack err) `shouldContain` errMsg403UTxO - out `shouldBe` "" - c `shouldBe` ExitFailure 1 - it "TRANS_CREATE_03 - 0 balance after transaction" $ \ctx -> do let (feeMin, _) = ctx ^. #_feeEstimator $ PaymentDescription 1 1 0 let amt = 1 @@ -487,23 +468,6 @@ spec = do ] c `shouldBe` ExitSuccess - it "TRANS_ESTIMATE_04 - Multiple Output Txs fees estimation doesn't work on single UTxO" $ \ctx -> do - wSrc <- fixtureWalletWith @n ctx [2_124_333] - wDest <- emptyWallet ctx - addrs <- listAddresses @n ctx wDest - - let addr1 = encodeAddress @n (getApiT $ fst $ addrs !! 1 ^. #id) - let addr2 = encodeAddress @n (getApiT $ fst $ addrs !! 2 ^. #id) - let args = T.unpack <$> - [ wSrc ^. walletId - , "--payment", "12333@" <> addr1 - , "--payment", "4666@" <> addr2 - ] - (Exit c, Stdout out, Stderr err) <- postTransactionFeeViaCLI @t ctx args - err `shouldContain` errMsg403UTxO - out `shouldBe` "" - c `shouldBe` ExitFailure 1 - it "TRANS_ESTIMATE_05 - Error shown when ErrInputsDepleted encountered" $ \ctx -> do wSrc <- fixtureWalletWith @n ctx [12_000_000, 20_000_000, 17_000_000] wDest <- emptyWallet ctx diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index 8efb602fc47..a72070e8dd7 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -1178,15 +1178,15 @@ selectCoinsForPaymentFromUTxO -> NonEmpty TxOut -> Quantity "lovelace" Word64 -> ExceptT (ErrSelectForPayment e) IO CoinSelection -selectCoinsForPaymentFromUTxO ctx utxo txp recipients (Quantity withdrawal) = do +selectCoinsForPaymentFromUTxO ctx utxo txp recipients withdrawal = do lift . traceWith tr $ MsgPaymentCoinSelectionStart utxo txp recipients (sel, utxo') <- withExceptT ErrSelectForPaymentCoinSelection $ do let opts = coinSelOpts tl (txp ^. #getTxMaxSize) - CoinSelection.random opts recipients utxo + CoinSelection.random opts recipients withdrawal utxo lift . traceWith tr $ MsgPaymentCoinSelection sel let feePolicy = feeOpts tl Nothing (txp ^. #getFeePolicy) withExceptT ErrSelectForPaymentFee $ do - balancedSel <- adjustForFee feePolicy utxo' (sel { withdrawal }) + balancedSel <- adjustForFee feePolicy utxo' sel lift . traceWith tr $ MsgPaymentCoinSelectionAdjusted balancedSel pure balancedSel where diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index 685530b59e8..11e371c983d 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -1862,13 +1862,6 @@ instance Buildable e => LiftHandler (ErrCoinSelection e) where , " Lovelace (excluding fee amount) in order to proceed " , " with the payment." ] - ErrUtxoNotEnoughFragmented nUtxo nOuts -> - apiError err403 UtxoNotEnoughFragmented $ mconcat - [ "When creating new transactions, I'm not able to re-use " - , "the same UTxO for different outputs. Here, I only have " - , showT nUtxo, " available, but there are ", showT nOuts - , " outputs." - ] ErrMaximumInputsReached n -> apiError err403 TransactionIsTooBig $ mconcat [ "I had to select ", showT n, " inputs to construct the " @@ -1878,10 +1871,9 @@ instance Buildable e => LiftHandler (ErrCoinSelection e) where ] ErrInputsDepleted -> apiError err403 InputsDepleted $ mconcat - [ "I had to select inputs to construct the " - , "requested transaction. Unfortunately, one output of the " - , "transaction depleted all available inputs. " - , "Try sending a smaller amount." + [ "I cannot select enough UTxO from your wallet to construct " + , "an adequate transaction. Try sending a smaller amount or " + , "increasing the number of available UTxO." ] ErrInvalidSelection e -> apiError err403 InvalidCoinSelection $ pretty e diff --git a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection.hs b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection.hs index 0603445c7fa..6b5ab2eb18b 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection.hs @@ -20,6 +20,7 @@ module Cardano.Wallet.Primitive.CoinSelection , outputBalance , changeBalance , feeBalance + , totalBalance , ErrCoinSelection (..) , CoinSelectionOptions (..) ) where @@ -27,9 +28,11 @@ module Cardano.Wallet.Primitive.CoinSelection import Prelude import Cardano.Wallet.Primitive.Types - ( Coin (..), TxIn, TxOut (..) ) + ( Coin (..), TxIn, TxOut (..), balance' ) import Data.List ( foldl' ) +import Data.Quantity + ( Quantity (..) ) import Data.Word ( Word64, Word8 ) import Fmt @@ -117,6 +120,10 @@ changeBalance = foldl' addCoin 0 . change feeBalance :: CoinSelection -> Word64 feeBalance sel = inputBalance sel - outputBalance sel - changeBalance sel +-- | Total UTxO balance + withdrawal. +totalBalance :: Quantity "lovelace" Word64 -> [(TxIn, TxOut)] -> Word64 +totalBalance (Quantity withdraw) inps = balance' inps + withdraw + addTxOut :: Integral a => a -> TxOut -> a addTxOut total = addCoin total . coin @@ -128,10 +135,6 @@ data ErrCoinSelection e -- ^ UTxO exhausted during input selection -- We record the balance of the UTxO as well as the size of the payment -- we tried to make. - | ErrUtxoNotEnoughFragmented Word64 Word64 - -- ^ UTxO is not enough fragmented for the number of transaction outputs - -- We record the number of UTxO entries as well as the number of the - -- outputs of the transaction. | ErrMaximumInputsReached Word64 -- ^ When trying to construct a transaction, the max number of allowed -- inputs was reached. diff --git a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/LargestFirst.hs b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/LargestFirst.hs index 9dd1c033415..9d3d42b774c 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/LargestFirst.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/LargestFirst.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} @@ -16,13 +18,17 @@ module Cardano.Wallet.Primitive.CoinSelection.LargestFirst ( import Prelude import Cardano.Wallet.Primitive.CoinSelection - ( CoinSelection (..), CoinSelectionOptions (..), ErrCoinSelection (..) ) + ( CoinSelection (..) + , CoinSelectionOptions (..) + , ErrCoinSelection (..) + , totalBalance + ) import Cardano.Wallet.Primitive.Types - ( Coin (..), TxIn, TxOut (..), UTxO (..), balance ) + ( Coin (..), TxIn, TxOut (..), UTxO (..) ) import Control.Arrow ( left ) import Control.Monad - ( foldM, when ) + ( when ) import Control.Monad.Trans.Except ( ExceptT (..), except, throwE ) import Data.Functor @@ -31,71 +37,75 @@ import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Ord ( Down (..) ) +import Data.Quantity + ( Quantity (..) ) +import Data.Word + ( Word64 ) import qualified Data.List as L import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map - -- | Largest-first input selection policy largestFirst :: forall m e. Monad m => CoinSelectionOptions e -> NonEmpty TxOut + -> Quantity "lovelace" Word64 -> UTxO -> ExceptT (ErrCoinSelection e) m (CoinSelection, UTxO) -largestFirst opt outs utxo = do - let descending = L.sortOn (Down . coin) . NE.toList +largestFirst opt outs withdrawal utxo = do let nOuts = fromIntegral $ NE.length outs - let maxN = fromIntegral $ maximumNumberOfInputs opt (fromIntegral nOuts) + let maxN = fromIntegral $ maximumNumberOfInputs opt nOuts let nLargest = take maxN . L.sortOn (Down . coin . snd) . Map.toList . getUTxO let guard = except . left ErrInvalidSelection . validate opt - case foldM atLeast (nLargest utxo, mempty) (descending outs) of + case atLeast (nLargest utxo) withdrawal (NE.toList outs) of Just (utxo', s) -> guard s $> (s, UTxO $ Map.fromList utxo') Nothing -> do - let moneyRequested = sum $ (getCoin . coin) <$> (descending outs) - let utxoBalance = fromIntegral $ balance utxo + let moneyRequested = sum $ (getCoin . coin) <$> outs + let utxoList = Map.toList $ getUTxO utxo + let total = totalBalance withdrawal utxoList let nUtxo = fromIntegral $ Map.size $ getUTxO utxo - when (utxoBalance < moneyRequested) - $ throwE $ ErrNotEnoughMoney utxoBalance moneyRequested + when (null utxoList) + $ throwE ErrInputsDepleted - when (nUtxo < nOuts) - $ throwE $ ErrUtxoNotEnoughFragmented nUtxo nOuts + when (total < moneyRequested) + $ throwE $ ErrNotEnoughMoney total moneyRequested - when (fromIntegral maxN > nUtxo) + when (maxN > nUtxo) $ throwE ErrInputsDepleted throwE $ ErrMaximumInputsReached (fromIntegral maxN) -- Selecting coins to cover at least the specified value -- The details of the algorithm are following: --- (a) transaction outputs are processed starting from the largest one +-- +-- (a) transaction outputs are considered as a whole (sum of all outputs). +-- -- (b) `maximumNumberOfInputs` biggest available UTxO inputs are taken -- into consideration. They constitute a candidate UTxO inputs from --- which coin selection will be tried. Each output is treated independently --- with the heuristic described in (c). +-- which coin selection will be tried. +-- -- (c) the biggest candidate UTxO input is tried first to cover the transaction --- output. If the input is not enough, then the next biggest one is added --- to check if they can cover the transaction output. This process is continued --- until the output is covered or the candidates UTxO inputs are depleted. --- In the latter case `MaximumInputsReached` error is triggered. If the transaction --- output is covered the next biggest one is processed. Here, the biggest --- UTxO input, not participating in the coverage, is taken. We are back at (b) --- step as a result +-- total output. If the input is not enough, then the next biggest one is added +-- to check if they can cover the total. -- --- The steps are continued until all transaction are covered. +-- This process is continued until the total is covered or the candidates UTxO +-- inputs are depleted. In the latter case `MaximumInputsReached` error is +-- triggered. atLeast - :: ([(TxIn, TxOut)], CoinSelection) - -> TxOut + :: [(TxIn, TxOut)] + -> Quantity "lovelace" Word64 + -> [TxOut] -> Maybe ([(TxIn, TxOut)], CoinSelection) -atLeast (utxo0, selection) txout = - coverOutput (fromIntegral $ getCoin $ coin txout, mempty) utxo0 +atLeast utxo0 (Quantity withdrawal) outs = + coverOutput (toInteger $ sum $ getCoin . coin <$> outs, mempty) utxo0 where coverOutput :: (Integer, [(TxIn, TxOut)]) @@ -104,17 +114,25 @@ atLeast (utxo0, selection) txout = coverOutput (target, ins) utxo | target <= 0 = Just ( utxo - , selection <> mempty + , mempty { inputs = ins - , outputs = [txout] + , outputs = outs , change = filter (/= (Coin 0)) [Coin (fromIntegral $ abs target)] + , withdrawal } ) + | null utxo = Nothing + | otherwise = let (inp, out):utxo' = utxo - target' = target - (fromIntegral (getCoin (coin out))) + outAmount = getCoin (coin out) + -- NOTE: For the /first/ selected input, we also use the entire + -- withdrawal. If it's not enough, new inputs will be selected. + target' + | null ins = target - fromIntegral (outAmount + withdrawal) + | otherwise = target - fromIntegral outAmount in coverOutput (target', (inp, out):ins) utxo' diff --git a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs index 4e1b1eef00c..1ad9e1e5c1f 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} @@ -17,19 +19,15 @@ module Cardano.Wallet.Primitive.CoinSelection.Random import Prelude import Cardano.Wallet.Primitive.CoinSelection - ( CoinSelection (..), CoinSelectionOptions (..), ErrCoinSelection (..) ) + ( CoinSelection (..) + , CoinSelectionOptions (..) + , ErrCoinSelection (..) + , totalBalance + ) import Cardano.Wallet.Primitive.CoinSelection.LargestFirst ( largestFirst ) import Cardano.Wallet.Primitive.Types - ( Coin (..) - , TxIn - , TxOut (..) - , UTxO (..) - , balance' - , distance - , invariant - , pickRandom - ) + ( Coin (..), TxIn, TxOut (..), UTxO (..), distance, invariant, pickRandom ) import Control.Arrow ( left ) import Control.Monad @@ -48,6 +46,8 @@ import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Ord ( comparing ) +import Data.Quantity + ( Quantity (..) ) import Data.Word ( Word64 ) @@ -112,76 +112,110 @@ random :: forall m e. MonadRandom m => CoinSelectionOptions e -> NonEmpty TxOut + -> Quantity "lovelace" Word64 -> UTxO -> ExceptT (ErrCoinSelection e) m (CoinSelection, UTxO) -random opt outs utxo = do +random opt outs (Quantity withdrawal) utxo = do let descending = NE.toList . NE.sortBy (flip $ comparing coin) let nOuts = fromIntegral $ NE.length outs let maxN = fromIntegral $ maximumNumberOfInputs opt nOuts - randomMaybe <- lift $ runMaybeT $ - foldM makeSelection (maxN, utxo, []) (descending outs) + randomMaybe <- lift $ runMaybeT $ do + let initialState = SelectionState maxN utxo (Quantity withdrawal) [] + foldM makeSelection initialState (descending outs) case randomMaybe of - Just (maxN', utxo', res) -> do + Just (SelectionState maxN' utxo' _ res) -> do (_, sel, remUtxo) <- lift $ foldM improveTxOut (maxN', mempty, utxo') (reverse res) - guard sel $> (sel, remUtxo) + let result = sel { withdrawal } + guard result $> (result, remUtxo) Nothing -> - largestFirst opt outs utxo + largestFirst opt outs (Quantity withdrawal) utxo where guard = except . left ErrInvalidSelection . validate opt +-- A little type-alias to ease signature below +data SelectionState = SelectionState + { _maxN :: Word64 + , _utxo :: UTxO + , _withdrawal :: Quantity "lovelace" Word64 + , _selection :: [CoinSelection] + } deriving Show + -- | Perform a random selection on a given output, without improvement. makeSelection :: forall m. MonadRandom m - => (Word64, UTxO, [([(TxIn, TxOut)], TxOut)]) + => SelectionState -> TxOut - -> MaybeT m (Word64, UTxO, [([(TxIn, TxOut)], TxOut)]) -makeSelection (maxNumInputs, utxo0, selection) txout = do - (inps, utxo1) <- coverRandomly ([], utxo0) - return - ( maxNumInputs - fromIntegral (L.length inps) - , utxo1 - , (inps, txout) : selection - ) + -> MaybeT m SelectionState +makeSelection (SelectionState maxN utxo0 withdrawal0 selection0) txout = do + (selection', utxo') <- coverRandomly ([], utxo0) + return $ SelectionState + { _maxN = maxN - fromIntegral (L.length $ inputs selection') + , _utxo = utxo' + , _withdrawal = (\w -> w - withdrawal selection') <$> withdrawal0 + , _selection = selection' : selection0 + } where + TargetRange{targetMin} = mkTargetRange $ getCoin $ coin txout + coverRandomly :: forall m. MonadRandom m => ([(TxIn, TxOut)], UTxO) - -> MaybeT m ([(TxIn, TxOut)], UTxO) + -> MaybeT m (CoinSelection, UTxO) coverRandomly (inps, utxo) - | L.length inps > (fromIntegral maxNumInputs) = + | L.length inps > fromIntegral maxN = MaybeT $ return Nothing - | balance' inps >= targetMin (mkTargetRange txout) = - MaybeT $ return $ Just (inps, utxo) + | currentBalance >= targetMin = do + let remainder + | inputBalance >= targetMin = 0 + | otherwise = targetMin - inputBalance + MaybeT $ return $ Just + ( mempty + { inputs = inps + , outputs = [txout] + , withdrawal = min remainder (getQuantity withdrawal0) + } + , utxo + ) | otherwise = do pickRandomT utxo >>= \(io, utxo') -> coverRandomly (io:inps, utxo') + where + -- Withdrawal can only count towards the input balance if there's been + -- at least one selected input. + currentBalance + | null inps && null selection0 = inputBalance + | otherwise = totalBalance withdrawal0 inps + + inputBalance = + totalBalance (Quantity 0) inps -- | Perform an improvement to random selection on a given output. improveTxOut :: forall m. MonadRandom m => (Word64, CoinSelection, UTxO) - -> ([(TxIn, TxOut)], TxOut) + -> CoinSelection -> m (Word64, CoinSelection, UTxO) -improveTxOut (maxN0, selection, utxo0) (inps0, txout) = do +improveTxOut (maxN0, selection, utxo0) (CoinSelection inps0 withdraw _ outs _ _) = do (maxN, inps, utxo) <- improve (maxN0, inps0, utxo0) return ( maxN , selection <> mempty { inputs = inps - , outputs = [txout] - , change = mkChange txout inps + , outputs = outs + , change = mkChange (Quantity withdraw) outs inps + , withdrawal = withdraw } , utxo ) where - target = mkTargetRange txout + target = mkTargetRange $ sum $ getCoin . coin <$> outs improve :: forall m. MonadRandom m => (Word64, [(TxIn, TxOut)], UTxO) -> m (Word64, [(TxIn, TxOut)], UTxO) improve (maxN, inps, utxo) - | maxN >= 1 && balance' inps < targetAim target = do + | maxN >= 1 && totalBalance (Quantity withdraw) inps < targetAim target = do runMaybeT (pickRandomT utxo) >>= \case Nothing -> return (maxN, inps, utxo) @@ -197,13 +231,21 @@ improveTxOut (maxN0, selection, utxo0) (inps0, txout) = do isImprovement :: (TxIn, TxOut) -> [(TxIn, TxOut)] -> Bool isImprovement io selected = let + balanceWithExtraInput = + totalBalance (Quantity withdraw) (io : selected) + + balanceWithoutExtraInput = + totalBalance (Quantity withdraw) selected + condA = -- (a) It doesn’t exceed a specified upper limit. - balance' (io : selected) < targetMax target + balanceWithExtraInput + < + targetMax target condB = -- (b) Addition gets us closer to the ideal change - distance (targetAim target) (balance' (io : selected)) + distance (targetAim target) balanceWithExtraInput < - distance (targetAim target) (balance' selected) + distance (targetAim target) balanceWithoutExtraInput -- (c) Doesn't exceed maximum number of inputs -- Guaranteed by the precondition on 'improve'. @@ -220,23 +262,24 @@ pickRandomT = MaybeT . fmap (\(m,u) -> (,u) <$> m) . pickRandom -- | Compute the target range for a given output -mkTargetRange :: TxOut -> TargetRange -mkTargetRange (TxOut _ (Coin c)) = TargetRange - { targetMin = c - , targetAim = 2 * c - , targetMax = 3 * c +mkTargetRange :: Word64 -> TargetRange +mkTargetRange base = TargetRange + { targetMin = base + , targetAim = 2 * base + , targetMax = 3 * base } -- | Compute corresponding change outputs from a target output and a selection -- of inputs. -- -- > pre-condition: the output must be smaller (or eq) than the sum of inputs -mkChange :: TxOut -> [(TxIn, TxOut)] -> [Coin] -mkChange (TxOut _ (Coin out)) inps = +mkChange :: Quantity "lovelace" Word64 -> [TxOut] -> [(TxIn, TxOut)] -> [Coin] +mkChange withdraw outs inps = let + out = sum $ getCoin . coin <$> outs selected = invariant "mkChange: output is smaller than selected inputs!" - (balance' inps) + (totalBalance withdraw inps) (>= out) Coin maxCoinValue = maxBound in diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/LargestFirstSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/LargestFirstSpec.hs index f4e14322e65..58ebb4c2ead 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/LargestFirstSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/LargestFirstSpec.hs @@ -33,10 +33,12 @@ import Data.Functor.Identity ( Identity (runIdentity) ) import Data.List.NonEmpty ( NonEmpty (..) ) +import Data.Quantity + ( Quantity (..) ) import Test.Hspec ( Spec, describe, it, shouldSatisfy ) import Test.QuickCheck - ( Property, property, (===), (==>) ) + ( Property, expectFailure, property, (===), (==>) ) import qualified Data.List as L import qualified Data.List.NonEmpty as NE @@ -57,6 +59,7 @@ spec = do , validateSelection = noValidation , utxoInputs = [10,10,17] , txOutputs = 17 :| [] + , totalWithdrawal = 0 }) coinSelectionUnitTest largestFirst "" @@ -70,6 +73,7 @@ spec = do , validateSelection = noValidation , utxoInputs = [12,10,17] , txOutputs = 1 :| [] + , totalWithdrawal = 0 }) coinSelectionUnitTest largestFirst "" @@ -83,6 +87,7 @@ spec = do , validateSelection = noValidation , utxoInputs = [12,10,17] , txOutputs = 18 :| [] + , totalWithdrawal = 0 }) coinSelectionUnitTest largestFirst "" @@ -96,12 +101,13 @@ spec = do , validateSelection = noValidation , utxoInputs = [12,10,17] , txOutputs = 30 :| [] + , totalWithdrawal = 0 }) coinSelectionUnitTest largestFirst "" (Right $ CoinSelectionResult - { rsInputs = [6,10,5] - , rsChange = [5,4] + { rsInputs = [6,10] + , rsChange = [4] , rsOutputs = [11,1] }) (CoinSelectionFixture @@ -109,6 +115,45 @@ spec = do , validateSelection = noValidation , utxoInputs = [1,2,10,6,5] , txOutputs = 11 :| [1] + , totalWithdrawal = 0 + }) + + coinSelectionUnitTest largestFirst "with withdrawal" + (Right $ CoinSelectionResult + { rsInputs = [1] + , rsChange = [] + , rsOutputs = [100] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , validateSelection = noValidation + , utxoInputs = [1] + , txOutputs = 100 :| [] + , totalWithdrawal = 99 + }) + + coinSelectionUnitTest largestFirst "with withdrawal & change" + (Right $ CoinSelectionResult + { rsInputs = [30] + , rsChange = [40] + , rsOutputs = [40] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , validateSelection = noValidation + , utxoInputs = [10,30] + , txOutputs = 40 :| [] + , totalWithdrawal = 50 + }) + + coinSelectionUnitTest largestFirst "withdrawal requires at least one input" + (Left ErrInputsDepleted) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , validateSelection = noValidation + , utxoInputs = [] + , txOutputs = 1 :| [] + , totalWithdrawal = 10 }) coinSelectionUnitTest largestFirst "not enough coins" @@ -118,45 +163,46 @@ spec = do , validateSelection = noValidation , utxoInputs = [12,10,17] , txOutputs = 40 :| [] + , totalWithdrawal = 0 }) - coinSelectionUnitTest largestFirst "not enough coin & not fragmented enough" + coinSelectionUnitTest largestFirst "not enough coin & fragmentation doesn't matter" (Left $ ErrNotEnoughMoney 39 43) (CoinSelectionFixture { maxNumOfInputs = 100 , validateSelection = noValidation , utxoInputs = [12,10,17] , txOutputs = 40 :| [1,1,1] + , totalWithdrawal = 0 }) - coinSelectionUnitTest largestFirst "enough coins, but not fragmented enough" - (Left $ ErrUtxoNotEnoughFragmented 3 4) + coinSelectionUnitTest largestFirst "enough coins, fragmentation doesn't matter" + (Right $ CoinSelectionResult + { rsInputs = [12,17,20] + , rsChange = [6] + , rsOutputs = [40,1,1,1] + }) (CoinSelectionFixture { maxNumOfInputs = 100 , validateSelection = noValidation , utxoInputs = [12,20,17] , txOutputs = 40 :| [1,1,1] + , totalWithdrawal = 0 }) coinSelectionUnitTest largestFirst - "enough coins, fragmented enough, but one output depletes all inputs" - (Left ErrInputsDepleted) + "enough coins, one output does not deplete all inputs" + (Right $ CoinSelectionResult + { rsInputs = [12,17,20] + , rsChange = [8] + , rsOutputs = [40,1] + }) (CoinSelectionFixture { maxNumOfInputs = 100 , validateSelection = noValidation , utxoInputs = [12,20,17] , txOutputs = 40 :| [1] - }) - - coinSelectionUnitTest - largestFirst - "enough coins, fragmented enough, but the input needed to stay for the next output is depleted" - (Left ErrInputsDepleted) - (CoinSelectionFixture - { maxNumOfInputs = 100 - , validateSelection = noValidation - , utxoInputs = [20,20,10,5] - , txOutputs = 41 :| [6] + , totalWithdrawal = 0 }) coinSelectionUnitTest largestFirst "each output needs maxNumInputs" @@ -175,16 +222,7 @@ spec = do , validateSelection = noValidation , utxoInputs = replicate 100 1 , txOutputs = NE.fromList (replicate 10 10) - }) - - coinSelectionUnitTest largestFirst - "enough coins but, strict maximumNumberOfInputs" - (Left $ ErrMaximumInputsReached 2) - (CoinSelectionFixture - { maxNumOfInputs = 2 - , validateSelection = noValidation - , utxoInputs = [1,2,10,6,5] - , txOutputs = 11 :| [1] + , totalWithdrawal = 0 }) coinSelectionUnitTest largestFirst "custom validation" @@ -194,15 +232,16 @@ spec = do , validateSelection = alwaysFail , utxoInputs = [1,1] , txOutputs = 2 :| [] + , totalWithdrawal = 0 }) describe "Coin selection properties : LargestFirst algorithm" $ do it "forall (UTxO, NonEmpty TxOut), running algorithm twice yields \ \exactly the same result" (property propDeterministic) - it "forall (UTxO, NonEmpty TxOut), there's at least as many selected \ - \inputs as there are requested outputs" - (property propAtLeast) + it "There exists (UTxO, NonEmpty TxOut) for which at there are less \ + \inputs selected than there are requested outputs" + (expectFailure $ property propAtLeast) it "forall (UTxO, NonEmpty TxOut), for all selected input, there's no \ \bigger input in the UTxO that is not already in the selected inputs" (property propInputDecreasingOrder) @@ -216,8 +255,9 @@ propDeterministic -> Property propDeterministic (CoinSelProp utxo txOuts) = do let opts = CoinSelectionOptions (const 100) noValidation - let resultOne = runIdentity $ runExceptT $ largestFirst opts txOuts utxo - let resultTwo = runIdentity $ runExceptT $ largestFirst opts txOuts utxo + let withdraw = Quantity 0 + let resultOne = runIdentity $ runExceptT $ largestFirst opts txOuts withdraw utxo + let resultTwo = runIdentity $ runExceptT $ largestFirst opts txOuts withdraw utxo resultOne === resultTwo propAtLeast @@ -228,8 +268,9 @@ propAtLeast (CoinSelProp utxo txOuts) = where prop cs = L.length (inputs cs) `shouldSatisfy` (>= NE.length txOuts) - selection = runIdentity $ runExceptT $ - largestFirst (CoinSelectionOptions (const 100) noValidation) txOuts utxo + selection = runIdentity $ runExceptT $ do + let opts = CoinSelectionOptions (const 100) noValidation + largestFirst opts txOuts (Quantity 0) utxo propInputDecreasingOrder :: CoinSelProp @@ -246,5 +287,6 @@ propInputDecreasingOrder (CoinSelProp utxo txOuts) = `shouldSatisfy` (>= (getExtremumValue L.maximum utxo')) getExtremumValue f = f . map (getCoin . coin . snd) - selection = runIdentity $ runExceptT $ - largestFirst (CoinSelectionOptions (const 100) noValidation) txOuts utxo + selection = runIdentity $ runExceptT $ do + let opts = CoinSelectionOptions (const 100) noValidation + largestFirst opts txOuts (Quantity 0) utxo diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs index 6f817b58e8e..509035158db 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs @@ -35,6 +35,8 @@ import Data.Functor.Identity ( Identity (..) ) import Data.List.NonEmpty ( NonEmpty (..) ) +import Data.Quantity + ( Quantity (..) ) import Test.Hspec ( Spec, before, describe, it, shouldSatisfy ) import Test.QuickCheck @@ -59,6 +61,7 @@ spec = do , validateSelection = noValidation , utxoInputs = [1,1,1,1,1,1] , txOutputs = 2 :| [] + , totalWithdrawal = 0 }) coinSelectionUnitTest random "" @@ -72,6 +75,7 @@ spec = do , validateSelection = noValidation , utxoInputs = [1,1,1,1,1,1] , txOutputs = 2 :| [1] + , totalWithdrawal = 0 }) coinSelectionUnitTest random "" @@ -85,6 +89,7 @@ spec = do , validateSelection = noValidation , utxoInputs = [1,1,1,1,1] , txOutputs = 2 :| [1] + , totalWithdrawal = 0 }) coinSelectionUnitTest random "" @@ -98,6 +103,7 @@ spec = do , validateSelection = noValidation , utxoInputs = [1,1,1,1] , txOutputs = 2 :| [1] + , totalWithdrawal = 0 }) coinSelectionUnitTest random "" @@ -111,6 +117,7 @@ spec = do , validateSelection = noValidation , utxoInputs = [5,5,5] , txOutputs = 2 :| [] + , totalWithdrawal = 0 }) coinSelectionUnitTest random "" @@ -125,6 +132,7 @@ spec = do , validateSelection = noValidation , utxoInputs = [10,10,10] , txOutputs = 2 :| [2] + , totalWithdrawal = 0 }) coinSelectionUnitTest random "cannot cover aim, but only min" @@ -138,6 +146,7 @@ spec = do , validateSelection = noValidation , utxoInputs = [1,1,1,1,1,1] , txOutputs = 3 :| [] + , totalWithdrawal = 0 }) coinSelectionUnitTest random "REG CO-450: no fallback" @@ -151,15 +160,114 @@ spec = do , validateSelection = noValidation , utxoInputs = [oneAda, oneAda, oneAda, oneAda] , txOutputs = 2*oneAda :| [oneAda `div` 2] + , totalWithdrawal = 0 }) - coinSelectionUnitTest random "enough funds, proper fragmentation, inputs depleted" + coinSelectionUnitTest random "withdrawal simple" + (Right $ CoinSelectionResult + { rsInputs = [1] + , rsChange = [] + , rsOutputs = [2] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , validateSelection = noValidation + , utxoInputs = [1] + , txOutputs = 2 :| [] + , totalWithdrawal = 1 + }) + + coinSelectionUnitTest random "withdrawal multi-output" + (Right $ CoinSelectionResult + { rsInputs = [1,1] + , rsChange = [] + , rsOutputs = [2,2] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , validateSelection = noValidation + , utxoInputs = [1,1] + , txOutputs = 2 :| [2] + , totalWithdrawal = 2 + }) + + coinSelectionUnitTest random "withdrawal cover next output, no improvement" + -- NOTE + -- There's no change because the withdrawal covers it all _just_ + -- perfectly, the exceeding withdrawal remains available as a + -- positive delta for fee balancing. + (Right $ CoinSelectionResult + { rsInputs = [1] + , rsChange = [] + , rsOutputs = [10, 10] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , validateSelection = noValidation + , utxoInputs = [1] + , txOutputs = 10 :| [10] + , totalWithdrawal = 20 + }) + + coinSelectionUnitTest random "withdrawal cover next, with input improvement" + -- NOTE + -- This one is tricky, but here's what's happening + -- + -- 1. A first input is selected + -- 2. Part of the withdrawal (5) is used to cover for the remainder + -- 3. Rest of the withdrawal (1) is used to cover the second output + -- 4. The first input selection is "improved", so another input is + -- picked (hence the change of roughly the same size) + -- 5. There are no more inputs available, so the second input can't + -- be improved. + -- + -- At the end, still remains 4 Lovelace that can be used in the fee + -- balancing. + (Right $ CoinSelectionResult + { rsInputs = [5,5] + , rsChange = [5] + , rsOutputs = [10, 1] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , validateSelection = noValidation + , utxoInputs = [5,5] + , txOutputs = 10 :| [1] + , totalWithdrawal = 10 + }) + + coinSelectionUnitTest random "withdrawal can cover many next outputs" + (Right $ CoinSelectionResult + { rsInputs = [1] + , rsChange = [] + , rsOutputs = [1,1,1,1,1,1] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , validateSelection = noValidation + , utxoInputs = [1] + , txOutputs = 1 :| [1,1,1,1,1] + , totalWithdrawal = 5 + }) + + coinSelectionUnitTest random "withdrawal requires at least one input" (Left ErrInputsDepleted) (CoinSelectionFixture { maxNumOfInputs = 100 , validateSelection = noValidation - , utxoInputs = [10,10,10,10] - , txOutputs = 38 :| [1] + , utxoInputs = [] + , txOutputs = 1 :| [] + , totalWithdrawal = 10 + }) + + coinSelectionUnitTest random "not enough funds, withdrawal correctly counted" + (Left $ ErrNotEnoughMoney 11 100) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , validateSelection = noValidation + , utxoInputs = [1] + , txOutputs = 100 :| [] + , totalWithdrawal = 10 }) coinSelectionUnitTest random "" @@ -169,6 +277,7 @@ spec = do , validateSelection = noValidation , utxoInputs = [1,1,1,1,1,1] , txOutputs = 3 :| [] + , totalWithdrawal = 0 }) coinSelectionUnitTest random "each output needs maxNumInputs" @@ -187,6 +297,7 @@ spec = do , validateSelection = noValidation , utxoInputs = replicate 100 1 , txOutputs = NE.fromList (replicate 10 10) + , totalWithdrawal = 0 }) coinSelectionUnitTest random "" @@ -196,6 +307,7 @@ spec = do , validateSelection = noValidation , utxoInputs = [12,10,17] , txOutputs = 40 :| [] + , totalWithdrawal = 0 }) coinSelectionUnitTest random "" @@ -205,15 +317,7 @@ spec = do , validateSelection = noValidation , utxoInputs = [12,10,17] , txOutputs = 40 :| [1,1,1] - }) - - coinSelectionUnitTest random "" - (Left $ ErrUtxoNotEnoughFragmented 3 4) - (CoinSelectionFixture - { maxNumOfInputs = 100 - , validateSelection = noValidation - , utxoInputs = [12,20,17] - , txOutputs = 40 :| [1,1,1] + , totalWithdrawal = 0 }) coinSelectionUnitTest random "custom validation" @@ -223,6 +327,7 @@ spec = do , validateSelection = alwaysFail , utxoInputs = [1,1] , txOutputs = 2 :| [] + , totalWithdrawal = 0 }) before getSystemDRG $ describe "Coin selection properties : random algorithm" $ do @@ -250,9 +355,9 @@ propFragmentation drg (CoinSelProp utxo txOuts) = do prop (cs1, cs2) = L.length (inputs cs1) `shouldSatisfy` (>= L.length (inputs cs2)) (selection1,_) = withDRG drg - (runExceptT $ random opt txOuts utxo) + (runExceptT $ random opt txOuts (Quantity 0) utxo) selection2 = runIdentity $ runExceptT $ - largestFirst opt txOuts utxo + largestFirst opt txOuts (Quantity 0) utxo opt = CoinSelectionOptions (const 100) noValidation propErrors @@ -267,7 +372,7 @@ propErrors drg (CoinSelProp utxo txOuts) = do prop (err1, err2) = err1 === err2 (selection1,_) = withDRG drg - (runExceptT $ random opt txOuts utxo) + (runExceptT $ random opt txOuts (Quantity 0) utxo) selection2 = runIdentity $ runExceptT $ - largestFirst opt txOuts utxo + largestFirst opt txOuts (Quantity 0) utxo opt = (CoinSelectionOptions (const 1) noValidation) diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs index 2ad174a834f..49d49a5ee03 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs @@ -45,6 +45,8 @@ import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Maybe ( catMaybes ) +import Data.Quantity + ( Quantity (..) ) import Data.Vector.Shuffle ( shuffle ) import Data.Word @@ -99,6 +101,7 @@ spec = do prop "All inputs are used" prop_allInputsAreUsed prop "All inputs are used per transaction" prop_allInputsAreUsedPerTx prop "Addresses are recycled fairly" prop_fairAddressesRecycled + where lowerConfidence :: Confidence lowerConfidence = Confidence (10^(6 :: Integer)) 0.75 @@ -243,6 +246,9 @@ data CoinSelectionFixture = CoinSelectionFixture -- ^ Value (in Lovelace) & number of available coins in the UTxO , txOutputs :: NonEmpty Word64 -- ^ Value (in Lovelace) & number of requested outputs + , totalWithdrawal :: Word64 + -- ^ Total withdrawal available for the selection. May be split across + -- outputs. } -- | A dummy error for testing extra validation @@ -263,11 +269,13 @@ data CoinSelectionResult = CoinSelectionResult , rsOutputs :: [Word64] } deriving (Eq, Show) + -- | Generate a 'UTxO' and 'TxOut' matching the given 'Fixture', and perform -- given coin selection on it. coinSelectionUnitTest :: ( CoinSelectionOptions ErrValidation -> NonEmpty TxOut + -> Quantity "lovelace" Word64 -> UTxO -> ExceptT (ErrCoinSelection ErrValidation) IO (CoinSelection, UTxO) ) @@ -275,11 +283,12 @@ coinSelectionUnitTest -> Either (ErrCoinSelection ErrValidation) CoinSelectionResult -> CoinSelectionFixture -> SpecWith () -coinSelectionUnitTest run lbl expected (CoinSelectionFixture n fn utxoF outsF) = +coinSelectionUnitTest run lbl expected (CoinSelectionFixture n fn utxoF outsF w) = it title $ do (utxo,txOuts) <- setup result <- runExceptT $ do - cs <- fst <$> run (CoinSelectionOptions (const n) fn) txOuts utxo + cs <- fst <$> run + (CoinSelectionOptions (const n) fn) txOuts (Quantity w) utxo return $ CoinSelectionResult { rsInputs = map (getCoin . coin . snd) (inputs cs) , rsChange = map getCoin (change cs) diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/FeeSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/FeeSpec.hs index 8972fcca750..e426f8df477 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/FeeSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/FeeSpec.hs @@ -57,6 +57,8 @@ import Data.Functor.Identity ( Identity (runIdentity) ) import Data.List.NonEmpty ( NonEmpty ) +import Data.Quantity + ( Quantity (..) ) import Data.Word ( Word64 ) import Fmt @@ -707,10 +709,10 @@ genSelectionFor :: NonEmpty TxOut -> Gen CoinSelection genSelectionFor outs = do let opts = CS.CoinSelectionOptions (const 100) (const $ pure ()) utxo <- vector (NE.length outs * 3) >>= genUTxO - case runIdentity $ runExceptT $ largestFirst opts outs utxo of + withdrawal_ <- genWithdrawal + case runIdentity $ runExceptT $ largestFirst opts outs (Quantity withdrawal_) utxo of Left _ -> genSelectionFor outs Right (s,_) -> do - withdrawal_ <- genWithdrawal reclaim_ <- genReclaim let s' = s { withdrawal = withdrawal_, reclaim = reclaim_ } deposit_ <- genDeposit (feeBalance s') diff --git a/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs b/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs index e5a187acb48..3e1a840d7e3 100644 --- a/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs +++ b/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs @@ -159,7 +159,7 @@ spec = do let selectCoins = flip catchE (handleCannotCover utxo recipients) $ do (sel, utxo') <- withExceptT ErrSelectForPaymentCoinSelection $ do - CS.random testCoinSelOpts recipients utxo + CS.random testCoinSelOpts recipients (Quantity 0) utxo withExceptT ErrSelectForPaymentFee $ (Fee . CS.feeBalance) <$> adjustForFee testFeeOpts utxo' sel res <- runExceptT $ estimateFeeForCoinSelection selectCoins