cardano-coin-selection 1.0.0 → 1.0.1
raw patch · 10 files changed
+473/−354 lines, 10 files
Files
- ChangeLog.md +34/−0
- cardano-coin-selection.cabal +4/−4
- src/library/Cardano/CoinSelection.hs +1/−1
- src/library/Cardano/CoinSelection/Algorithm/LargestFirst.hs +77/−210
- src/library/Cardano/CoinSelection/Algorithm/Migration.hs +16/−13
- src/library/Cardano/CoinSelection/Fee.hs +14/−2
- src/test/Cardano/CoinSelection/Algorithm/LargestFirstSpec.hs +205/−77
- src/test/Cardano/CoinSelection/Algorithm/MigrationSpec.hs +12/−11
- src/test/Cardano/CoinSelection/Algorithm/RandomImproveSpec.hs +53/−18
- src/test/Cardano/CoinSelectionSpec.hs +57/−18
ChangeLog.md view
@@ -1,3 +1,37 @@+## [1.0.1] - 2020-05-13++### Improvements++* Adjusted the Largest-First algorithm to pay for outputs collectively instead+ of individually.++ The updated algorithm should now be successful at paying for any set of+ outputs of total value **_v_** provided that the total value **_u_** of+ available inputs satisfies **_u_** ≥ **_v_**.++ The cardinality restriction requiring the number of inputs to be greater than+ the number of outputs has been removed.++ See the following commits for more details:++ * `aae26dddb727779f`+ ([PR #73](https://github.com/input-output-hk/cardano-coin-selection/pull/73))+ * `65d5108bac63251f`+ ([PR #76](https://github.com/input-output-hk/cardano-coin-selection/pull/76))++### Fixes++* Fixed a small issue with the migration algorithm that caused it to+ occasionally return more change than actually available.++ This issue only occurred in extreme situations, where the total value of the+ available UTxO set was less than the dust threshold value.++ See the following commits for more details:++ * `14ef17a9647974a8`+ ([PR #77](https://github.com/input-output-hk/cardano-coin-selection/pull/77))+ ## [1.0.0] - 2020-04-29 Initial release.
cardano-coin-selection.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: fa91aa04303b2016d424d05014b688d5845de29176adad56b44a698e849d080a+-- hash: 955257d9cc818ae774b8798f360815648a42e3808e53b8363c5195d1864c716a name: cardano-coin-selection-version: 1.0.0+version: 1.0.1 synopsis: Algorithms for coin selection and fee balancing. description: Please see the README on GitHub at <https://github.com/input-output-hk/cardano-coin-selection> category: Cardano@@ -58,7 +58,7 @@ , deepseq , quiet , text- , transformers+ , transformers >=0.5.6.0 if flag(release) ghc-options: -Werror default-language: Haskell2010@@ -96,7 +96,7 @@ , quiet , random , text- , transformers+ , transformers >=0.5.6.0 , vector if flag(release) ghc-options: -Werror
src/library/Cardano/CoinSelection.hs view
@@ -233,7 +233,7 @@ -- ^ The generated coin selection. , inputsRemaining :: CoinMap i -- ^ The set of inputs that were __not__ selected.- }+ } deriving (Eq, Show) -- | A __coin selection__ is the basis for a /transaction/. --
src/library/Cardano/CoinSelection/Algorithm/LargestFirst.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- |@@ -15,29 +17,28 @@ import Prelude import Cardano.CoinSelection- ( CoinMapEntry (..)+ ( CoinMap (..)+ , CoinMapEntry (..) , CoinSelection (..) , CoinSelectionAlgorithm (..) , CoinSelectionError (..) , CoinSelectionLimit (..) , CoinSelectionParameters (..) , CoinSelectionResult (..)- , InputCountInsufficientError (..) , InputLimitExceededError (..) , InputValueInsufficientError (..)- , InputsExhaustedError (..) , coinMapFromList , coinMapToList , coinMapValue )-import Control.Monad- ( foldM ) import Control.Monad.Trans.Except ( ExceptT (..), throwE )+import Data.Function+ ( (&) ) import Data.Ord ( Down (..) )-import Internal.Coin- ( Coin )+import Data.Word+ ( Word16 ) import qualified Data.Foldable as F import qualified Data.List as L@@ -45,236 +46,102 @@ -- | An implementation of the __Largest-First__ coin selection algorithm. ----- = Overview------ The __Largest-First__ algorithm processes outputs in /descending order of/--- /value/, from /largest/ to /smallest/.------ For each output, it repeatedly selects the /largest/ remaining unspent UTxO--- entry until the value of selected entries is greater than or equal to the--- value of that output.------ = State Maintained by the Algorithm------ At all stages of processing, the algorithm maintains:------ 1. A __/remaining UTxO list/__------ This is initially equal to the given /initial UTxO set/ parameter,--- sorted into /descending order of coin value/.------ The /head/ of the list is always the remaining UTxO entry with the--- /largest coin value/.------ Entries are incrementally removed from the /head/ of the list as the--- algorithm proceeds, until the list is empty.------ 2. An __/unpaid output list/__------ This is initially equal to the given /output list/ parameter, sorted--- into /descending order of coin value/.------ The /head/ of the list is always the unpaid output with the--- /largest coin value/.------ Entries are incrementally removed from the /head/ of the list as the--- algorithm proceeds, until the list is empty.------ 3. An __/accumulated coin selection/__------ This is initially /empty/.------ Entries are incrementally added as each output is paid for, until the--- /unpaid output list/ is empty.------ = Cardinality Rules------ The algorithm requires that:------ 1. Each output from the given /output list/ is paid for by /one or more/--- entries from the /initial UTxO set/.------ 2. Each entry from the /initial UTxO set/ is used to pay for /at most one/--- output from the given /output list/.------ (A single UTxO entry __cannot__ be used to pay for multiple outputs.)------ = Order of Processing------ The algorithm proceeds according to the following sequence of steps:------ * /Step 1/------ Remove a single /unpaid output/ from the head of the--- /unpaid output list/.------ * /Step 2/------ Repeatedly remove UTxO entries from the head of the--- /remaining UTxO list/ until the total value of entries removed is--- /greater than or equal to/ the value of the /removed output/.------ * /Step 3/------ Use the /removed UTxO entries/ to pay for the /removed output/.------ This is achieved by:------ * adding the /removed UTxO entries/ to the 'inputs' field of the--- /accumulated coin selection/.--- * adding the /removed output/ to the 'outputs' field of the--- /accumulated coin selection/.------ * /Step 4/------ If the /total value/ of the /removed UTxO entries/ is greater than the--- value of the /removed output/, generate a coin whose value is equal to--- the exact difference, and add it to the 'change' field of the--- /accumulated coin selection/.------ * /Step 5/------ If the /unpaid output list/ is empty, __terminate__ here.+-- The Largest-First coin selection algorithm considers available inputs in+-- /descending/ order of value, from /largest/ to /smallest/. ----- Otherwise, return to /Step 1/.+-- When applied to a set of requested outputs, the algorithm repeatedly selects+-- entries from the available inputs set until the total value of selected+-- entries is greater than or equal to the total value of requested outputs. ----- = Termination+-- === Change Values ----- The algorithm terminates __successfully__ if the /remaining UTxO list/ is--- not depleted before the /unpaid output list/ can be fully depleted (i.e., if--- all the outputs have been paid for).+-- If the total value of selected inputs is /greater than/ the total value of+-- all requested outputs, the 'change' set of the resulting selection will+-- contain /a single coin/ with the excess value. ----- The /accumulated coin selection/ and /remaining UTxO list/ are returned to--- the caller.+-- If the total value of selected inputs is /exactly equal to/ the total value+-- of all requested outputs, the 'change' set of the resulting selection will+-- be /empty/. -- -- === Failure Modes -- -- The algorithm terminates with an __error__ if: ----- 1. The /total value/ of the initial UTxO set (the amount of money--- /available/) is /less than/ the total value of the output list (the+-- 1. The /total value/ of 'inputsAvailable' (the amount of money+-- /available/) is /less than/ the total value of 'outputsRequested' (the -- amount of money /required/). -- -- See: __'InputValueInsufficientError'__. ----- 2. The /number/ of entries in the initial UTxO set is /smaller than/ the--- number of requested outputs.------ Due to the nature of the algorithm, /at least one/ UTxO entry is--- required /for each/ output.------ See: __'InputCountInsufficientError'__.------ 3. Due to the particular /distribution/ of values within the initial UTxO--- set, the algorithm depletes all entries from the UTxO set /before/ it--- is able to pay for all requested outputs.------ See: __'InputsExhaustedError'__.------ 4. The /number/ of UTxO entries needed to pay for the requested outputs--- would /exceed/ the upper limit specified by 'limit'.+-- 2. It is not possible to cover the total value of 'outputsRequested'+-- without selecting a number of inputs from 'inputsAvailable' that+-- would exceed the maximum defined by 'limit'. -- -- See: __'InputLimitExceededError'__. -- -- @since 1.0.0 largestFirst- :: (Ord i, Ord o, Monad m)+ :: (Ord i, Monad m) => CoinSelectionAlgorithm i o m largestFirst = CoinSelectionAlgorithm payForOutputs payForOutputs- :: (Ord i, Ord o, Monad m)+ :: forall i o m . (Ord i, Monad m) => CoinSelectionParameters i o -> ExceptT CoinSelectionError m (CoinSelectionResult i o)-payForOutputs params =- case foldM payForOutput (utxoDescending, mempty) outputsDescending of- Just (utxoRemaining, selection) ->- pure $ CoinSelectionResult selection $ coinMapFromList utxoRemaining- Nothing ->- throwE errorCondition+payForOutputs params+ | amountAvailable < amountRequired =+ throwE+ $ InputValueInsufficient+ $ InputValueInsufficientError amountAvailable amountRequired+ | length inputsSelected > inputCountMax =+ throwE+ $ InputLimitExceeded+ $ InputLimitExceededError+ $ fromIntegral inputCountMax+ | otherwise =+ pure CoinSelectionResult {coinSelection, inputsRemaining} where- errorCondition- | amountAvailable < amountRequested =- InputValueInsufficient $- InputValueInsufficientError- amountAvailable amountRequested- | utxoCount < outputCount =- InputCountInsufficient $- InputCountInsufficientError- utxoCount outputCount- | utxoCount <= inputCountMax =- InputsExhausted- InputsExhaustedError- | otherwise =- InputLimitExceeded $- InputLimitExceededError $- fromIntegral inputCountMax amountAvailable = coinMapValue $ inputsAvailable params- amountRequested =+ amountRequired = coinMapValue $ outputsRequested params- inputCountMax = fromIntegral- $ calculateLimit (limit params)- $ fromIntegral outputCount- outputCount =- fromIntegral $ length $ coinMapToList $ outputsRequested params- outputsDescending =- L.sortOn (Down . entryValue) $ coinMapToList $ outputsRequested params- utxoCount =- fromIntegral $ L.length $ coinMapToList $ inputsAvailable params- utxoDescending =- take (fromIntegral inputCountMax)- $ L.sortOn (Down . entryValue)- $ coinMapToList- $ inputsAvailable params+ coinSelection = CoinSelection+ { inputs =+ inputsSelected+ , outputs =+ outputsRequested params+ , change = filter (> C.zero)+ $ F.toList+ $ coinMapValue inputsSelected `C.sub` amountRequired+ }+ inputsAvailableDescending :: [CoinMapEntry i]+ inputsAvailableDescending = inputsAvailable params+ & coinMapToList+ & L.sortOn (Down . entryValue)+ inputCountMax :: Int+ inputCountMax = outputsRequested params+ & coinMapToList+ & length+ & fromIntegral @Int @Word16+ & calculateLimit (limit params)+ & fromIntegral @Word16 @Int+ inputsSelected :: CoinMap i+ inputsSelected = inputsAvailableDescending+ & fmap entryValue+ & scanl1 (<>)+ & takeUntil (>= amountRequired)+ & zip inputsAvailableDescending+ & fmap fst+ & coinMapFromList+ inputsRemaining :: CoinMap i+ inputsRemaining = inputsAvailableDescending+ & drop (length inputsSelected)+ & coinMapFromList --- | Attempts to pay for a /single transaction output/ by selecting the--- /smallest possible/ number of entries from the /head/ of the given--- UTxO list.------ Returns a /reduced/ list of UTxO entries, and a coin selection that is--- /updated/ to include the payment.------ If the total value of entries in the given UTxO list is /less than/ the--- required output amount, this function will return 'Nothing'.----payForOutput- :: forall i o . (Ord i, Ord o)- => ([CoinMapEntry i], CoinSelection i o)- -> CoinMapEntry o- -> Maybe ([CoinMapEntry i], CoinSelection i o)-payForOutput (utxoAvailable, currentSelection) out =- coverTarget utxoAvailable mempty- where- coverTarget- :: [CoinMapEntry i]- -> [CoinMapEntry i]- -> Maybe ([CoinMapEntry i], CoinSelection i o)- coverTarget utxoRemaining utxoSelected- | valueSelected >= valueTarget = Just- -- We've selected enough to cover the target, so stop here.- ( utxoRemaining- , currentSelection <> CoinSelection- { inputs = coinMapFromList utxoSelected- , outputs = coinMapFromList [out]- , change = filter (> C.zero)- (F.toList $ valueSelected `C.sub` valueTarget)- }- )- | otherwise =- -- We haven't yet selected enough to cover the target, so attempt- -- to select a little more and then continue.- case utxoRemaining of- utxoEntry : utxoRemaining' ->- coverTarget utxoRemaining' (utxoEntry : utxoSelected)- [] ->- -- The UTxO has been exhausted, so stop here.- Nothing- where- valueTarget- = entryValue out- valueSelected- = sumEntries utxoSelected+--------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------- -sumEntries :: [CoinMapEntry a] -> Coin-sumEntries entries = mconcat $ entryValue <$> entries+takeUntil :: (a -> Bool) -> [a] -> [a]+takeUntil p = foldr (\x ys -> x : if p x then [] else ys) []
src/library/Cardano/CoinSelection/Algorithm/Migration.hs view
@@ -33,6 +33,7 @@ , CoinSelectionLimit (..) , coinMapFromList , coinMapToList+ , coinMapValue , sumChange , sumInputs )@@ -42,13 +43,14 @@ , FeeBalancingPolicy (..) , FeeEstimator (..) , FeeOptions (..)+ , isDust ) import Control.Monad.Trans.State ( State, evalState, get, put ) import Data.List.NonEmpty ( NonEmpty ((:|)) ) import Data.Maybe- ( fromMaybe, mapMaybe )+ ( fromMaybe ) import Data.Word ( Word16 ) import GHC.Generics@@ -113,19 +115,20 @@ -- Note that the selection may look a bit weird at first sight as it has -- no outputs (we are paying everything to ourselves!). mkCoinSelection :: [CoinMapEntry i] -> CoinSelection i o- mkCoinSelection inps = CoinSelection- { inputs = coinMapFromList inps- , outputs = mempty- , change =- let chgs = mapMaybe (noDust . entryValue) inps- in if null chgs then [threshold] else chgs- }+ mkCoinSelection inputEntries = CoinSelection {inputs, outputs, change} where- threshold = unDustThreshold dustThreshold- noDust :: Coin -> Maybe Coin- noDust c- | c < threshold = Nothing- | otherwise = Just c+ inputs = coinMapFromList inputEntries+ outputs = mempty+ change+ | null nonDustInputCoins && totalInputValue >= smallestNonDustCoin =+ [smallestNonDustCoin]+ | otherwise =+ nonDustInputCoins+ nonDustInputCoins = filter+ (not . isDust dustThreshold)+ (entryValue <$> inputEntries)+ smallestNonDustCoin = C.succ $ unDustThreshold dustThreshold+ totalInputValue = coinMapValue inputs -- | Attempt to balance the coin selection by reducing or increasing the -- change values based on the computed fees.
src/library/Cardano/CoinSelection/Fee.hs view
@@ -31,6 +31,7 @@ -- * Dust Processing , DustThreshold (..)+ , isDust , coalesceDust -- # Internal Functions@@ -119,6 +120,17 @@ deriving stock (Eq, Generic, Ord) deriving Show via (Quiet DustThreshold) +-- | Returns 'True' if and only if the given 'Coin' is a __dust coin__+-- according to the given 'DustThreshold'.+--+-- A coin is considered to be a dust coin if it is /less than or equal to/+-- the threshold.+--+-- See 'DustThreshold'.+--+isDust :: DustThreshold -> Coin -> Bool+isDust (DustThreshold dt) c = c <= dt+ -- | Provides a function capable of __estimating__ the transaction fee required -- for a given coin selection, according to the rules of a particular -- blockchain.@@ -618,10 +630,10 @@ -- >>> all (/= Coin 0) (coalesceDust threshold coins) -- coalesceDust :: DustThreshold -> NonEmpty Coin -> [Coin]-coalesceDust (DustThreshold threshold) coins =+coalesceDust threshold coins = splitCoin valueToDistribute coinsToKeep where- (coinsToKeep, coinsToRemove) = NE.partition (> threshold) coins+ (coinsToRemove, coinsToKeep) = NE.partition (isDust threshold) coins valueToDistribute = F.fold coinsToRemove -- Splits up the given coin of value __@v@__, distributing its value over the
src/test/Cardano/CoinSelection/Algorithm/LargestFirstSpec.hs view
@@ -1,10 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Cardano.CoinSelection.Algorithm.LargestFirstSpec- ( spec+ ( isValidLargestFirstError+ , spec ) where import Prelude@@ -18,16 +21,16 @@ , CoinSelectionLimit (..) , CoinSelectionParameters (..) , CoinSelectionResult (..)- , InputCountInsufficientError (..) , InputLimitExceededError (..) , InputValueInsufficientError (..)- , InputsExhaustedError (..)+ , coinMapFromList , coinMapToList+ , coinMapValue ) import Cardano.CoinSelection.Algorithm.LargestFirst ( largestFirst ) import Cardano.CoinSelectionSpec- ( CoinSelProp (..)+ ( CoinSelectionData (..) , CoinSelectionFixture (..) , CoinSelectionTestResult (..) , coinSelectionUnitTest@@ -40,22 +43,26 @@ ( runExceptT ) import Data.Either ( isRight )+import Data.Function+ ( (&) ) import Data.Functor.Identity ( Identity (runIdentity) ) import Test.Hspec- ( Spec, describe, it, shouldSatisfy )+ ( Spec, describe, it, shouldBe, shouldSatisfy ) import Test.QuickCheck- ( Property, property, (==>) )+ ( Property, checkCoverage, cover, property, withMaxSuccess, (.&&.), (==>) ) import qualified Data.List as L import qualified Data.Map.Strict as Map import qualified Data.Set as Set+import qualified Internal.Coin as C spec :: Spec spec = do describe "Coin selection: largest-first algorithm: unit tests" $ do - coinSelectionUnitTest largestFirst ""+ coinSelectionUnitTest largestFirst+ "Expect success: case #1" (Right $ CoinSelectionTestResult { rsInputs = [17] , rsChange = []@@ -67,7 +74,8 @@ , txOutputs = [17] }) - coinSelectionUnitTest largestFirst ""+ coinSelectionUnitTest largestFirst+ "Expect success: case #2" (Right $ CoinSelectionTestResult { rsInputs = [17] , rsChange = [16]@@ -79,7 +87,8 @@ , txOutputs = [1] }) - coinSelectionUnitTest largestFirst ""+ coinSelectionUnitTest largestFirst+ "Expect success: case #3" (Right $ CoinSelectionTestResult { rsInputs = [12, 17] , rsChange = [11]@@ -91,7 +100,8 @@ , txOutputs = [18] }) - coinSelectionUnitTest largestFirst ""+ coinSelectionUnitTest largestFirst+ "Expect success: case #4" (Right $ CoinSelectionTestResult { rsInputs = [10, 12, 17] , rsChange = [9]@@ -103,10 +113,11 @@ , txOutputs = [30] }) - coinSelectionUnitTest largestFirst ""+ coinSelectionUnitTest largestFirst+ "Expect success: case #5" (Right $ CoinSelectionTestResult- { rsInputs = [6,10,5]- , rsChange = [5,4]+ { rsInputs = [6,10]+ , rsChange = [4] , rsOutputs = [11,1] }) (CoinSelectionFixture@@ -116,118 +127,165 @@ }) coinSelectionUnitTest largestFirst- "UTxO balance not sufficient"- (Left $ InputValueInsufficient $ InputValueInsufficientError- (unsafeCoin @Int 39) (unsafeCoin @Int 40))+ "Expect success: case #6"+ (Right $ CoinSelectionTestResult+ { rsInputs = [12,17,20]+ , rsChange = [6]+ , rsOutputs = [1,1,1,40]+ }) (CoinSelectionFixture { maxNumOfInputs = 100- , utxoInputs = [12,10,17]- , txOutputs = [40]+ , utxoInputs = [12,20,17]+ , txOutputs = [40,1,1,1] }) coinSelectionUnitTest largestFirst- "UTxO balance not sufficient, and not fragmented enough"- (Left $ InputValueInsufficient $ InputValueInsufficientError- (unsafeCoin @Int 39) (unsafeCoin @Int 43))+ "Expect success: case #7"+ (Right $ CoinSelectionTestResult+ { rsInputs = [12,17,20]+ , rsChange = [8]+ , rsOutputs = [1,40]+ }) (CoinSelectionFixture { maxNumOfInputs = 100- , utxoInputs = [12,10,17]- , txOutputs = [40,1,1,1]+ , utxoInputs = [12,20,17]+ , txOutputs = [40, 1] }) coinSelectionUnitTest largestFirst- "UTxO balance sufficient, but not fragmented enough"- (Left $ InputCountInsufficient $ InputCountInsufficientError 3 4)+ "Expect success: case #8"+ (Right $ CoinSelectionTestResult+ { rsInputs = [10,20,20]+ , rsChange = [3]+ , rsOutputs = [6,41]+ }) (CoinSelectionFixture { maxNumOfInputs = 100- , utxoInputs = [12,20,17]- , txOutputs = [40,1,1,1]+ , utxoInputs = [20,20,10,5]+ , txOutputs = [41, 6] }) coinSelectionUnitTest largestFirst- "UTxO balance sufficient, fragmented enough, but single output \- \depletes all UTxO entries"- (Left (InputsExhausted InputsExhaustedError))+ "Expect success: case #9"+ (Right $ CoinSelectionTestResult+ { rsInputs = [6,10]+ , rsChange = [4]+ , rsOutputs = [1,11]+ }) (CoinSelectionFixture- { maxNumOfInputs = 100- , utxoInputs = [12,20,17]- , txOutputs = [40, 1]+ { maxNumOfInputs = 2+ , utxoInputs = [1,2,10,6,5]+ , txOutputs = [11, 1] }) coinSelectionUnitTest largestFirst- "UTxO balance sufficient, fragmented enough, but single output \- \depletes all UTxO entries"- (Left (InputsExhausted InputsExhaustedError))+ "Expect success: fewer inputs than outputs: case #1"+ (Right $ CoinSelectionTestResult+ { rsInputs = [100]+ , rsOutputs = [1,2,3,4]+ , rsChange = [90]+ }) (CoinSelectionFixture- { maxNumOfInputs = 100- , utxoInputs = [20,20,10,5]- , txOutputs = [41, 6]+ { maxNumOfInputs = 1000+ , utxoInputs = [100,100]+ , txOutputs = [1,2,3,4] }) coinSelectionUnitTest largestFirst- "UTxO balance sufficient, fragmented enough, but maximum input \- \count exceeded"- (Left $ InputLimitExceeded $ InputLimitExceededError 9)+ "Expect success: fewer inputs than outputs: case #2"+ (Right $ CoinSelectionTestResult+ { rsInputs = [100]+ , rsOutputs = [1,2,3,4]+ , rsChange = [90]+ }) (CoinSelectionFixture- { maxNumOfInputs = 9- , utxoInputs = replicate 100 1+ { maxNumOfInputs = 1000+ , utxoInputs = [100,10]+ , txOutputs = [1,2,3,4]+ })++ coinSelectionUnitTest largestFirst+ "Expect success: fewer inputs than outputs: case #3"+ (Right $ CoinSelectionTestResult+ { rsInputs = [10]+ , rsOutputs = [1,2,3,4]+ , rsChange = []+ })+ (CoinSelectionFixture+ { maxNumOfInputs = 1000+ , utxoInputs = [10,10]+ , txOutputs = [1,2,3,4]+ })++ coinSelectionUnitTest largestFirst+ "Expect success: fewer inputs than outputs: case #4"+ (Right $ CoinSelectionTestResult+ { rsInputs = [100]+ , rsOutputs = replicate 100 1+ , rsChange = []+ })+ (CoinSelectionFixture+ { maxNumOfInputs = 1+ , utxoInputs = [100] , txOutputs = replicate 100 1 }) coinSelectionUnitTest largestFirst- "UTxO balance sufficient, fragmented enough, but maximum input \- \count exceeded"- (Left $ InputLimitExceeded $ InputLimitExceededError 9)+ "UTxO balance not sufficient: case #1"+ (Left $ InputValueInsufficient $ InputValueInsufficientError+ (unsafeCoin @Int 39) (unsafeCoin @Int 40)) (CoinSelectionFixture- { maxNumOfInputs = 9- , utxoInputs = replicate 100 1- , txOutputs = replicate 10 10+ { maxNumOfInputs = 100+ , utxoInputs = [12,10,17]+ , txOutputs = [40] }) coinSelectionUnitTest largestFirst- "UTxO balance sufficient, fragmented enough, but maximum input \- \count exceeded"- (Left $ InputLimitExceeded $ InputLimitExceededError 2)+ "UTxO balance not sufficient: case #2"+ (Left $ InputValueInsufficient $ InputValueInsufficientError+ (unsafeCoin @Int 39) (unsafeCoin @Int 43)) (CoinSelectionFixture- { maxNumOfInputs = 2- , utxoInputs = [1,2,10,6,5]- , txOutputs = [11, 1]+ { maxNumOfInputs = 100+ , utxoInputs = [12,10,17]+ , txOutputs = [40,1,1,1] }) + coinSelectionUnitTest largestFirst+ "UTxO balance sufficient, but maximum input count exceeded"+ (Left $ InputLimitExceeded $ InputLimitExceededError 9)+ (CoinSelectionFixture+ { maxNumOfInputs = 9+ , utxoInputs = replicate 100 1+ , txOutputs = replicate 100 1+ })+ describe "Coin selection: largest-first algorithm: properties" $ do - it "forall (UTxO, NonEmpty TxOut), there's at least as many selected \- \inputs as there are requested outputs"- (property $ propAtLeast @TxIn @Address) 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 @TxIn @Address) + it "The algorithm selects just enough inputs and no more."+ (property+ $ withMaxSuccess 10_000+ $ propSelectionMinimal @Int @Int)++ it "The algorithm produces the correct set of change."+ (checkCoverage+ $ property+ $ withMaxSuccess 10_000+ $ propChangeCorrect @Int @Int)+ -------------------------------------------------------------------------------- -- Properties -------------------------------------------------------------------------------- -propAtLeast- :: (Ord i, Ord o)- => CoinSelProp i o- -> Property-propAtLeast (CoinSelProp utxo txOuts) =- isRight selection ==>- let Right (CoinSelectionResult s _) = selection in- prop s- where- prop (CoinSelection inps _ _) =- length inps `shouldSatisfy` (>= length txOuts)- selection = runIdentity $ runExceptT $ selectCoins largestFirst- $ CoinSelectionParameters utxo txOuts selectionLimit- selectionLimit = CoinSelectionLimit $ const 100- propInputDecreasingOrder- :: (Ord i, Ord o)- => CoinSelProp i o+ :: Ord i+ => CoinSelectionData i o -> Property-propInputDecreasingOrder (CoinSelProp utxo txOuts) =+propInputDecreasingOrder (CoinSelectionData utxo txOuts) = isRight selection ==> let Right (CoinSelectionResult s _) = selection in prop s@@ -245,3 +303,73 @@ $ selectCoins largestFirst $ CoinSelectionParameters utxo txOuts selectionLimit selectionLimit = CoinSelectionLimit $ const 100++-- Confirm that a selection is minimal by removing the smallest entry from the+-- inputs and verifying that the reduced input total is no longer enough to pay+-- for the total value of all outputs.+propSelectionMinimal+ :: Ord i => CoinSelectionData i o -> Property+propSelectionMinimal (CoinSelectionData inpsAvailable outsRequested) =+ isRight result ==>+ let Right (CoinSelectionResult selection _) = result in+ prop selection+ where+ prop (CoinSelection inputsSelected _ _) =+ (coinMapValue inputsSelected+ `shouldSatisfy` (>= coinMapValue outsRequested))+ .&&.+ (coinMapValue inputsReduced+ `shouldSatisfy` (< coinMapValue outsRequested))+ where+ -- The set of selected inputs with the smallest entry removed.+ inputsReduced = inputsSelected+ & coinMapToList+ & L.sortOn entryValue+ & L.drop 1+ & coinMapFromList+ result = runIdentity+ $ runExceptT+ $ selectCoins largestFirst+ $ CoinSelectionParameters inpsAvailable outsRequested+ $ CoinSelectionLimit $ const 1000++-- Verify that the algorithm generates the correct set of change.+propChangeCorrect+ :: Ord i => CoinSelectionData i o -> Property+propChangeCorrect (CoinSelectionData inpsAvailable outsRequested) =+ isRight result ==>+ let Right (CoinSelectionResult selection _) = result in+ prop selection+ where+ prop (CoinSelection inpsSelected _ changeGenerated) =+ cover 8 (amountSelected > amountRequired)+ "amountSelected > amountRequired" $+ cover 1 (amountSelected == amountRequired)+ "amountSelected = amountRequired" $+ if amountSelected > amountRequired then+ changeGenerated `shouldBe`+ [amountSelected `C.distance` amountRequired]+ else+ changeGenerated `shouldSatisfy` null+ where+ amountSelected = coinMapValue inpsSelected+ amountRequired = coinMapValue outsRequested+ result = runIdentity+ $ runExceptT+ $ selectCoins largestFirst+ $ CoinSelectionParameters inpsAvailable outsRequested+ $ CoinSelectionLimit $ const 1000++--------------------------------------------------------------------------------+-- Utilities+--------------------------------------------------------------------------------++-- Returns true if (and only if) the given error value is one that can be+-- thrown by the Largest-First algorithm.+--+isValidLargestFirstError :: CoinSelectionError -> Bool+isValidLargestFirstError = \case+ InputLimitExceeded _ -> True+ InputValueInsufficient _ -> True+ InputCountInsufficient _ -> False+ InputsExhausted _ -> False
src/test/Cardano/CoinSelection/Algorithm/MigrationSpec.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -117,27 +118,27 @@ describe "selectCoins properties" $ do it "No coin selection has outputs" $- property $ withMaxSuccess 10000 $ prop_onlyChangeOutputs+ property $ withMaxSuccess 10_000 $ prop_onlyChangeOutputs @(Wrapped TxIn) @Address - it "Every coin in the selection change >= minimum threshold coin" $- property $ withMaxSuccess 10000 $ prop_noLessThanThreshold+ it "Every coin in the selection change > dust threshold" $+ property $ withMaxSuccess 10_000 $ prop_allAboveThreshold @(Wrapped TxIn) @Address it "Total input UTxO value >= sum of selection change coins" $- property $ withMaxSuccess 10000 $ prop_inputsGreaterThanOutputs+ property $ withMaxSuccess 10_000 $ prop_inputsGreaterThanOutputs @(Wrapped TxIn) @Address it "Every selection input is unique" $- property $ withMaxSuccess 10000 $ prop_inputsAreUnique+ property $ withMaxSuccess 10_000 $ prop_inputsAreUnique @(Wrapped TxIn) @Address it "Every selection input is a member of the UTxO" $- property $ withMaxSuccess 10000 $ prop_inputsStillInUTxO+ property $ withMaxSuccess 10_000 $ prop_inputsStillInUTxO @(Wrapped TxIn) @Address it "Every coin selection is well-balanced" $- property $ withMaxSuccess 10000 $ prop_wellBalanced+ property $ withMaxSuccess 10_000 $ prop_wellBalanced @(Wrapped TxIn) @Address describe "selectCoins regressions" $ do@@ -177,18 +178,18 @@ coinMapToList . outputs =<< selectCoins feeOpts batchSize utxo property (allOutputs `shouldSatisfy` null) --- | Every coin in the selection change >= minimum threshold coin-prop_noLessThanThreshold+-- | Every coin in the selection change > dust threshold+prop_allAboveThreshold :: forall i o . (Ord i, Ord o) => FeeOptions i o -> BatchSize -> CoinMap i -> Property-prop_noLessThanThreshold feeOpts batchSize utxo = do+prop_allAboveThreshold feeOpts batchSize utxo = do let allChange = change =<< selectCoins feeOpts batchSize utxo let undersizedCoins =- filter (< threshold) allChange+ filter (<= threshold) allChange property (undersizedCoins `shouldSatisfy` null) where threshold = unDustThreshold $ dustThreshold feeOpts
src/test/Cardano/CoinSelection/Algorithm/RandomImproveSpec.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -23,10 +24,12 @@ ) import Cardano.CoinSelection.Algorithm.LargestFirst ( largestFirst )+import Cardano.CoinSelection.Algorithm.LargestFirstSpec+ ( isValidLargestFirstError ) import Cardano.CoinSelection.Algorithm.RandomImprove ( randomImprove ) import Cardano.CoinSelectionSpec- ( CoinSelProp (..)+ ( CoinSelectionData (..) , CoinSelectionFixture (..) , CoinSelectionTestResult (..) , coinSelectionUnitTest@@ -40,13 +43,13 @@ import Crypto.Random.Types ( withDRG ) import Data.Either- ( isLeft, isRight )+ ( isRight ) import Data.Functor.Identity ( Identity (..) ) import Test.Hspec- ( Spec, before, describe, it, shouldSatisfy )+ ( Spec, before, describe, it, shouldBe, shouldSatisfy ) import Test.QuickCheck- ( Property, property, (===), (==>) )+ ( Property, counterexample, property, (==>) ) import qualified Data.List as L @@ -227,9 +230,9 @@ propFragmentation :: (Ord i, Ord o) => SystemDRG- -> CoinSelProp i o+ -> CoinSelectionData i o -> Property-propFragmentation drg (CoinSelProp utxo txOuts) = do+propFragmentation drg (CoinSelectionData utxo txOuts) = do isRight selection1 && isRight selection2 ==> let Right (CoinSelectionResult s1 _) = selection1 in let Right (CoinSelectionResult s2 _) = selection2 in@@ -242,23 +245,55 @@ selection2 = runIdentity $ runExceptT $ selectCoins largestFirst params selectionLimit = CoinSelectionLimit $ const 100- params = CoinSelectionParameters txOuts utxo selectionLimit+ params = CoinSelectionParameters utxo txOuts selectionLimit propErrors- :: (Ord i, Ord o)+ :: (Ord i, Ord o, Show i, Show o) => SystemDRG- -> CoinSelProp i o+ -> CoinSelectionData i o -> Property-propErrors drg (CoinSelProp utxo txOuts) = do- isLeft selection1 && isLeft selection2 ==>- let (Left s1, Left s2) = (selection1, selection2)- in prop (s1, s2)+propErrors drg (CoinSelectionData utxo txOuts) =+ case resultRandomImprove of+ Right _ ->+ -- Largest-First should always succeed if Random-Improve succeeds.+ counterexample "case: Success"+ $ property+ $ resultLargestFirst `shouldSatisfy` isRight+ Left (InputValueInsufficient _) ->+ -- Largest-First should fail in exactly the same way when the total+ -- value available is insufficient.+ counterexample "case: InputValueInsufficient"+ $ property+ $ resultLargestFirst `shouldBe` resultRandomImprove+ Left (InputCountInsufficient _) ->+ -- Largest-First can still succeed in this case, so just check for+ -- a valid result.+ counterexample "case: InputCountInsufficient"+ $ property+ $ resultLargestFirst `shouldSatisfy` isValidLargestFirstResult+ Left (InputsExhausted _) ->+ -- Largest-First can still succeed in this case, so just check for+ -- a valid result.+ counterexample "case: InputsExhausted"+ $ property+ $ resultLargestFirst `shouldSatisfy` isValidLargestFirstResult+ Left (InputLimitExceeded _) ->+ -- Largest-First can still succeed in this case, so just check for+ -- a valid result.+ counterexample "case: InputLimitExceeded"+ $ property+ $ resultLargestFirst `shouldSatisfy` isValidLargestFirstResult where- prop (err1, err2) =- err1 === err2- (selection1,_) = withDRG drg $+ isValidLargestFirstResult = \case+ Right _ ->+ -- We assume that this is a valid result, based on the assumption+ -- that test coverage for Largest-First is sufficient.+ True+ Left x ->+ isValidLargestFirstError x+ resultRandomImprove = fst $ withDRG drg $ runExceptT $ selectCoins randomImprove params- selection2 = runIdentity $ runExceptT $+ resultLargestFirst = runIdentity $ runExceptT $ selectCoins largestFirst params selectionLimit = CoinSelectionLimit $ const 1- params = CoinSelectionParameters txOuts utxo selectionLimit+ params = CoinSelectionParameters utxo txOuts selectionLimit
src/test/Cardano/CoinSelectionSpec.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}@@ -15,7 +16,7 @@ -- * Export used to test various coin selection implementations , CoinSelectionFixture (..) , CoinSelectionTestResult (..)- , CoinSelProp (..)+ , CoinSelectionData (..) , coinSelectionUnitTest ) where @@ -46,6 +47,8 @@ ( Address (..), Hash (..), ShowFmt (..), TxIn (..), unsafeCoin ) import Control.Arrow ( (&&&) )+import Control.Monad+ ( replicateM ) import Control.Monad.Trans.Except ( runExceptT ) import Data.Function@@ -63,12 +66,11 @@ import Internal.Coin ( Coin, coinToIntegral ) import Test.Hspec- ( Spec, SpecWith, describe, it, shouldBe )+ ( Spec, SpecWith, describe, it, shouldBe, shouldSatisfy ) import Test.QuickCheck ( Arbitrary (..) , Confidence (..) , Gen- , NonEmptyList (..) , Property , arbitraryBoundedIntegral , checkCoverage@@ -82,6 +84,8 @@ , property , scale , vectorOf+ , withMaxSuccess+ , (.&&.) ) import Test.QuickCheck.Monadic ( monadicIO )@@ -125,6 +129,12 @@ checkCoverage $ prop_coinSelection_mappendPreservesTotalValue @Int @Int + describe "CoinSelectionData properties" $ do+ it "CoinSelectionData coverage is adequate" $+ checkCoverage+ $ withMaxSuccess 10_000+ $ prop_CoinSelectionData_coverage @Int @Int+ where lowerConfidence :: Confidence lowerConfidence = Confidence (10^(6 :: Integer)) 0.75@@ -280,21 +290,35 @@ sumChange s1 <> sumChange s2 `shouldBe` sumChange (s1 <> s2) change s1 <> change s2 `shouldBe` change (s1 <> s2) +prop_CoinSelectionData_coverage+ :: CoinSelectionData i o+ -> Property+prop_CoinSelectionData_coverage (CoinSelectionData inps outs) = property+ $ cover 90 (amountAvailable >= amountRequested)+ "amountAvailable ≥ amountRequested"+ $+ (amountAvailable `shouldSatisfy` (> C.zero))+ .&&.+ (amountRequested `shouldSatisfy` (> C.zero))+ where+ amountAvailable = coinMapValue inps+ amountRequested = coinMapValue outs+ -------------------------------------------------------------------------------- -- Coin Selection - Unit Tests -------------------------------------------------------------------------------- --- | Data for running-data CoinSelProp i o = CoinSelProp- { csUtxO :: CoinMap i- -- ^ Available UTxO for the selection- , csOuts :: CoinMap o- -- ^ Requested outputs for the payment+-- | Data for coin selection properties.+data CoinSelectionData i o = CoinSelectionData+ { csdInputsAvailable+ :: CoinMap i+ , csdOutputsRequested+ :: CoinMap o } deriving Show -instance (Buildable i, Buildable o) => Buildable (CoinSelProp i o) where- build (CoinSelProp utxo outs) = mempty- <> nameF "utxo" (blockListF $ coinMapToList utxo)+instance (Buildable i, Buildable o) => Buildable (CoinSelectionData i o) where+ build (CoinSelectionData inps outs) = mempty+ <> nameF "inps" (blockListF $ coinMapToList inps) <> nameF "outs" (blockListF $ coinMapToList outs) -- | A fixture for testing the coin selection@@ -396,14 +420,29 @@ NE.fromList <$> vectorOf n arbitrary instance (Arbitrary i, Arbitrary o, Ord i, Ord o) =>- Arbitrary (CoinSelProp i o)+ Arbitrary (CoinSelectionData i o) where- shrink (CoinSelProp utxo outs) = uncurry CoinSelProp <$> zip- (shrink utxo)+ shrink (CoinSelectionData inps outs) = uncurry CoinSelectionData <$> zip+ (shrink inps) (coinMapFromList <$> filter (not . null) (shrink (coinMapToList outs)))- arbitrary = CoinSelProp- <$> (coinMapFromList . getNonEmpty <$> arbitrary)- <*> (coinMapFromList . getNonEmpty <$> arbitrary)+ arbitrary =+ CoinSelectionData <$> genInps <*> genOuts+ where+ -- Incorporate a bias towards being able to pay for all outputs.+ genInps = genCoinMap 256+ genOuts = genCoinMap 4++ genCoinMap :: forall k . (Arbitrary k, Ord k) => Int -> Gen (CoinMap k)+ genCoinMap maxEntryCount = do+ count <- choose (1, maxEntryCount)+ coinMapFromList <$> replicateM count genCoinMapEntry++ genCoinMapEntry :: forall k . Arbitrary k => Gen (CoinMapEntry k)+ genCoinMapEntry = CoinMapEntry <$> arbitrary <*> genCoin++ -- Generate coins with a reasonably high chance of size collisions.+ genCoin :: Gen Coin+ genCoin = unsafeCoin @Int <$> choose (1, 16) instance Arbitrary Address where shrink _ = []