Merge pull request #493 from input-output-hk/paweljakubas/461/defer-s…

…election-improvement

defer selection improvement in coin selection

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

lib/core/src/Cardano/Wallet/Api/Types.hs

@@ -194,6 +194,7 @@ data ApiErrorCode
     | NotEnoughMoney
     | UtxoNotEnoughFragmented
     | TransactionIsTooBig
+    | InputsDepleted
     | CannotCoverFee
     | NetworkUnreachable
     | CreatedInvalidTransaction

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

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:

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,64 +113,80 @@ 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)
         -> MaybeT m ([(TxIn, TxOut)], UTxO)
     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
 -------------------------------------------------------------------------------}

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"

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)

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"