diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index d7e9200ed44..f80832ca262 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -481,6 +481,13 @@ instance LiftHandler ErrCoinSelection where , "transaction that is too big, and this would consequently " , "be rejected by a core node. Try sending a smaller amount." ] + 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." + ] instance LiftHandler ErrAdjustForFee where handler = \case diff --git a/lib/core/src/Cardano/Wallet/Api/Types.hs b/lib/core/src/Cardano/Wallet/Api/Types.hs index 9dc5802abd7..48a96a35f1f 100644 --- a/lib/core/src/Cardano/Wallet/Api/Types.hs +++ b/lib/core/src/Cardano/Wallet/Api/Types.hs @@ -194,6 +194,7 @@ data ApiErrorCode | NotEnoughMoney | UtxoNotEnoughFragmented | TransactionIsTooBig + | InputsDepleted | CannotCoverFee | NetworkUnreachable | CreatedInvalidTransaction diff --git a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection.hs b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection.hs index a37d3394d8f..42c28c328c6 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection.hs @@ -64,6 +64,9 @@ data ErrCoinSelection | ErrMaximumInputsReached Word64 -- ^ When trying to construct a transaction, the max number of allowed -- inputs was reached. + | ErrInputsDepleted + -- ^ When trying to construct a transaction, the available inputs are depleted + -- even when UTxO is properly fragmented and with enough funds to cover payment deriving (Show, Eq) data CoinSelection = CoinSelection diff --git a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/LargestFirst.hs b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/LargestFirst.hs index 8dbf7ff11bd..dbde55597b6 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/LargestFirst.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/LargestFirst.hs @@ -60,8 +60,10 @@ largestFirst opt outs utxo = do when (nUtxo < nOuts) $ throwE $ ErrUtxoNotEnoughFragmented nUtxo nOuts - throwE $ ErrMaximumInputsReached (fromIntegral n) + when (fromIntegral n > nUtxo) + $ throwE ErrInputsDepleted + throwE $ ErrMaximumInputsReached (fromIntegral n) -- Selecting coins to cover at least the specified value -- The details of the algorithm are following: diff --git a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs index 92a72010c89..6fff11fe31d 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs @@ -68,9 +68,13 @@ data TargetRange = TargetRange -- transaction inputs has been exceeded, fall back on the largest-first -- algorithm for this step.) -- --- 2. Randomly select outputs from the UTxO, considering for each output if that --- output is animprovement. If it is, add it to the transaction, and keep --- going. An output is considered an improvement when: +-- 2. The algorithm first makes a random selection for each output from the UTxO, +-- processing the biggest output first and proceeding in a descending order. +-- If the selection is not successful largest-first fallback kicks in. +-- If the selection is successful for each output then the +-- improvement is tried for each selection, once again starting from the selection +-- made for the biggest output. The improvement is tried for the next biggest output's +-- selection. An output is considered an improvement when: -- -- (a) It doesn’t exceed a specified upper limit. -- (b) Adding the new output gets us closer to the ideal change value. @@ -109,37 +113,32 @@ random random opt outs utxo = do let descending = NE.toList . NE.sortBy (flip $ comparing coin) randomMaybe <- lift $ runMaybeT $ foldM - (processTxOut opt) - (utxo, mempty) + (makeSelection opt) + (utxo, []) (descending outs) case randomMaybe of - Just (utxo', res) -> - return (res, utxo') + Just (utxo', res) -> do + lift $ foldM + (improveTxOut opt) + (mempty, utxo') + (reverse res) Nothing -> largestFirst opt outs utxo --- | Perform a random selection on a given output, with improvement. -processTxOut +-- | Perform a random selection on a given output, without improvement. +makeSelection :: forall m. MonadRandom m => CoinSelectionOptions - -> (UTxO, CoinSelection) + -> (UTxO, [([(TxIn, TxOut)], TxOut)]) -> TxOut - -> MaybeT m (UTxO, CoinSelection) -processTxOut (CoinSelectionOptions maxNumInputs) (utxo0, selection) txout = do - attempt <- coverRandomly ([], utxo0) - (inps, utxo') <- lift (improve attempt) + -> MaybeT m (UTxO, [([(TxIn, TxOut)], TxOut)]) +makeSelection (CoinSelectionOptions maxNumInputs) (utxo0, selection) txout = do + (inps, utxo1) <- coverRandomly ([], utxo0) return - ( utxo' - , selection <> CoinSelection - { inputs = inps - , outputs = [txout] - , change = mkChange txout inps - } + ( utxo1 + , (inps, txout) : selection ) where - target :: TargetRange - target = mkTargetRange txout - coverRandomly :: forall m. MonadRandom m => ([(TxIn, TxOut)], UTxO) @@ -147,26 +146,47 @@ processTxOut (CoinSelectionOptions maxNumInputs) (utxo0, selection) txout = do coverRandomly (inps, utxo) | L.length inps > (fromIntegral maxNumInputs) = MaybeT $ return Nothing - | balance' inps >= targetMin target = + | balance' inps >= targetMin (mkTargetRange txout) = MaybeT $ return $ Just (inps, utxo) | otherwise = do pickRandomT utxo >>= \(io, utxo') -> coverRandomly (io:inps, utxo') + +-- | Perform an improvement to random selection on a given output. +improveTxOut + :: forall m. MonadRandom m + => CoinSelectionOptions + -> (CoinSelection, UTxO) + -> ([(TxIn, TxOut)], TxOut) + -> m (CoinSelection, UTxO) +improveTxOut (CoinSelectionOptions maxNumInputs) (selection, utxo0) (inps0, txout) = do + (inps, utxo) <- improve (inps0, utxo0) + return + ( selection <> CoinSelection + { inputs = inps + , outputs = [txout] + , change = mkChange txout inps + } + , utxo + ) + where + target = mkTargetRange txout + improve :: forall m. MonadRandom m => ([(TxIn, TxOut)], UTxO) -> m ([(TxIn, TxOut)], UTxO) improve (inps, utxo) = runMaybeT (pickRandomT utxo) >>= \case - Nothing -> - return (inps, utxo) - Just (io, utxo') | isImprovement io inps -> do - let inps' = io : inps - if balance' inps' >= targetAim target - then return (inps', utxo') - else improve (inps', utxo') - Just _ -> - return (inps, utxo) + Nothing -> + return (inps, utxo) + Just (io, utxo') | isImprovement io inps -> do + let inps' = io : inps + if balance' inps' >= targetAim target + then return (inps', utxo') + else improve (inps', utxo') + Just _ -> + return (inps, utxo) isImprovement :: (TxIn, TxOut) -> [(TxIn, TxOut)] -> Bool isImprovement io selected = @@ -184,6 +204,7 @@ processTxOut (CoinSelectionOptions maxNumInputs) (utxo0, selection) txout = do in condA && condB && condC + {------------------------------------------------------------------------------- Internals -------------------------------------------------------------------------------} 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 a0c8777b9a2..00f4a6342ba 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/LargestFirstSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/LargestFirstSpec.hs @@ -133,6 +133,26 @@ spec = do , txOutputs = 40 :| [1,1,1] } + coinSelectionUnitTest + largestFirst + "enough coins, fragmented enough, but one output depletes all inputs" + (Left ErrInputsDepleted) + $ CoinSelectionFixture + { maxNumOfInputs = 100 + , 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 + , utxoInputs = [20,20,10,5] + , txOutputs = 41 :| [6] + } + coinSelectionUnitTest largestFirst "enough coins but, strict maximumNumberOfInputs" 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 48f419e74a1..7f382754b6f 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs @@ -42,7 +42,10 @@ import qualified Data.List as L spec :: Spec spec = do - describe "Unit tests" $ do + describe "Coin selection : random algorithm unit tests" $ do + + let oneAda = 1000000 + coinSelectionUnitTest random "" (Right $ CoinSelectionResult { rsInputs = [1,1,1,1] @@ -79,10 +82,10 @@ spec = do , txOutputs = 2 :| [1] }) - coinSelectionUnitTest random "with fallback" + coinSelectionUnitTest random "" (Right $ CoinSelectionResult - { rsInputs = [1,1,1] - , rsChange = [] + { rsInputs = [1,1,1,1] + , rsChange = [1] , rsOutputs = [2,1] }) (CoinSelectionFixture @@ -128,6 +131,26 @@ spec = do , txOutputs = 3 :| [] }) + coinSelectionUnitTest random "REG CO-450: no fallback" + (Right $ CoinSelectionResult + { rsInputs = [oneAda, oneAda, oneAda, oneAda] + , rsChange = [oneAda, oneAda `div` 2] + , rsOutputs = [2*oneAda,oneAda `div` 2] + }) + (CoinSelectionFixture + { maxNumOfInputs = 4 + , utxoInputs = [oneAda, oneAda, oneAda, oneAda] + , txOutputs = 2*oneAda :| [oneAda `div` 2] + }) + + coinSelectionUnitTest random "enough funds, proper fragmentation, inputs depleted" + (Left ErrInputsDepleted) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [10,10,10,10] + , txOutputs = 38 :| [1] + }) + coinSelectionUnitTest random "" (Left $ ErrMaximumInputsReached 2) $ CoinSelectionFixture { maxNumOfInputs = 2 @@ -156,7 +179,7 @@ spec = do , txOutputs = 40 :| [1,1,1] } - before getSystemDRG $ describe "Property Tests" $ do + before getSystemDRG $ describe "Coin selection properties : random algorithm" $ do it "forall (UTxO, NonEmpty TxOut), \ \ running algorithm gives not less UTxO fragmentation than LargestFirst algorithm" (property . propFragmentation) diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs index 2e600bb2699..d061ccd3916 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs @@ -74,7 +74,7 @@ import qualified Data.Map.Strict as Map spec :: Spec spec = do - describe "shuffle" $ do + describe "Coin selection properties : shuffle" $ do it "every non-empty list can be shuffled, ultimately" (checkCoverageWith lowerConfidence prop_shuffleCanShuffle) it "shuffle is non-deterministic"