From e11a6ec58a71619a15e738a3532af453f187c51a Mon Sep 17 00:00:00 2001 From: Pawel Jakubas Date: Sun, 30 Jun 2019 10:55:05 +0200 Subject: [PATCH 1/5] Add ErrInputsDepleted error with an illustrative test --- lib/core/src/Cardano/Wallet/Api/Server.hs | 7 +++++++ lib/core/src/Cardano/Wallet/Api/Types.hs | 1 + lib/core/src/Cardano/Wallet/Primitive/CoinSelection.hs | 3 +++ .../Wallet/Primitive/CoinSelection/LargestFirst.hs | 4 +++- .../Cardano/Wallet/Primitive/CoinSelection/Random.hs | 2 +- .../Wallet/Primitive/CoinSelection/LargestFirstSpec.hs | 10 ++++++++++ 6 files changed, 25 insertions(+), 2 deletions(-) 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..d024f77dc5d 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs @@ -69,7 +69,7 @@ data TargetRange = TargetRange -- 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 +-- output is an improvement. If it is, add it to the transaction, and keep -- going. An output is considered an improvement when: -- -- (a) It doesn’t exceed a specified upper limit. 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..4fbf85a7291 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,16 @@ 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 but, strict maximumNumberOfInputs" From ce66f7824b325d97334a8619e6899d9ac5f33552 Mon Sep 17 00:00:00 2001 From: Pawel Jakubas Date: Sun, 30 Jun 2019 12:37:05 +0200 Subject: [PATCH 2/5] improve on decription in coin selection to ameliorate better filtering when testing --- .../unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs | 4 ++-- .../test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) 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..53006eb40be 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,7 @@ import qualified Data.List as L spec :: Spec spec = do - describe "Unit tests" $ do + describe "Coin selection : random algorithm unit tests" $ do coinSelectionUnitTest random "" (Right $ CoinSelectionResult { rsInputs = [1,1,1,1] @@ -156,7 +156,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" From 75a3e28d3a66fd29b61426051682c5317334087a Mon Sep 17 00:00:00 2001 From: Pawel Jakubas Date: Sun, 30 Jun 2019 13:59:30 +0200 Subject: [PATCH 3/5] add boundary/regression unit tests --- .../CoinSelection/LargestFirstSpec.hs | 10 ++++++++ .../Primitive/CoinSelection/RandomSpec.hs | 23 +++++++++++++++++++ 2 files changed, 33 insertions(+) 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 4fbf85a7291..00f4a6342ba 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/LargestFirstSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/LargestFirstSpec.hs @@ -143,6 +143,16 @@ spec = do , 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 53006eb40be..381b899d452 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs @@ -43,6 +43,9 @@ import qualified Data.List as L spec :: Spec spec = do describe "Coin selection : random algorithm unit tests" $ do + + let oneAda = 1000000 + coinSelectionUnitTest random "" (Right $ CoinSelectionResult { rsInputs = [1,1,1,1] @@ -128,6 +131,26 @@ spec = do , txOutputs = 3 :| [] }) + coinSelectionUnitTest random "REG CO-450: fallback works correctly" + (Right $ CoinSelectionResult + { rsInputs = [1000000,1000000,1000000] + , rsChange = [500000] + , rsOutputs = [2000000,500000] + }) + (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 From 5814177d9bf5182d693bf02d4b21c0de3ab577fa Mon Sep 17 00:00:00 2001 From: Pawel Jakubas Date: Mon, 1 Jul 2019 12:20:09 +0200 Subject: [PATCH 4/5] implement new random hlint --- .../Wallet/Primitive/CoinSelection/Random.hs | 99 ++++++++++++------- .../Primitive/CoinSelection/RandomSpec.hs | 16 +-- 2 files changed, 69 insertions(+), 46 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs index d024f77dc5d..27854058991 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 an improvement. 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. @@ -106,40 +110,37 @@ random -> NonEmpty TxOut -> UTxO -> ExceptT ErrCoinSelection m (CoinSelection, UTxO) -random opt outs utxo = do +random opt outs utxo0 = do let descending = NE.toList . NE.sortBy (flip $ comparing coin) randomMaybe <- lift $ runMaybeT $ foldM - (processTxOut opt) - (utxo, mempty) + (makeSelection opt) + (utxo0, []) (descending outs) case randomMaybe of - Just (utxo', res) -> - return (res, utxo') + Just (utxo1, res) -> do + (utxo2, selection) <- + lift $ foldM + (improveTxOut opt) + (utxo1, mempty) + (reverse res) + return (selection, utxo2) Nothing -> - largestFirst opt outs utxo + largestFirst opt outs utxo0 --- | 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,43 +148,65 @@ 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 + -> (UTxO, CoinSelection) + -> ([(TxIn, TxOut)], TxOut) + -> m (UTxO, CoinSelection) +improveTxOut (CoinSelectionOptions maxNumInputs) (utxo0,selection) (inps0, txout) = do + (inps, utxo) <- improve (inps0, utxo0) + return + ( utxo + , selection <> CoinSelection + { inputs = inps + , outputs = [txout] + , change = mkChange txout inps + } + ) + where + theTarget = 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 theTarget + then return (inps', utxo') + else improve (inps', utxo') + Just _ -> + return (inps, utxo) isImprovement :: (TxIn, TxOut) -> [(TxIn, TxOut)] -> Bool isImprovement io selected = let condA = -- (a) It doesn’t exceed a specified upper limit. - balance' (io : selected) < targetMax target + balance' (io : selected) < targetMax theTarget condB = -- (b) Addition gets us closer to the ideal change - distance (targetAim target) (balance' (io : selected)) + distance (targetAim theTarget) (balance' (io : selected)) < - distance (targetAim target) (balance' selected) + distance (targetAim theTarget) (balance' selected) condC = -- (c) Doesn't exceed maximum number of inputs length (io : selected) <= fromIntegral maxNumInputs in condA && condB && condC + {------------------------------------------------------------------------------- Internals -------------------------------------------------------------------------------} 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 381b899d452..7f382754b6f 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs @@ -82,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 @@ -131,11 +131,11 @@ spec = do , txOutputs = 3 :| [] }) - coinSelectionUnitTest random "REG CO-450: fallback works correctly" + coinSelectionUnitTest random "REG CO-450: no fallback" (Right $ CoinSelectionResult - { rsInputs = [1000000,1000000,1000000] - , rsChange = [500000] - , rsOutputs = [2000000,500000] + { rsInputs = [oneAda, oneAda, oneAda, oneAda] + , rsChange = [oneAda, oneAda `div` 2] + , rsOutputs = [2*oneAda,oneAda `div` 2] }) (CoinSelectionFixture { maxNumOfInputs = 4 @@ -144,7 +144,7 @@ spec = do }) coinSelectionUnitTest random "enough funds, proper fragmentation, inputs depleted" - (Left ErrInputsDepleted) $ + (Left ErrInputsDepleted) (CoinSelectionFixture { maxNumOfInputs = 100 , utxoInputs = [10,10,10,10] From 40a428014f17401ce17f879b288ea8baebed8cf5 Mon Sep 17 00:00:00 2001 From: Pawel Jakubas Date: Mon, 1 Jul 2019 14:39:16 +0200 Subject: [PATCH 5/5] simplify things a bit --- .../Wallet/Primitive/CoinSelection/Random.hs | 34 +++++++++---------- 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs index 27854058991..6fff11fe31d 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs @@ -110,22 +110,20 @@ random -> NonEmpty TxOut -> UTxO -> ExceptT ErrCoinSelection m (CoinSelection, UTxO) -random opt outs utxo0 = do +random opt outs utxo = do let descending = NE.toList . NE.sortBy (flip $ comparing coin) randomMaybe <- lift $ runMaybeT $ foldM (makeSelection opt) - (utxo0, []) + (utxo, []) (descending outs) case randomMaybe of - Just (utxo1, res) -> do - (utxo2, selection) <- - lift $ foldM + Just (utxo', res) -> do + lift $ foldM (improveTxOut opt) - (utxo1, mempty) + (mempty, utxo') (reverse res) - return (selection, utxo2) Nothing -> - largestFirst opt outs utxo0 + largestFirst opt outs utxo -- | Perform a random selection on a given output, without improvement. makeSelection @@ -158,21 +156,21 @@ makeSelection (CoinSelectionOptions maxNumInputs) (utxo0, selection) txout = do improveTxOut :: forall m. MonadRandom m => CoinSelectionOptions - -> (UTxO, CoinSelection) + -> (CoinSelection, UTxO) -> ([(TxIn, TxOut)], TxOut) - -> m (UTxO, CoinSelection) -improveTxOut (CoinSelectionOptions maxNumInputs) (utxo0,selection) (inps0, txout) = do + -> m (CoinSelection, UTxO) +improveTxOut (CoinSelectionOptions maxNumInputs) (selection, utxo0) (inps0, txout) = do (inps, utxo) <- improve (inps0, utxo0) return - ( utxo - , selection <> CoinSelection + ( selection <> CoinSelection { inputs = inps , outputs = [txout] , change = mkChange txout inps } + , utxo ) where - theTarget = mkTargetRange txout + target = mkTargetRange txout improve :: forall m. MonadRandom m @@ -184,7 +182,7 @@ improveTxOut (CoinSelectionOptions maxNumInputs) (utxo0,selection) (inps0, txout return (inps, utxo) Just (io, utxo') | isImprovement io inps -> do let inps' = io : inps - if balance' inps' >= targetAim theTarget + if balance' inps' >= targetAim target then return (inps', utxo') else improve (inps', utxo') Just _ -> @@ -194,12 +192,12 @@ improveTxOut (CoinSelectionOptions maxNumInputs) (utxo0,selection) (inps0, txout isImprovement io selected = let condA = -- (a) It doesn’t exceed a specified upper limit. - balance' (io : selected) < targetMax theTarget + balance' (io : selected) < targetMax target condB = -- (b) Addition gets us closer to the ideal change - distance (targetAim theTarget) (balance' (io : selected)) + distance (targetAim target) (balance' (io : selected)) < - distance (targetAim theTarget) (balance' selected) + distance (targetAim target) (balance' selected) condC = -- (c) Doesn't exceed maximum number of inputs length (io : selected) <= fromIntegral maxNumInputs