diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index 10a68d4e263..bc018c36334 100644 --- a/cardano-wallet.cabal +++ b/cardano-wallet.cabal @@ -71,6 +71,7 @@ library Cardano.Wallet.Binary.Packfile Cardano.Wallet.CoinSelection Cardano.Wallet.CoinSelection.LargestFirst + Cardano.Wallet.CoinSelection.Random Cardano.Wallet.DB Cardano.Wallet.DB.MVar Cardano.Wallet.Network @@ -147,6 +148,7 @@ test-suite unit Cardano.Wallet.Binary.PackfileSpec Cardano.Wallet.CoinSelectionSpec Cardano.Wallet.CoinSelection.LargestFirstSpec + Cardano.Wallet.CoinSelection.RandomSpec Cardano.Wallet.DBSpec Cardano.Wallet.DB.MVarSpec Cardano.Wallet.NetworkSpec diff --git a/src/Cardano/Wallet/CoinSelection.hs b/src/Cardano/Wallet/CoinSelection.hs index e666e7cf24a..101b88bf919 100644 --- a/src/Cardano/Wallet/CoinSelection.hs +++ b/src/Cardano/Wallet/CoinSelection.hs @@ -57,6 +57,10 @@ data CoinSelectionError = | MaximumInputsReached Word64 -- ^ When trying to construct a transaction, the max number of allowed -- inputs was reached. + | UtxoDepleted Word64 Word64 + -- ^ When trying to perform coin selection available utxos were depleted + -- We record the size of payment we try to make and the available balance + -- at the time of this attempt deriving (Show, Eq) data CoinSelection = CoinSelection diff --git a/src/Cardano/Wallet/CoinSelection/LargestFirst.hs b/src/Cardano/Wallet/CoinSelection/LargestFirst.hs index 5777a55d8f7..1a06bdcc535 100644 --- a/src/Cardano/Wallet/CoinSelection/LargestFirst.hs +++ b/src/Cardano/Wallet/CoinSelection/LargestFirst.hs @@ -10,7 +10,8 @@ module Cardano.Wallet.CoinSelection.LargestFirst ( - largestFirst + largestFirst + , atLeast ) where import Prelude diff --git a/src/Cardano/Wallet/CoinSelection/Random.hs b/src/Cardano/Wallet/CoinSelection/Random.hs new file mode 100644 index 00000000000..4e04101331a --- /dev/null +++ b/src/Cardano/Wallet/CoinSelection/Random.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Copyright: © 2018-2019 IOHK +-- License: MIT +-- +-- This module contains the implementation of random +-- input selection algorithm + + +module Cardano.Wallet.CoinSelection.Random ( + random + ) where + +import Prelude + +import Cardano.Wallet.CoinSelection + ( CoinSelection (..), CoinSelectionError (..), CoinSelectionOptions (..) ) +import Cardano.Wallet.Primitive.Types + ( Coin (..), TxIn, TxOut (..), UTxO (..), balance, excluding, isValidCoin ) +import Control.Monad + ( foldM, guard ) +import Control.Monad.Trans.Class + ( lift ) +import Control.Monad.Trans.Except + ( ExceptT (..), throwE ) +import Crypto.Number.Generate + ( generateBetween ) +import Crypto.Random.Types + ( MonadRandom, getRandomBytes ) +import Data.List.NonEmpty + ( NonEmpty (..) ) +import Data.Map.Strict + ( Map ) +import Data.Maybe + ( fromMaybe ) +import Data.Ord + ( comparing ) +import Data.Word + ( Word64 ) + +import qualified Cardano.Wallet.CoinSelection.LargestFirst as LargestFirst +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +-- Target range for picking inputs +data TargetRange = TargetRange + { targetMin :: Coin + , targetAim :: Coin + , targetMax :: Coin + } + +-- Random input selection policy +random + :: forall m. MonadRandom m + => CoinSelectionOptions + -> UTxO + -> NonEmpty TxOut + -> ExceptT CoinSelectionError m CoinSelection +random opt utxo txOutputs = do + let txOutputsSorted = NE.toList + $ NE.sortBy (flip $ comparing coin) txOutputs + let n = maximumNumberOfInputs opt + (_, res) <- foldM (processTxOut n) (utxo, mempty) txOutputsSorted + pure res + + +-- Selecting coins to cover at least the specified value +-- with LargestFirst fallback and subsequent iterative improvement +-- to optimize selection further +-- The details of the algorithm are following: +-- (a) transaction outputs are processed starting from the largest one +-- (b) random selection is tried. The random UTxO entry is picked and checked +-- whether it covers the transaction output (ie., `targetMin` of TargetRange. +-- If no, then additional UTxO entry is picked. If successive picking of inputs +-- gives rise to total the inputs sum covering the transaction output +-- then the optimization described in step (c) is tried. +-- If the random selection leads to the number of inputs that exceeds `maximumNumberOfInputs` +-- then, for both a given transaction output and UTxO as being at the beginning of step (b), +-- fallback LargestFirst algoritm is tried. +-- (c) candidate input selection obtained in step (b) is optimized. Both `targetAim` and `targetMax` +-- as pinpointed in TargetRange drive the optimization. Here, we pick randomly the next UTxO entry +-- from remaining UTxO and check if it is improved as depicted in `isImprovement`. If not, then +-- the optimization ends with returning its initial selection. Otherwise, the procedure tries to +-- optimize more. +processTxOut + :: forall m. MonadRandom m + => Word64 + -> (UTxO, CoinSelection) + -> TxOut + -> ExceptT CoinSelectionError m (UTxO, CoinSelection) +processTxOut maxNumInputs (utxo, selection) txout = do + atLeast ([], getUTxO utxo) >>= improve >>= \case + Just (inps,utxoMap) -> do + let change = + ((sum . (map (getCoin . coin . snd))) inps) + - ((getCoin . coin) txout) + pure (UTxO utxoMap + , selection <> CoinSelection + { inputs = inps + , outputs = [txout] + , change = [Coin change] + } + ) + Nothing -> + throwE $ MaximumInputsReached maxNumInputs + + where + atLeast + :: forall m. MonadRandom m + => ([(TxIn, TxOut)], Map TxIn TxOut) + -> ExceptT CoinSelectionError m ([(TxIn, TxOut)], Map TxIn TxOut) + atLeast (inps, utxoMap) + | L.length inps > (fromIntegral maxNumInputs) = do + let entries = Map.toList utxoMap + case LargestFirst.atLeast (entries, selection) txout of + Just (utxo', selection') -> do + let oldInps = + (Set.fromList . map fst) $ inputs selection + let diff = + (UTxO . Map.fromList . inputs) selection' `excluding` oldInps + pure ((Map.toList . getUTxO) diff, Map.fromList utxo') + Nothing -> + throwE $ MaximumInputsReached maxNumInputs + | sum (map (getCoin . coin . snd) inps) + > ((getCoin . targetMin . mkTargetRange . coin) txout) = + pure (inps, utxoMap) + | otherwise = do + let currBalance = fromIntegral $ balance utxo + (io, utxoMap') <- pickRandom utxoMap >>= + maybe (throwE $ UtxoDepleted currBalance ((getCoin . coin) txout)) return + atLeast (io:inps, utxoMap') + + improve + :: forall m. MonadRandom m + => ([(TxIn, TxOut)], Map TxIn TxOut) + -> ExceptT CoinSelectionError m (Maybe ([(TxIn, TxOut)], Map TxIn TxOut)) + improve (inps, utxoMap) = do + let currBalance = fromIntegral $ balance utxo + (io, utxoMap') <- pickRandom utxoMap >>= + maybe (throwE $ UtxoDepleted currBalance ((getCoin . coin) txout)) return + case isImprovement io inps of + Nothing -> + pure $ Just (inps, utxoMap) + Just inps' -> + improve (inps', utxoMap') + + isImprovement + :: (TxIn, TxOut) + -> [(TxIn, TxOut)] + -> Maybe [(TxIn, TxOut)] + isImprovement io selected = do + + guard + ((selectedBalance selected' <= targetMax targetRange) + && + (distance (targetAim targetRange) (selectedBalance selected') < + distance (targetAim targetRange) (selectedBalance selected)) + && + (L.length selected' <= fromIntegral maxNumInputs)) + + return selected' + where + selected' = io : selected + selectedBalance = Coin . sum . (map (getCoin . coin . snd)) + distance (Coin val1) (Coin val2) = + if val1 < val2 then + val2 - val1 + else + val1 - val2 + targetRange = (mkTargetRange . coin) txout + + +mkTargetRange :: Coin -> TargetRange +mkTargetRange val = + fromMaybe (privacyOffTargetRange val) (tryCanonicalTargetRange val) + where + tryCanonicalTargetRange :: Coin -> Maybe TargetRange + tryCanonicalTargetRange coin@(Coin v) = do + let targetMin = coin + targetAim <- + if isValidCoin (Coin $ 2*v) then Just (Coin $ 2*v) else Nothing + targetMax <- + if isValidCoin (Coin $ 3*v) then Just (Coin $ 3*v) else Nothing + return TargetRange {..} + privacyOffTargetRange :: Coin -> TargetRange + privacyOffTargetRange v = + TargetRange v v v + + +-- Pick a random element from a map +-- Returns 'Nothing' if the map is empty +pickRandom + :: MonadRandom m + => Map k a + -> m (Maybe ((k, a), Map k a)) +pickRandom m + | Map.null m = return Nothing + | otherwise = (withIx m) . fromIntegral <$> + generateBetween 0 (fromIntegral (Map.size m - 1)) + where + withIx + :: Map k a + -> Int + -> Maybe ((k, a), Map k a) + withIx m' ix = Just (Map.elemAt ix m', Map.deleteAt ix m') + + +instance MonadRandom m => MonadRandom (ExceptT e m) where + getRandomBytes = lift . getRandomBytes diff --git a/test/unit/Cardano/Wallet/CoinSelection/RandomSpec.hs b/test/unit/Cardano/Wallet/CoinSelection/RandomSpec.hs new file mode 100644 index 00000000000..51c1e734741 --- /dev/null +++ b/test/unit/Cardano/Wallet/CoinSelection/RandomSpec.hs @@ -0,0 +1,14 @@ +module Cardano.Wallet.CoinSelection.RandomSpec + ( spec + ) where + +import Prelude + +import Cardano.Wallet.CoinSelection.Random + () +import Test.Hspec + ( Spec ) + + +spec :: Spec +spec = return ()