diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index 623417bd900..2a934c89020 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 @@ -110,6 +111,7 @@ test-suite unit , cardano-crypto , cardano-wallet , cborg + , cryptonite , containers , deepseq , exceptions @@ -149,6 +151,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..ee37b03d8ad 100644 --- a/src/Cardano/Wallet/CoinSelection.hs +++ b/src/Cardano/Wallet/CoinSelection.hs @@ -11,40 +11,27 @@ -- https://iohk.io/blog/self-organisation-in-coin-selection/ -module Cardano.Wallet.CoinSelection where +module Cardano.Wallet.CoinSelection + ( CoinSelectionOptions (..) + , CoinSelectionError(..) + , CoinSelection(..) + ) where import Prelude import Cardano.Wallet.Primitive.Types - ( Coin (..), TxIn, TxOut (..), UTxO ) -import Data.List.NonEmpty - ( NonEmpty (..) ) -import Data.Quantity - ( Quantity (..) ) + ( Coin (..), TxIn, TxOut (..) ) import Data.Word ( Word64 ) import GHC.Generics ( Generic ) -import Numeric.Natural - ( Natural ) -data CoinSelectionOptions = CoinSelectionOptions - { estimateFee - :: Int - -> NonEmpty Coin - -> Coin - -- ^ A function to estimate the fees. - , dustThreshold - :: Coin - -- ^ Change addresses below the given threshold will be evicted - -- from the created transaction. If you only want to remove change - -- outputs equal to 0, set 'csoDustThreshold' to 0. - , maximumNumberOfInputs +newtype CoinSelectionOptions = CoinSelectionOptions + { maximumNumberOfInputs :: Word64 } deriving (Generic) - data CoinSelectionError = NotEnoughMoney Word64 Word64 -- ^ UTxO exhausted during input selection @@ -81,25 +68,3 @@ instance Semigroup CoinSelection where instance Monoid CoinSelection where mempty = CoinSelection [] [] [] - - ----------------------------------------------------------------------------- --- Fee related -- ----------------------------------------------------------------------------- - -newtype Fee = Fee { getFee :: Quantity "lovelace" Natural } - -adjustForFees - :: CoinSelectionOptions - -> ( Coin -> UTxO -> Maybe (TxIn, TxOut) ) - -> CoinSelection - -> CoinSelection -adjustForFees _opt _pickUtxo selection = do - let inps = inputs selection - let outs = outputs selection - let chgs = change selection - - -- here will come estimateFee and other stuff - -- and will change inps, outs and chgs - - CoinSelection inps outs chgs diff --git a/src/Cardano/Wallet/CoinSelection/LargestFirst.hs b/src/Cardano/Wallet/CoinSelection/LargestFirst.hs index 5777a55d8f7..6fe51df34eb 100644 --- a/src/Cardano/Wallet/CoinSelection/LargestFirst.hs +++ b/src/Cardano/Wallet/CoinSelection/LargestFirst.hs @@ -40,19 +40,19 @@ largestFirst -> UTxO -> NonEmpty TxOut -> ExceptT CoinSelectionError m CoinSelection -largestFirst opt utxo txOutputs = do - let txOutputsSorted = NE.toList $ NE.sortBy (flip $ comparing coin) txOutputs +largestFirst opt utxo outs = do + let descending = NE.toList . NE.sortBy (flip $ comparing coin) let n = fromIntegral $ maximumNumberOfInputs opt let nLargest = take n . L.sortBy (flip $ comparing (coin . snd)) . Map.toList . getUTxO - case foldM atLeast (nLargest utxo, mempty) txOutputsSorted of + case foldM atLeast (nLargest utxo, mempty) (descending outs) of Just (_, s) -> return s Nothing -> do - let moneyRequested = sum $ (getCoin . coin) <$> txOutputsSorted + let moneyRequested = sum $ (getCoin . coin) <$> (descending outs) let utxoBalance = fromIntegral $ balance utxo let numberOfUtxoEntries = fromIntegral $ L.length $ (Map.toList . getUTxO) utxo - let numberOfTransactionOutputs = fromIntegral $ NE.length txOutputs + let numberOfTransactionOutputs = fromIntegral $ NE.length outs when (utxoBalance < moneyRequested) $ throwE $ NotEnoughMoney utxoBalance moneyRequested diff --git a/src/Cardano/Wallet/CoinSelection/Random.hs b/src/Cardano/Wallet/CoinSelection/Random.hs new file mode 100644 index 00000000000..d38b5dc1947 --- /dev/null +++ b/src/Cardano/Wallet/CoinSelection/Random.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- 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.CoinSelection.LargestFirst + ( largestFirst ) +import Cardano.Wallet.Primitive.Types + ( Coin (..), TxIn, TxOut (..), UTxO (..), balance, invariant ) +import Control.Monad + ( foldM ) +import Control.Monad.Trans.Class + ( lift ) +import Control.Monad.Trans.Except + ( ExceptT (..) ) +import Control.Monad.Trans.Maybe + ( MaybeT (..), runMaybeT ) +import Crypto.Number.Generate + ( generateBetween ) +import Crypto.Random.Types + ( MonadRandom ) +import Data.List.NonEmpty + ( NonEmpty (..) ) +import Data.Ord + ( comparing ) +import Data.Word + ( Word64 ) + +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map + + +-- | Target range for picking inputs +data TargetRange = TargetRange + { targetMin :: Word64 + -- ^ Minimum value to cover: only the requested amount, no change at all + , targetAim :: Word64 + -- ^ Ideal case: change equal to requested amount + , targetMax :: Word64 + -- ^ Maximum value: an arbitrary upper bound (e.g. @2 * targetMin@) + } + +-- | Random-Improve Algorithm +-- +-- 1. Randomly select outputs from the UTxO until the payment value is covered. +-- (In the rare case that this fails because the maximum number of 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: +-- +-- (a) It doesn’t exceed a specified upper limit. +-- (b) Adding the new output gets us closer to the ideal change value. +-- (c) It doesn’t exceed a maximum number of transaction inputs. +-- +-- This algorithm follows three principles: +-- +-- @ +-- **Self organisation principle 1** +-- Random selection has a high probability of picking dust outputs precisely +-- when there is a lot of dust in the UTxO. +-- @ +-- +-- @ +-- **Self organisation principle 2** +-- If for each payment request for value `x` we create a change output roughly +-- of the same value `x`, then we will end up with a lot of change outputs in +-- our UTxO of size `x` precisely when we have a lot of payment requests of +-- size `x` +-- @ +-- +-- @ +-- **Self organisation principle 3** +-- Searching the UTxO for additional entries to improve our change output is +-- only useful if the UTxO contains entries that are sufficiently small enough. +-- But precisely when the UTxO contains many small entries, it is less likely +-- that a randomly chosen UTxO entry will push the total above the upper bound +-- we set. +-- @ +random + :: forall m. MonadRandom m + => CoinSelectionOptions + -> UTxO + -> NonEmpty TxOut + -> ExceptT CoinSelectionError m CoinSelection +random opt utxo outs = do + let descending = NE.toList . NE.sortBy (flip $ comparing coin) + randomMaybe <- lift $ runMaybeT $ foldM + (processTxOut opt) + (utxo, mempty) + (descending outs) + case randomMaybe of + Just (_,res) -> + return res + Nothing -> + largestFirst opt utxo outs + +-- | Perform a random selection on a given output, with improvement. +processTxOut + :: forall m. MonadRandom m + => CoinSelectionOptions + -> (UTxO, CoinSelection) + -> TxOut + -> MaybeT m (UTxO, CoinSelection) +processTxOut (CoinSelectionOptions maxNumInputs) (utxo0, selection) txout = do + attempt <- coverRandomly ([], utxo0) + (inps, utxo') <- lift (improve attempt) + return + ( utxo' + , selection <> CoinSelection + { inputs = inps + , outputs = [txout] + , change = mkChange txout inps + } + ) + 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 = + MaybeT $ return $ Just (inps, utxo) + | otherwise = do + pickRandom utxo >>= \(io, utxo') -> coverRandomly (io:inps, utxo') + + improve + :: forall m. MonadRandom m + => ([(TxIn, TxOut)], UTxO) + -> m ([(TxIn, TxOut)], UTxO) + improve (inps, utxo) = + runMaybeT (pickRandom 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) + + 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 + + condB = -- (b) Addition gets us closer to the ideal change + distance (targetAim target) (balance' (io : selected)) + < + distance (targetAim target) (balance' selected) + + condC = -- (c) Doesn't exceed maximum number of inputs + length (io : selected) <= fromIntegral maxNumInputs + in + condA && condB && condC + +{------------------------------------------------------------------------------- + Internals +-------------------------------------------------------------------------------} + +-- | Compute the target range for a given output +mkTargetRange :: TxOut -> TargetRange +mkTargetRange (TxOut _ (Coin c)) = TargetRange + { targetMin = c + , targetAim = 2 * c + , targetMax = 3 * c + } + +-- | Compute the balance of a unwrapped UTxO +balance' :: [(TxIn, TxOut)] -> Word64 +balance' = + fromIntegral . balance . UTxO . Map.fromList + +-- | Compute distance between two numeric values |a - b| +distance :: (Ord a, Num a) => a -> a -> a +distance a b = + if a < b then b - a else a - b + +-- | 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 = + let + selected = invariant + "mkChange: output is smaller than selected inputs!" + (balance' inps) + (> out) + Coin maxCoinValue = maxBound + in + case selected - out of + c | c > maxCoinValue -> + let h = (c `div` 2) in [Coin h, Coin (c - h)] + c | c == 0 -> + [] + c -> + [ Coin c ] + +-- Pick a random element from a map, returns 'Nothing' if the map is empty +pickRandom + :: MonadRandom m + => UTxO + -> MaybeT m ((TxIn, TxOut), UTxO) +pickRandom (UTxO utxo) + | Map.null utxo = + MaybeT $ return Nothing + | otherwise = do + ix <- fromEnum <$> lift (generateBetween 0 (toEnum (Map.size utxo - 1))) + return (Map.elemAt ix utxo, UTxO $ Map.deleteAt ix utxo) diff --git a/test/unit/Cardano/Wallet/CoinSelection/LargestFirstSpec.hs b/test/unit/Cardano/Wallet/CoinSelection/LargestFirstSpec.hs index cdd0add2a4b..e28262bdc35 100644 --- a/test/unit/Cardano/Wallet/CoinSelection/LargestFirstSpec.hs +++ b/test/unit/Cardano/Wallet/CoinSelection/LargestFirstSpec.hs @@ -12,15 +12,10 @@ import Cardano.Wallet.CoinSelection ( CoinSelection (..), CoinSelectionError (..), CoinSelectionOptions (..) ) import Cardano.Wallet.CoinSelection.LargestFirst ( largestFirst ) +import Cardano.Wallet.CoinSelectionSpec + ( CoveringCase (..), Fixture (..), coinSelectionUnitTest ) import Cardano.Wallet.Primitive.Types - ( Address (..) - , Coin (..) - , Hash (..) - , TxIn (..) - , TxOut (..) - , UTxO (..) - , excluding - ) + ( Coin (..), TxOut (..), UTxO (..), excluding ) import Control.Monad ( unless ) import Control.Monad.Trans.Except @@ -31,25 +26,11 @@ import Data.Functor.Identity ( Identity (runIdentity) ) import Data.List.NonEmpty ( NonEmpty (..) ) -import Data.Word - ( Word64, Word8 ) import Test.Hspec - ( Expectation, Spec, describe, it, shouldBe, shouldSatisfy ) + ( Spec, describe, it, shouldSatisfy ) import Test.QuickCheck - ( Arbitrary (..) - , Gen - , Property - , choose - , generate - , oneof - , property - , scale - , vectorOf - , (===) - , (==>) - ) + ( Property, property, (===), (==>) ) -import qualified Data.ByteString as BS import qualified Data.List as L import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map @@ -58,134 +39,96 @@ import qualified Data.Set as Set spec :: Spec spec = do describe "Coin selection : LargestFirst algorithm unit tests" $ do - it "one input per small output" $ do - (coinSelectionUnitTest - Fixture - { maxNumOfInputs = 100 - , utxoInputs = [10,10,17] - , txOutputs = 17 :| [] - , expectedResult = Right [17] - }) - it "one input per big output" $ do - (coinSelectionUnitTest - Fixture - { maxNumOfInputs = 100 - , utxoInputs = [12,10,17] - , txOutputs = 1 :| [] - , expectedResult = Right [17] - }) - it "two inputs per output" $ do - (coinSelectionUnitTest - Fixture - { maxNumOfInputs = 100 - , utxoInputs = [12,10,17] - , txOutputs = 18 :| [] - , expectedResult = Right [12, 17] - }) - it "three inputs per output" $ do - (coinSelectionUnitTest - Fixture - { maxNumOfInputs = 100 - , utxoInputs = [12,10,17] - , txOutputs = 30 :| [] - , expectedResult = Right [10, 12, 17] - }) - it "NotEnoughMoney error expected when not enough coins" $ do - (coinSelectionUnitTest - Fixture + coinSelectionUnitTest largestFirst "" (Right [17]) $ Fixture + { maxNumOfInputs = 100 + , utxoInputs = [10,10,17] + , txOutputs = 17 :| [] + } + + coinSelectionUnitTest largestFirst "" (Right [17]) $ Fixture + { maxNumOfInputs = 100 + , utxoInputs = [12,10,17] + , txOutputs = 1 :| [] + } + + coinSelectionUnitTest largestFirst "" (Right [12, 17]) $ Fixture + { maxNumOfInputs = 100 + , utxoInputs = [12,10,17] + , txOutputs = 18 :| [] + } + + coinSelectionUnitTest largestFirst "" (Right [10, 12, 17]) $ Fixture + { maxNumOfInputs = 100 + , utxoInputs = [12,10,17] + , txOutputs = 30 :| [] + } + + coinSelectionUnitTest largestFirst "" (Right [6,10,5]) $ Fixture + { maxNumOfInputs = 3 + , utxoInputs = [1,2,10,6,5] + , txOutputs = 11 :| [1] + } + + coinSelectionUnitTest + largestFirst + "not enough coins" + (Left $ NotEnoughMoney 39 40) + $ Fixture { maxNumOfInputs = 100 , utxoInputs = [12,10,17] , txOutputs = 40 :| [] - , expectedResult = Left $ NotEnoughMoney 39 40 - }) - it "NotEnoughMoney error expected when not enough coins and utxo not fragmented enough" $ do - (coinSelectionUnitTest - Fixture + } + + coinSelectionUnitTest + largestFirst + "not enough coin & not fragmented enough" + (Left $ NotEnoughMoney 39 43) + $ Fixture { maxNumOfInputs = 100 , utxoInputs = [12,10,17] , txOutputs = 40 :| [1,1,1] - , expectedResult = Left $ NotEnoughMoney 39 43 - }) - it "UtxoNotEnoughFragmented error expected when enough coins and utxo not fragmented enough" $ do - (coinSelectionUnitTest - Fixture + } + + coinSelectionUnitTest + largestFirst + "enough coins, but not fragmented enough" + (Left $ UtxoNotEnoughFragmented 3 4) + $ Fixture { maxNumOfInputs = 100 , utxoInputs = [12,20,17] , txOutputs = 40 :| [1,1,1] - , expectedResult = Left $ UtxoNotEnoughFragmented 3 4 - }) - it "happy path with correct maximumNumberOfInputs - 3 inputs for 2 outputs" $ do - (coinSelectionUnitTest - Fixture - { maxNumOfInputs = 3 - , utxoInputs = [1,2,10,6,5] - , txOutputs = 11 :| [1] - , expectedResult = Right [6,10,5] - }) - it "happy path with too strict maximumNumberOfInputs result in error - 3 inputs for 2 outputs" $ do - (coinSelectionUnitTest - Fixture + } + + coinSelectionUnitTest + largestFirst + "enough coins but, strict maximumNumberOfInputs" + (Left $ MaximumInputsReached 2) + $ Fixture { maxNumOfInputs = 2 , utxoInputs = [1,2,10,6,5] , txOutputs = 11 :| [1] - , expectedResult = Left $ MaximumInputsReached 2 - }) + } describe "Coin selection properties : LargestFirst algorithm" $ do - it "forall (UTxO, NonEmpty TxOut), \ - \ running algorithm twice yields exactly the same result" + 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" + it "forall (UTxO, NonEmpty TxOut), there's at least as many selected \ + \inputs as there are requested outputs" (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." + 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) {------------------------------------------------------------------------------- - Properties and unit test generic scenario + Properties -------------------------------------------------------------------------------} -data Fixture = Fixture - { maxNumOfInputs :: Word64 - , utxoInputs :: [Word64] - , txOutputs :: NonEmpty Word64 - , expectedResult :: Either CoinSelectionError [Word64] - } deriving Show - - -coinSelectionUnitTest - :: Fixture - -> Expectation -coinSelectionUnitTest (Fixture n utxoCoins txOutsCoins expected) = do - (utxo,txOuts) <- setup - - result <- runExceptT $ do - CoinSelection inps _ _ <- - largestFirst (defaultCoinSelectionOptions n) utxo txOuts - return $ map (getCoin . coin . snd) inps - - result `shouldBe` expected - where - setup :: IO (UTxO, NonEmpty TxOut) - setup = do - ins <- generate $ vectorOf (L.length utxoCoins) arbitrary - addrs <- generate $ vectorOf (L.length utxoCoins) arbitrary - let utxo = UTxO $ Map.fromList - $ L.zip ins - $ L.zipWith TxOut addrs - $ map Coin utxoCoins - txOutsAddrs <- generate $ vectorOf (L.length txOutsCoins) arbitrary - let txOuts = NE.zipWith TxOut (NE.fromList txOutsAddrs) - $ NE.map Coin txOutsCoins - pure (utxo, txOuts) - - propDeterministic :: CoveringCase -> Property propDeterministic (CoveringCase (utxo, txOuts)) = do - let opts = defaultCoinSelectionOptions 100 + let opts = CoinSelectionOptions 100 let resultOne = runIdentity $ runExceptT $ largestFirst opts utxo txOuts let resultTwo = runIdentity $ runExceptT $ largestFirst opts utxo txOuts resultOne === resultTwo @@ -199,7 +142,7 @@ propAtLeast (CoveringCase (utxo, txOuts)) = prop (CoinSelection inps _ _) = L.length inps `shouldSatisfy` (>= NE.length txOuts) selection = runIdentity $ runExceptT $ - largestFirst (defaultCoinSelectionOptions 100) utxo txOuts + largestFirst (CoinSelectionOptions 100) utxo txOuts propInputDecreasingOrder :: CoveringCase @@ -217,68 +160,4 @@ propInputDecreasingOrder (CoveringCase (utxo, txOuts)) = (>= (getExtremumValue L.maximum utxo')) getExtremumValue f = f . map (getCoin . coin . snd) selection = runIdentity $ runExceptT $ - largestFirst (defaultCoinSelectionOptions 100) utxo txOuts - - -{------------------------------------------------------------------------------- - Test Data --------------------------------------------------------------------------------} - -defaultCoinSelectionOptions - :: Word64 - -> CoinSelectionOptions -defaultCoinSelectionOptions n = CoinSelectionOptions - { estimateFee = \_ _ -> Coin 0 - , dustThreshold = Coin 0 - , maximumNumberOfInputs = n - } - -newtype CoveringCase = CoveringCase { getCoveringCase :: (UTxO, NonEmpty TxOut)} - deriving Show - -instance Arbitrary CoveringCase where - arbitrary = do - n <- choose (1, 10) - txOutsNonEmpty <- NE.fromList <$> vectorOf n arbitrary - utxo <- arbitrary - return $ CoveringCase (utxo, txOutsNonEmpty) - -instance Arbitrary (Hash "Tx") where - -- No Shrinking - arbitrary = do - wds <- vectorOf 10 arbitrary :: Gen [Word8] - let bs = BS.pack wds - pure $ Hash bs - -instance Arbitrary Address where - -- No Shrinking - arbitrary = oneof - [ pure $ Address "ADDR01" - , pure $ Address "ADDR02" - , pure $ Address "ADDR03" - ] - -instance Arbitrary Coin where - -- No Shrinking - arbitrary = Coin <$> choose (1, 100000) - -instance Arbitrary TxOut where - -- No Shrinking - arbitrary = TxOut - <$> arbitrary - <*> arbitrary - -instance Arbitrary TxIn where - -- No Shrinking - arbitrary = TxIn - <$> arbitrary - <*> scale (`mod` 3) arbitrary -- No need for a high indexes - -instance Arbitrary UTxO where - shrink (UTxO utxo) = UTxO <$> shrink utxo - arbitrary = do - n <- choose (1, 100) - utxo <- zip - <$> vectorOf n arbitrary - <*> vectorOf n arbitrary - return $ UTxO $ Map.fromList utxo + largestFirst (CoinSelectionOptions 100) utxo txOuts diff --git a/test/unit/Cardano/Wallet/CoinSelection/RandomSpec.hs b/test/unit/Cardano/Wallet/CoinSelection/RandomSpec.hs new file mode 100644 index 00000000000..fa192dcbb3d --- /dev/null +++ b/test/unit/Cardano/Wallet/CoinSelection/RandomSpec.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.Wallet.CoinSelection.RandomSpec + ( spec + ) where + +import Prelude + +import Cardano.Wallet.CoinSelection + ( CoinSelection (..), CoinSelectionError (..), CoinSelectionOptions (..) ) +import Cardano.Wallet.CoinSelection.LargestFirst + ( largestFirst ) +import Cardano.Wallet.CoinSelection.Random + ( random ) +import Cardano.Wallet.CoinSelectionSpec + ( CoveringCase (..), Fixture (..), coinSelectionUnitTest ) +import Control.Monad.Trans.Except + ( runExceptT ) +import Crypto.Random + ( SystemDRG, getSystemDRG ) +import Crypto.Random.Types + ( withDRG ) +import Data.Either + ( isLeft, isRight ) +import Data.Functor.Identity + ( Identity (..) ) +import Data.List.NonEmpty + ( NonEmpty (..) ) +import Test.Hspec + ( Spec, before, describe, it, shouldSatisfy ) +import Test.QuickCheck + ( Property, property, (===), (==>) ) + +import qualified Data.List as L + + +spec :: Spec +spec = do + describe "Unit tests" $ do + coinSelectionUnitTest random "" (Right [1,1,1,1]) $ Fixture + { maxNumOfInputs = 100 + , utxoInputs = [1,1,1,1,1,1] + , txOutputs = 2 :| [] + } + + coinSelectionUnitTest random "" (Right [1,1,1,1,1,1]) $ Fixture + { maxNumOfInputs = 100 + , utxoInputs = [1,1,1,1,1,1] + , txOutputs = 2 :| [1] + } + + coinSelectionUnitTest random "" (Right [1,1,1,1,1]) $ Fixture + { maxNumOfInputs = 100 + , utxoInputs = [1,1,1,1,1] + , txOutputs = 2 :| [1] + } + + coinSelectionUnitTest random "with fallback" (Right [1,1,1]) $ Fixture + { maxNumOfInputs = 100 + , utxoInputs = [1,1,1,1] + , txOutputs = 2 :| [1] + } + + coinSelectionUnitTest random "" (Right [5]) $ Fixture + { maxNumOfInputs = 100 + , utxoInputs = [5,5,5] + , txOutputs = 2 :| [] + } + + coinSelectionUnitTest random "" (Right [10,10]) $ Fixture + { maxNumOfInputs = 100 + , utxoInputs = [10,10,10] + , txOutputs = 2 :| [2] + } + + coinSelectionUnitTest random "cannot cover aim, but only min" + (Right [1,1,1,1]) $ Fixture + { maxNumOfInputs = 4 + , utxoInputs = [1,1,1,1,1,1] + , txOutputs = 3 :| [] + } + + coinSelectionUnitTest random "" (Left $ MaximumInputsReached 2) $ Fixture + { maxNumOfInputs = 2 + , utxoInputs = [1,1,1,1,1,1] + , txOutputs = 3 :| [] + } + + coinSelectionUnitTest random "" (Left $ NotEnoughMoney 39 40) $ Fixture + { maxNumOfInputs = 100 + , utxoInputs = [12,10,17] + , txOutputs = 40 :| [] + } + + coinSelectionUnitTest random "" (Left $ NotEnoughMoney 39 43) $ Fixture + { maxNumOfInputs = 100 + , utxoInputs = [12,10,17] + , txOutputs = 40 :| [1,1,1] + } + + coinSelectionUnitTest random "" (Left $ UtxoNotEnoughFragmented 3 4) $ Fixture + { maxNumOfInputs = 100 + , utxoInputs = [12,20,17] + , txOutputs = 40 :| [1,1,1] + } + + before getSystemDRG $ describe "Property Tests" $ do + it "forall (UTxO, NonEmpty TxOut), \ + \ running algorithm gives not less UTxO fragmentation than LargestFirst algorithm" + (property . propFragmentation) + it "forall (UTxO, NonEmpty TxOut), \ + \ running algorithm gives the same errors as LargestFirst algorithm" + (property . propErrors) + +{------------------------------------------------------------------------------- + Properties +-------------------------------------------------------------------------------} + +propFragmentation + :: SystemDRG + -> CoveringCase + -> Property +propFragmentation drg (CoveringCase (utxo, txOuts)) = do + isRight selection1 && isRight selection2 ==> + let (Right s1, Right s2) = + (selection1, selection2) + in prop (s1, s2) + where + prop (CoinSelection inps1 _ _, CoinSelection inps2 _ _) = + L.length inps1 `shouldSatisfy` (>= L.length inps2) + (selection1,_) = withDRG drg + (runExceptT $ random (CoinSelectionOptions 100) utxo txOuts) + selection2 = runIdentity $ runExceptT $ + largestFirst (CoinSelectionOptions 100) utxo txOuts + +propErrors + :: SystemDRG + -> CoveringCase + -> Property +propErrors drg (CoveringCase (utxo, txOuts)) = do + isLeft selection1 && isLeft selection2 ==> + let (Left s1, Left s2) = (selection1, selection2) + in prop (s1, s2) + where + prop (err1, err2) = + err1 === err2 + (selection1,_) = withDRG drg + (runExceptT $ random (CoinSelectionOptions 1) utxo txOuts) + selection2 = runIdentity $ runExceptT $ + largestFirst (CoinSelectionOptions 1) utxo txOuts diff --git a/test/unit/Cardano/Wallet/CoinSelectionSpec.hs b/test/unit/Cardano/Wallet/CoinSelectionSpec.hs index 2fc4f7447df..a79db52735c 100644 --- a/test/unit/Cardano/Wallet/CoinSelectionSpec.hs +++ b/test/unit/Cardano/Wallet/CoinSelectionSpec.hs @@ -1,14 +1,148 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Cardano.Wallet.CoinSelectionSpec ( spec + , Fixture(..) + , coinSelectionUnitTest + , CoveringCase(..) ) where +-- | This module contains shared logic between the coin selection tests. They +-- ought to share the same interface, and therefore, it makes sense for them to +-- also require the same arbitrary instances and instrument testing in a similar +-- way for both. + import Prelude import Cardano.Wallet.CoinSelection - () + ( CoinSelection (..), CoinSelectionError (..), CoinSelectionOptions (..) ) +import Cardano.Wallet.Primitive.Types + ( Address (..), Coin (..), Hash (..), TxIn (..), TxOut (..), UTxO (..) ) +import Control.Monad.Trans.Except + ( ExceptT, runExceptT ) +import Data.List.NonEmpty + ( NonEmpty (..) ) +import Data.Word + ( Word64, Word8 ) import Test.Hspec - ( Spec ) + ( Spec, SpecWith, it, shouldBe ) +import Test.QuickCheck + ( Arbitrary (..), Gen, choose, generate, oneof, scale, vectorOf ) + +import qualified Data.ByteString as BS +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map spec :: Spec spec = return () + +-- | A fixture for testing the coin selection +data Fixture = Fixture + { maxNumOfInputs :: Word64 + -- ^ Maximum number of inputs that can be selected + , utxoInputs :: [Word64] + -- ^ Value (in Lovelace) & number of available coins in the UTxO + , txOutputs :: NonEmpty Word64 + -- ^ Value (in Lovelace) & number of requested outputs + } deriving Show + +-- | Data for running +newtype CoveringCase = CoveringCase { getCoveringCase :: (UTxO, NonEmpty TxOut)} + deriving Show + +-- | Generate a 'UTxO' and 'TxOut' matching the given 'Fixture', and perform +-- given coin selection on it. +coinSelectionUnitTest + :: ( CoinSelectionOptions + -> UTxO + -> NonEmpty TxOut + -> ExceptT CoinSelectionError IO CoinSelection + ) + -> String + -> Either CoinSelectionError [Word64] + -> Fixture + -> SpecWith () +coinSelectionUnitTest run lbl expected (Fixture n utxoCoins txOutsCoins) = + it title $ do + (utxo,txOuts) <- setup + result <- runExceptT $ do + CoinSelection inps _ _ <- + run (CoinSelectionOptions n) utxo txOuts + return $ map (getCoin . coin . snd) inps + result `shouldBe` expected + where + title :: String + title = mempty + <> "max=" <> show n + <> ", UTxO=" <> show utxoCoins + <> ", Output=" <> show (NE.toList txOutsCoins) + <> " --> " <> show expected + <> if null lbl then "" else " (" <> lbl <> ")" + + setup :: IO (UTxO, NonEmpty TxOut) + setup = do + ins <- generate $ vectorOf (L.length utxoCoins) arbitrary + addrs <- generate $ vectorOf (L.length utxoCoins) arbitrary + let utxo = UTxO $ Map.fromList + $ L.zip ins + $ L.zipWith TxOut addrs + $ map Coin utxoCoins + txOutsAddrs <- generate $ vectorOf (L.length txOutsCoins) arbitrary + let txOuts = NE.zipWith TxOut (NE.fromList txOutsAddrs) + $ NE.map Coin txOutsCoins + pure (utxo, txOuts) + +{------------------------------------------------------------------------------- + Arbitrary Instances +-------------------------------------------------------------------------------} + +instance Arbitrary CoveringCase where + arbitrary = do + n <- choose (1, 10) + txOutsNonEmpty <- NE.fromList <$> vectorOf n arbitrary + utxo <- arbitrary + return $ CoveringCase (utxo, txOutsNonEmpty) + +instance Arbitrary Address where + -- No Shrinking + arbitrary = oneof + [ pure $ Address "ADDR01" + , pure $ Address "ADDR02" + , pure $ Address "ADDR03" + ] + +instance Arbitrary Coin where + -- No Shrinking + arbitrary = Coin <$> choose (1, 100000) + +instance Arbitrary TxIn where + -- No Shrinking + arbitrary = TxIn + <$> arbitrary + <*> scale (`mod` 3) arbitrary -- No need for a high indexes + +instance Arbitrary (Hash "Tx") where + -- No Shrinking + arbitrary = do + wds <- vectorOf 10 arbitrary :: Gen [Word8] + let bs = BS.pack wds + pure $ Hash bs + +instance Arbitrary TxOut where + -- No Shrinking + arbitrary = TxOut + <$> arbitrary + <*> arbitrary + +instance Arbitrary UTxO where + shrink (UTxO utxo) = UTxO <$> shrink utxo + arbitrary = do + n <- choose (1, 100) + utxo <- zip + <$> vectorOf n arbitrary + <*> vectorOf n arbitrary + return $ UTxO $ Map.fromList utxo