diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +## [1.0.0] - 2020-04-29 + +Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright © 2019-2020 IOHK + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/cardano-coin-selection.cabal b/cardano-coin-selection.cabal new file mode 100644 --- /dev/null +++ b/cardano-coin-selection.cabal @@ -0,0 +1,103 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: fa91aa04303b2016d424d05014b688d5845de29176adad56b44a698e849d080a + +name: cardano-coin-selection +version: 1.0.0 +synopsis: Algorithms for coin selection and fee balancing. +description: Please see the README on GitHub at +category: Cardano +homepage: https://github.com/input-output-hk/cardano-coin-selection#readme +bug-reports: https://github.com/input-output-hk/cardano-coin-selection/issues +author: IOHK +maintainer: operations@iohk.io +copyright: 2020 IOHK +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +extra-source-files: + ChangeLog.md + +source-repository head + type: git + location: https://github.com/input-output-hk/cardano-coin-selection + +flag release + description: Compile executables for a release. + manual: True + default: False + +library + exposed-modules: + Cardano.CoinSelection + Cardano.CoinSelection.Algorithm + Cardano.CoinSelection.Algorithm.LargestFirst + Cardano.CoinSelection.Algorithm.Migration + Cardano.CoinSelection.Algorithm.RandomImprove + Cardano.CoinSelection.Fee + Internal + Internal.Coin + Internal.Invariant + Internal.Rounding + other-modules: + Paths_cardano_coin_selection + hs-source-dirs: + src/library + src/internal + default-extensions: NoImplicitPrelude + ghc-options: -Wall -Wcompat -fwarn-redundant-constraints + build-depends: + base >=4.7 && <5 + , bytestring + , containers + , cryptonite + , deepseq + , quiet + , text + , transformers + if flag(release) + ghc-options: -Werror + default-language: Haskell2010 + +test-suite unit + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Cardano.CoinSelection.Algorithm.LargestFirstSpec + Cardano.CoinSelection.Algorithm.MigrationSpec + Cardano.CoinSelection.Algorithm.RandomImproveSpec + Cardano.CoinSelection.FeeSpec + Cardano.CoinSelection.TypesSpec + Cardano.CoinSelectionSpec + Cardano.Test.Utilities + Internal.CoinSpec + Test.Vector.Shuffle + Test.Vector.ShuffleSpec + Paths_cardano_coin_selection + hs-source-dirs: + src/test + default-extensions: NoImplicitPrelude + ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , base >=4.7 && <5 + , bytestring + , cardano-coin-selection + , containers + , cryptonite + , deepseq + , fmt + , hspec + , memory + , quiet + , random + , text + , transformers + , vector + if flag(release) + ghc-options: -Werror + default-language: Haskell2010 diff --git a/src/internal/Internal.hs b/src/internal/Internal.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- Copyright: © 2018-2020 IOHK +-- License: Apache-2.0 +-- +-- This module hierarchy provides types and functions that are not intended to +-- be part of the public API. +-- +-- Types and functions defined herein are not guaranteed to be forwards or +-- backwards compatible across different versions of the library. +-- +module Internal + ( module Internal.Invariant + , module Internal.Rounding + ) where + +import Internal.Invariant +import Internal.Rounding diff --git a/src/internal/Internal/Coin.hs b/src/internal/Internal/Coin.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal/Coin.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- Copyright: © 2018-2020 IOHK +-- License: Apache-2.0 +-- +module Internal.Coin + ( + -- * Types + Coin + + -- Construction and Deconstruction + , coinFromIntegral + , coinFromNatural + , coinToIntegral + , coinToNatural + + -- * Unary Operations + , pred + , succ + + -- * Binary Operations + , add + , sub + , mul + , div + , mod + + -- * Calculating Distances + , distance + + -- * Value Tests + , isZero + + -- * Special Values + , zero + , one + + ) where + +import Prelude hiding + ( div, fromIntegral, mod, pred, succ ) + +import GHC.Generics + ( Generic ) +import Numeric.Natural + ( Natural ) +import Quiet + ( Quiet (Quiet) ) + +import qualified Prelude + +-- | Represents a non-negative integral amount of currency. +-- +-- Use 'coinFromNatural' to create a coin from a natural number. +-- +-- Use 'coinToNatural' to convert a coin into a natural number. +-- +-- @since 1.0.0 +newtype Coin = Coin { unCoin :: Natural } + deriving stock (Eq, Generic, Ord) + deriving Show via (Quiet Coin) + +-- | Creates a coin from an integral number. +-- +-- Returns a coin if (and only if) the given input is not negative. +-- +coinFromIntegral :: Integral i => i -> Maybe Coin +coinFromIntegral i + | i >= 0 = Just $ Coin $ Prelude.fromIntegral i + | otherwise = Nothing + +-- | Creates a coin from a natural number. +-- +-- @since 1.0.0 +coinFromNatural :: Natural -> Coin +coinFromNatural = Coin + +-- | Converts the given coin into an integral number. +-- +coinToIntegral :: Integral i => Coin -> i +coinToIntegral (Coin i) = Prelude.fromIntegral i + +-- | Converts the given coin into a natural number. +-- +-- @since 1.0.0 +coinToNatural :: Coin -> Natural +coinToNatural = unCoin + +add :: Coin -> Coin -> Coin +add (Coin x) (Coin y) = Coin $ x + y + +sub :: Coin -> Coin -> Maybe Coin +sub (Coin x) (Coin y) = coinFromIntegral $ toInteger x - toInteger y + +mul :: Integral i => Coin -> i -> Maybe Coin +mul (Coin x) y = coinFromIntegral $ toInteger x * toInteger y + +div :: Integral i => Coin -> i -> Maybe Coin +div (Coin x) y + | y <= 0 = Nothing + | otherwise = coinFromIntegral $ toInteger x `Prelude.div` toInteger y + +mod :: Integral i => Coin -> i -> Maybe Coin +mod (Coin x) y + | y <= 0 = Nothing + | otherwise = coinFromIntegral $ toInteger x `Prelude.mod` toInteger y + +distance :: Coin -> Coin -> Coin +distance (Coin x) (Coin y) + | x >= y = Coin $ x - y + | otherwise = Coin $ y - x + +pred :: Coin -> Maybe Coin +pred x = x `sub` one + +succ :: Coin -> Coin +succ x = x `add` one + +isZero :: Coin -> Bool +isZero = (== zero) + +zero :: Coin +zero = Coin 0 + +one :: Coin +one = Coin 1 + +newtype Sum a = Sum { getSum :: a } + deriving stock (Eq, Generic, Ord) + deriving Show via (Quiet (Sum a)) + +instance Monoid Coin where + mempty = zero + +instance Semigroup Coin where + (<>) = add diff --git a/src/internal/Internal/Invariant.hs b/src/internal/Internal/Invariant.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal/Invariant.hs @@ -0,0 +1,35 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- Copyright: © 2018-2020 IOHK +-- License: Apache-2.0 +-- +-- Provides internal functions relating to verification of invariants. +-- +module Internal.Invariant + ( invariant + ) where + +import Prelude + +-- | Checks whether or not an invariant holds, by applying the given predicate +-- to the given value. +-- +-- If the invariant does not hold (indicated by the predicate function +-- returning 'False'), throws an error with the specified message. +-- +-- >>> invariant "not empty" [1,2,3] (not . null) +-- [1, 2, 3] +-- +-- >>> invariant "not empty" [] (not . null) +-- *** Exception: not empty +invariant + :: String + -- ^ The message + -> a + -- ^ The value to test + -> (a -> Bool) + -- ^ The predicate + -> a +invariant msg a predicate = + if predicate a then a else error msg diff --git a/src/internal/Internal/Rounding.hs b/src/internal/Internal/Rounding.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal/Rounding.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- Copyright: © 2018-2020 IOHK +-- License: Apache-2.0 +-- +-- Provides internal types and functions relating to rounding of fractional +-- numbers. +-- +module Internal.Rounding + ( RoundingDirection (..) + , round + ) where + +import Prelude hiding + ( round ) + +-- | Indicates a rounding direction to be used when converting from a +-- fractional value to an integral value. +-- +-- See 'round'. +-- +data RoundingDirection + = RoundUp + -- ^ Round up to the nearest integral value. + | RoundDown + -- ^ Round down to the nearest integral value. + deriving (Eq, Show) + +-- | Use the given rounding direction to round the given fractional value, +-- producing an integral result. +-- +round :: (RealFrac a, Integral b) => RoundingDirection -> a -> b +round = \case + RoundUp -> ceiling + RoundDown -> floor diff --git a/src/library/Cardano/CoinSelection.hs b/src/library/Cardano/CoinSelection.hs new file mode 100644 --- /dev/null +++ b/src/library/Cardano/CoinSelection.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RankNTypes #-} + +{-# OPTIONS_HADDOCK prune #-} + +-- | +-- Copyright: © 2018-2020 IOHK +-- License: Apache-2.0 +-- +-- Provides general functions and types relating to coin selection. +-- +-- The 'CoinSelection' type represents a __coin selection__, the basis for a +-- /transaction/ in a UTxO-based blockchain. +-- +-- The 'CoinSelectionAlgorithm' type provides a __common interface__ to +-- algorithms that generate coin selections. +-- +-- For a guide to __algorithms provided by this library__, see the +-- "Cardano.CoinSelection.Algorithm" module. +-- +-- To adjust coin selections in order to __pay for transaction fees__, see +-- the "Cardano.CoinSelection.Fee" module. +-- +module Cardano.CoinSelection + ( + -- * Coin Selections + CoinSelection (..) + , sumInputs + , sumOutputs + , sumChange + + -- * Coin Selection Algorithms + , CoinSelectionAlgorithm (..) + , CoinSelectionParameters (..) + , CoinSelectionResult (..) + , CoinSelectionLimit (..) + + -- * Coins + , Coin + , coinFromNatural + , coinToNatural + + -- * Coin Maps + , CoinMap (..) + , CoinMapEntry (..) + , coinMapFromList + , coinMapToList + , coinMapValue + + -- * Coin Selection Errors + , CoinSelectionError (..) + , InputValueInsufficientError (..) + , InputCountInsufficientError (..) + , InputLimitExceededError (..) + , InputsExhaustedError (..) + + -- # Internal Functions + , coinMapRandomEntry + + ) where + +import Prelude + +import Control.Arrow + ( (&&&) ) +import Control.Monad.Trans.Except + ( ExceptT (..) ) +import Crypto.Number.Generate + ( generateBetween ) +import Crypto.Random.Types + ( MonadRandom ) +import Data.Map.Strict + ( Map ) +import Data.Word + ( Word16 ) +import GHC.Generics + ( Generic ) +import Internal.Coin + ( Coin, coinFromNatural, coinToNatural ) +import Numeric.Natural + ( Natural ) +import Quiet + ( Quiet (Quiet) ) + +import qualified Data.Foldable as F +import qualified Data.Map.Strict as Map + +-------------------------------------------------------------------------------- +-- Coin Map +-------------------------------------------------------------------------------- + +-- | A mapping from unique keys to associated 'Coin' values. +-- +-- A 'CoinMap' can be used to represent: +-- +-- * a UTxO set, where each key within the map refers to an unspent output +-- from a previous transaction. +-- +-- * a set of 'inputs' to a 'CoinSelection', where each input is an entry +-- selected from a UTxO set by a 'CoinSelectionAlgorithm'. +-- +-- * a set of 'outputs' for a 'CoinSelection', where each key within the map +-- refers to the address of a payment recipient. +-- +-- A 'CoinMap' can be constructed with the 'coinMapFromList' function. +-- +-- The total value of a 'CoinMap' is given by the 'coinMapValue' function. +-- +-- @since 1.0.0 +newtype CoinMap a = CoinMap { unCoinMap :: Map a Coin } + deriving (Eq, Generic) + deriving Show via (Quiet (CoinMap a)) + +instance Foldable CoinMap where + foldMap f = F.fold . fmap (f . entryKey) . coinMapToList + +instance Ord a => Monoid (CoinMap a) where + mempty = CoinMap mempty + +instance Ord a => Semigroup (CoinMap a) where + CoinMap a <> CoinMap b = CoinMap $ Map.unionWith (<>) a b + +-- | An entry for a 'CoinMap'. +-- +-- @since 1.0.0 +data CoinMapEntry a = CoinMapEntry + { entryKey + :: a + -- ^ The unique key associated with this entry. + , entryValue + :: Coin + -- ^ The coin value associated with this entry. + } deriving (Eq, Generic, Ord, Show) + +-- | Constructs a 'CoinMap' from a list of entries. +-- +-- See 'CoinMapEntry'. +-- +-- @since 1.0.0 +coinMapFromList :: Ord a => [CoinMapEntry a] -> CoinMap a +coinMapFromList = CoinMap + . Map.fromListWith (<>) + . fmap (entryKey &&& entryValue) + +-- | Converts a 'CoinMap' to a list of entries. +-- +-- See 'CoinMapEntry'. +-- +-- @since 1.0.0 +coinMapToList :: CoinMap a -> [CoinMapEntry a] +coinMapToList = fmap (uncurry CoinMapEntry) . Map.toList . unCoinMap + +-- | Calculates the total coin value associated with a 'CoinMap'. +-- +-- @since 1.0.0 +coinMapValue :: CoinMap a -> Coin +coinMapValue = mconcat . fmap entryValue . coinMapToList + +-------------------------------------------------------------------------------- +-- Coin Selection +-------------------------------------------------------------------------------- + +-- | Provides a __common interface__ for coin selection algorithms. +-- +-- The function 'selectCoins', when applied to the given +-- 'CoinSelectionParameters' object (with /available inputs/ and /requested/ +-- /outputs/), will generate a 'CoinSelectionResult' (with /remaining inputs/ +-- and a /coin selection/). +-- +-- For implementations provided by this library, see +-- "Cardano.CoinSelection.Algorithm". +-- +-- @since 1.0.0 +newtype CoinSelectionAlgorithm i o m = CoinSelectionAlgorithm + { selectCoins + :: CoinSelectionParameters i o + -> ExceptT CoinSelectionError m (CoinSelectionResult i o) + } + +-- | The complete set of parameters required for a 'CoinSelectionAlgorithm'. +-- +-- The 'inputsAvailable' and 'outputsRequested' fields are both maps of unique +-- keys to associated 'Coin' values, where: +-- +-- * Each key-value pair in the 'inputsAvailable' map corresponds to an +-- __unspent output__ from a previous transaction that is /available/ +-- /for selection as an input/ by the coin selection algorithm. The /key/ +-- is a unique reference to that output, and the /value/ is the amount of +-- unspent value associated with it. +-- +-- * Each key-value pair in the 'outputsRequested' map corresponds to a +-- __payment__ whose value is /to be paid for/ by the coin selection +-- algorithm. The /key/ is a unique reference to a payment recipient, +-- and the /value/ is the amount of money to pay to that recipient. +-- +-- A coin selection algorithm will select a __subset__ of inputs from +-- 'inputsAvailable' in order to pay for __all__ the outputs in +-- 'outputsRequested', where: +-- +-- * Inputs __selected__ by the algorithm are included in the 'inputs' +-- set of the generated 'CoinSelection'. +-- +-- * Inputs __not__ selected by the algorithm are included in the +-- 'inputsRemaining' set of the 'CoinSelectionResult'. +-- +-- The number of inputs that can selected is limited by 'limit'. +-- +-- The total value of 'inputsAvailable' must be /greater than or equal to/ +-- the total value of 'outputsRequested', as given by the 'coinMapValue' +-- function. +-- +-- @since 1.0.0 +data CoinSelectionParameters i o = CoinSelectionParameters + { inputsAvailable :: CoinMap i + -- ^ The set of inputs available for selection. + , outputsRequested :: CoinMap o + -- ^ The set of outputs requested for payment. + , limit :: CoinSelectionLimit + -- ^ A limit on the number of inputs that can be selected. + } + deriving Generic + +-- | Represents the __result__ of running a coin selection algorithm. +-- +-- See 'CoinSelectionAlgorithm'. +-- +-- @since 1.0.0 +data CoinSelectionResult i o = CoinSelectionResult + { coinSelection :: CoinSelection i o + -- ^ The generated coin selection. + , inputsRemaining :: CoinMap i + -- ^ The set of inputs that were __not__ selected. + } + +-- | A __coin selection__ is the basis for a /transaction/. +-- +-- It consists of a selection of 'inputs', 'outputs', and 'change'. +-- +-- The 'inputs' and 'outputs' fields are both maps of unique keys to associated +-- 'Coin' values, where: +-- +-- * Each key-value pair in the 'inputs' map corresponds to an +-- __unspent output__ from a previous transaction (also known as a UTxO). +-- The /key/ is a unique reference to that output, and the /value/ is the +-- amount of unspent value associated with it. +-- +-- * Each key-value pair in the 'outputs' map corresponds to a __payment__. +-- The /key/ is a unique reference to a payment recipient, and the /value/ +-- is the amount of money to pay to that recipient. +-- +-- The 'change' field is a set of coins to be returned to the originator of the +-- transaction. +-- +-- The 'CoinSelectionAlgorithm' type provides a common interface for generating +-- coin selections. +-- +-- @since 1.0.0 +data CoinSelection i o = CoinSelection + { inputs :: CoinMap i + -- ^ The set of inputs. + , outputs :: CoinMap o + -- ^ The set of outputs. + , change :: [Coin] + -- ^ The set of change. + } + deriving (Generic, Show, Eq) + +instance (Ord i, Ord o) => Semigroup (CoinSelection i o) where + a <> b = CoinSelection + { inputs = inputs a <> inputs b + , outputs = outputs a <> outputs b + , change = change a <> change b + } + +instance (Ord i, Ord o) => Monoid (CoinSelection i o) where + mempty = CoinSelection mempty mempty mempty + +-- | Calculate the total sum of all 'inputs' for the given 'CoinSelection'. +-- +-- @since 1.0.0 +sumInputs :: CoinSelection i o -> Coin +sumInputs = coinMapValue . inputs + +-- | Calculate the total sum of all 'outputs' for the given 'CoinSelection'. +-- +-- @since 1.0.0 +sumOutputs :: CoinSelection i o -> Coin +sumOutputs = coinMapValue . outputs + +-- | Calculate the total sum of all 'change' for the given 'CoinSelection'. +-- +-- @since 1.0.0 +sumChange :: CoinSelection i o -> Coin +sumChange = mconcat . change + +-- | Defines an __inclusive upper bound__ on the /number/ of inputs that +-- a 'CoinSelectionAlgorithm' is allowed to select. +-- +-- @since 1.0.0 +newtype CoinSelectionLimit = CoinSelectionLimit + { calculateLimit + :: Word16 -> Word16 + -- ^ Calculate the maximum number of inputs allowed for a given + -- number of outputs. + } deriving Generic + +-- | Represents the set of possible failures that can occur when attempting +-- to produce a 'CoinSelection' with a 'CoinSelectionAlgorithm'. +-- +-- See 'selectCoins'. +-- +-- @since 1.0.0 +data CoinSelectionError + = InputValueInsufficient + InputValueInsufficientError + | InputCountInsufficient + InputCountInsufficientError + | InputLimitExceeded + InputLimitExceededError + | InputsExhausted + InputsExhaustedError + deriving (Eq, Show) + +-- | Indicates that the total value of 'inputsAvailable' is less than the total +-- value of 'outputsRequested', making it /impossible/ to cover all payments, +-- /regardless/ of which algorithm is chosen. +-- +-- @since 1.0.0 +data InputValueInsufficientError = + InputValueInsufficientError + { inputValueAvailable :: Coin + -- ^ The total value of 'inputsAvailable'. + , inputValueRequired :: Coin + -- ^ The total value of 'outputsRequested'. + } + deriving (Eq, Show) + +-- | Indicates that the total count of entries in 'inputsAvailable' is /fewer/ +-- /than/ required by the algorithm. The number required depends on the +-- particular algorithm implementation. +-- +-- @since 1.0.0 +data InputCountInsufficientError = + InputCountInsufficientError + { inputCountAvailable :: Natural + -- ^ The number of entries in 'inputsAvailable'. + , inputCountRequired :: Natural + -- ^ The number of entries required. + } + deriving (Eq, Show) + +-- | Indicates that all available entries in 'inputsAvailable' were depleted +-- /before/ all the payments in 'outputsRequested' could be paid for. +-- +-- This condition can occur /even if/ the total value of 'inputsAvailable' is +-- greater than or equal to the total value of 'outputsRequested', due to +-- differences in the way that algorithms select inputs. +-- +-- @since 1.0.0 +data InputsExhaustedError = + InputsExhaustedError + deriving (Eq, Show) + +-- | Indicates that the coin selection algorithm is unable to cover the total +-- value of 'outputsRequested' without exceeding the maximum number of inputs +-- defined by 'limit'. +-- +-- See 'calculateLimit'. +-- +-- @since 1.0.0 +newtype InputLimitExceededError = + InputLimitExceededError + { calculatedInputLimit :: Word16 } + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- Internal Functions +-------------------------------------------------------------------------------- + +-- Selects an entry at random from a 'CoinMap', returning both the selected +-- entry and the map with the entry removed. +-- +-- If the given map is empty, this function returns 'Nothing'. +-- +coinMapRandomEntry + :: MonadRandom m + => CoinMap a + -> m (Maybe (CoinMapEntry a), CoinMap a) +coinMapRandomEntry (CoinMap m) + | Map.null m = + return (Nothing, CoinMap m) + | otherwise = do + ix <- fromEnum <$> generateBetween 0 (toEnum (Map.size m - 1)) + let entry = uncurry CoinMapEntry $ Map.elemAt ix m + let remainder = CoinMap $ Map.deleteAt ix m + return (Just entry, remainder) diff --git a/src/library/Cardano/CoinSelection/Algorithm.hs b/src/library/Cardano/CoinSelection/Algorithm.hs new file mode 100644 --- /dev/null +++ b/src/library/Cardano/CoinSelection/Algorithm.hs @@ -0,0 +1,57 @@ +-- | +-- Copyright: © 2018-2020 IOHK +-- License: Apache-2.0 +-- +-- __Submodules__ of this module provide implementations of +-- __coin selection algorithms__. +-- +-- Algorithms can be divided into two categories: +-- +-- * <#generalized-algorithms Generalized Algorithms> +-- +-- Algorithms that implement the general +-- 'Cardano.CoinSelection.CoinSelectionAlgorithm' interface. +-- +-- * <#specialized-algorithms Specialized Algorithms> +-- +-- Algorithms that provide functionality suited to specialized purposes. +-- +-- = Generalized Algorithms #generalized-algorithms# +-- +-- The following algorithms implement the general +-- 'Cardano.CoinSelection.CoinSelectionAlgorithm' interface: +-- +-- * __"Cardano.CoinSelection.Algorithm.LargestFirst"__ +-- +-- Provides an implementation of the __Largest-First__ algorithm. +-- +-- When selecting inputs from a given set of UTxO entries, this +-- algorithm always selects the /largest/ entries /first/. +-- +-- * __"Cardano.CoinSelection.Algorithm.RandomImprove"__ +-- +-- Provides an implementation of the __Random-Improve__ algorithm. +-- +-- When selecting inputs from a given set of UTxO entries, this +-- algorithm always selects entries at /random/. +-- +-- Once selections have been made, a second phase attempts to /improve/ +-- on each of the existing selections in order to optimize change +-- outputs. +-- +-- For __guidance on choosing an algorithm__ that's appropriate for your +-- scenario, please consult the following article: +-- +-- +-- +-- = Specialized Algorithms #specialized-algorithms# +-- +-- The following algorithms provide functionality suited to specialized +-- purposes: +-- +-- * __"Cardano.CoinSelection.Algorithm.Migration"__ +-- +-- Provides an algorithm for migrating all funds from one wallet to +-- another. +-- +module Cardano.CoinSelection.Algorithm where diff --git a/src/library/Cardano/CoinSelection/Algorithm/LargestFirst.hs b/src/library/Cardano/CoinSelection/Algorithm/LargestFirst.hs new file mode 100644 --- /dev/null +++ b/src/library/Cardano/CoinSelection/Algorithm/LargestFirst.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Copyright: © 2018-2020 IOHK +-- License: Apache-2.0 +-- +-- This module contains an implementation of the __Largest-First__ coin +-- selection algorithm. +-- +module Cardano.CoinSelection.Algorithm.LargestFirst ( + largestFirst + ) where + +import Prelude + +import Cardano.CoinSelection + ( 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.Ord + ( Down (..) ) +import Internal.Coin + ( Coin ) + +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Internal.Coin as C + +-- | 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. +-- +-- Otherwise, return to /Step 1/. +-- +-- = Termination +-- +-- 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). +-- +-- The /accumulated coin selection/ and /remaining UTxO list/ are returned to +-- the caller. +-- +-- === 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 +-- 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'. +-- +-- See: __'InputLimitExceededError'__. +-- +-- @since 1.0.0 +largestFirst + :: (Ord i, Ord o, Monad m) + => CoinSelectionAlgorithm i o m +largestFirst = CoinSelectionAlgorithm payForOutputs + +payForOutputs + :: (Ord i, Ord o, 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 + 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 = + 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 + +-- | 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 + +sumEntries :: [CoinMapEntry a] -> Coin +sumEntries entries = mconcat $ entryValue <$> entries diff --git a/src/library/Cardano/CoinSelection/Algorithm/Migration.hs b/src/library/Cardano/CoinSelection/Algorithm/Migration.hs new file mode 100644 --- /dev/null +++ b/src/library/Cardano/CoinSelection/Algorithm/Migration.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_HADDOCK prune #-} + +-- | +-- Copyright: © 2018-2020 IOHK +-- License: Apache-2.0 +-- +-- This module contains an algorithm for migrating all funds from one wallet +-- to another. +-- +-- See 'selectCoins'. +-- +module Cardano.CoinSelection.Algorithm.Migration + ( + -- * Coin Selection for Migration + selectCoins + , BatchSize (..) + , idealBatchSize + ) where + +import Prelude + +import Cardano.CoinSelection + ( CoinMap + , CoinMapEntry (..) + , CoinSelection (..) + , CoinSelectionLimit (..) + , coinMapFromList + , coinMapToList + , sumChange + , sumInputs + ) +import Cardano.CoinSelection.Fee + ( DustThreshold (..) + , Fee (..) + , FeeBalancingPolicy (..) + , FeeEstimator (..) + , FeeOptions (..) + ) +import Control.Monad.Trans.State + ( State, evalState, get, put ) +import Data.List.NonEmpty + ( NonEmpty ((:|)) ) +import Data.Maybe + ( fromMaybe, mapMaybe ) +import Data.Word + ( Word16 ) +import GHC.Generics + ( Generic ) +import Internal.Coin + ( Coin, coinFromIntegral, coinToIntegral ) + +import qualified Internal.Coin as C + +-------------------------------------------------------------------------------- +-- Coin Selection for Migration +-------------------------------------------------------------------------------- + +-- | Creates a __series__ of coin selections that, when published as +-- transactions, will have the effect of migrating all funds from one +-- wallet to another. +-- +-- Since UTxO-based blockchains typically impose limits on the sizes of +-- individual transactions, and since individual UTxO sets can contain +-- /arbitrarily/ many entries, migrating all funds from one wallet to another +-- may require the creation of /several/ transactions. +-- +-- This function therefore /partitions/ the given set of inputs into multiple +-- /batches/ of up to __/b/__ inputs, where __/b/__ is specified by the given +-- 'BatchSize' parameter. (See 'idealBatchSize' for an automatic way to +-- calculate a suitable batch size.) +-- +-- For each batch of inputs, this function creates a separate 'CoinSelection' +-- with the given 'inputs' /and/ a generated 'change' set, where the 'change' +-- set represents the value to be transferred to the target wallet, carefully +-- adjusted to deduct a fee in accordance with the given 'FeeOptions' +-- parameter. The set of 'outputs' for each coin selection is /purposefully/ +-- left empty, as /all/ value is captured in the 'change' set. +-- +-- @since 1.0.0 +selectCoins + :: forall i o . (Ord i, Ord o) + => FeeOptions i o + -- ^ The fee options. + -> BatchSize + -- ^ The maximum number of inputs to include in each selection. + -> CoinMap i + -- ^ The UTxO set to migrate. + -> [CoinSelection i o] +selectCoins options (BatchSize batchSize) utxo = + evalState migrate (coinMapToList utxo) + where + FeeOptions {dustThreshold, feeEstimator, feeBalancingPolicy} = options + + migrate :: State [CoinMapEntry i] [CoinSelection i o] + migrate = do + batch <- getNextBatch + if null batch then + pure [] + else case adjustForFee (mkCoinSelection batch) of + Nothing -> pure [] + Just coinSel -> do + rest <- migrate + pure (coinSel:rest) + + -- Construct a provisional 'CoinSelection' from the given selected inputs. + -- 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 + } + where + threshold = unDustThreshold dustThreshold + noDust :: Coin -> Maybe Coin + noDust c + | c < threshold = Nothing + | otherwise = Just c + + -- | Attempt to balance the coin selection by reducing or increasing the + -- change values based on the computed fees. + adjustForFee :: CoinSelection i o -> Maybe (CoinSelection i o) + adjustForFee !coinSel = case change coinSel of + -- If there's no change, nothing to adjust + [] -> Nothing + + -- No difference between required and computed, we're done + (_ : _) | diff == 0 -> Just coinSel + + -- Otherwise, we have 2 cases: + -- + -- 1/ diff < 0 + -- We aren't giving enough as fee, so we need to reduce one output. + -- + -- 2/ diff > 0 + -- We have some surplus so we add it to an arbitrary output + -- + -- If both cases we can simply modify one output by adding `diff`, the + -- sign of `diff` making for the right modification. + -- We then recursively call ourselves for this might reduce the number + -- of outputs and change the fee. + (c : cs) -> do + let coinSel' = coinSel + { change = modifyFirst (c :| cs) (applyDiff diff) } + let costOfSurplus + = fromIntegral + $ C.coinToNatural + $ C.distance + (unFee $ estimateFee feeEstimator coinSel') + (unFee $ estimateFee feeEstimator coinSel ) + if + -- Adding the change costs less than not having it, so it's + -- worth trying. + | costOfSurplus < actualFee -> + adjustForFee coinSel' + + -- Adding the change costs more than not having it, If we don't + -- require strict balancing, we can leave the selection as-is. + | feeBalancingPolicy == RequireMinimalFee -> + pure coinSel + + -- Adding the change costs more than not having it. So, + -- depending on our balancing policy, we may stop the balancing + -- right here, or, if we must balance the selection discard the + -- whole selection: it can't be balanced with this algorithm. + -- + -- Note that this last extreme case is reached when using an + -- unstable fee policy (where values of outputs can influence + -- the policy) AND, require transactions to be 100% balanced. + -- This is a silly thing to do. + | otherwise -> + Nothing + where + applyDiff :: Integer -> Coin -> Coin + applyDiff i c + = fromMaybe C.zero + $ coinFromIntegral (i + coinToIntegral c) + + diff :: Integer + diff = actualFee - requiredFee + where + requiredFee + = coinToIntegral $ unFee + $ estimateFee feeEstimator coinSel + + actualFee :: Integer + actualFee + = coinToIntegral (sumInputs coinSel) + - coinToIntegral (sumChange coinSel) + + -- | Apply the given function to the first coin of the list. If the + -- operation makes the 'Coin' smaller than the dust threshold, the coin is + -- discarded. + modifyFirst :: NonEmpty Coin -> (Coin -> Coin) -> [Coin] + modifyFirst (c :| cs) op + | c' <= threshold = cs + | otherwise = c' : cs + where + c' = op c + threshold = unDustThreshold dustThreshold + + getNextBatch :: State [a] [a] + getNextBatch = do + xs <- get + let (batch, rest) = splitAt (fromIntegral batchSize) xs + put rest + pure batch + +-- | An upper limit for the number of 'inputs' to include in each coin selection +-- generated by 'selectCoins'. +-- +-- @since 1.0.0 +newtype BatchSize = BatchSize Word16 + deriving (Eq, Generic, Ord, Show) + +-- | Calculate an ideal batch size based on the given coin selection limit. +-- +-- @since 1.0.0 +idealBatchSize :: CoinSelectionLimit -> BatchSize +idealBatchSize coinselOpts = BatchSize $ fixPoint 1 + where + fixPoint :: Word16 -> Word16 + fixPoint !n + | maxN n <= n = n + | n == maxBound = n + | otherwise = fixPoint (n + 1) + where + maxN :: Word16 -> Word16 + maxN = calculateLimit coinselOpts diff --git a/src/library/Cardano/CoinSelection/Algorithm/RandomImprove.hs b/src/library/Cardano/CoinSelection/Algorithm/RandomImprove.hs new file mode 100644 --- /dev/null +++ b/src/library/Cardano/CoinSelection/Algorithm/RandomImprove.hs @@ -0,0 +1,421 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Copyright: © 2018-2020 IOHK +-- License: Apache-2.0 +-- +-- This module contains an implementation of the __Random-Improve__ coin +-- selection algorithm. +-- +module Cardano.CoinSelection.Algorithm.RandomImprove + ( randomImprove + ) where + +import Prelude + +import Cardano.CoinSelection + ( CoinMap (..) + , CoinMapEntry (..) + , CoinSelection (..) + , CoinSelectionAlgorithm (..) + , CoinSelectionError (..) + , CoinSelectionLimit (..) + , CoinSelectionParameters (..) + , CoinSelectionResult (..) + , InputCountInsufficientError (..) + , InputLimitExceededError (..) + , InputValueInsufficientError (..) + , InputsExhaustedError (..) + , coinMapFromList + , coinMapRandomEntry + , coinMapToList + , coinMapValue + ) +import Control.Monad + ( foldM ) +import Control.Monad.Trans.Class + ( lift ) +import Control.Monad.Trans.Except + ( ExceptT (..), throwE ) +import Control.Monad.Trans.Maybe + ( MaybeT (..), runMaybeT ) +import Crypto.Random.Types + ( MonadRandom ) +import Data.Ord + ( Down (..) ) +import Internal.Coin + ( Coin ) + +import qualified Data.List as L +import qualified Internal.Coin as C + +-- | An implementation of the __Random-Improve__ coin selection algorithm. +-- +-- = Overview +-- +-- The __Random-Improve__ coin selection algorithm works in __two phases__, by +-- /first/ selecting UTxO entries /at random/ to pay for each of the given +-- outputs, and /then/ attempting to /improve/ upon each of the selections. +-- +-- === Phase 1: Random Selection +-- +-- __In this phase, the algorithm randomly selects a minimal set of UTxO__ +-- __entries to pay for each of the given outputs.__ +-- +-- During this phase, the algorithm: +-- +-- * processes outputs in /descending order of coin value/. +-- +-- * maintains a /remaining UTxO set/, initially equal to the given +-- /UTxO set/ parameter. +-- +-- For each output of value __/v/__, the algorithm /randomly/ selects entries +-- from the /remaining UTxO set/, until the total value of selected entries is +-- greater than or equal to __/v/__. The selected entries are then associated +-- with that output, and removed from the /remaining UTxO set/. +-- +-- This phase ends when every output has been associated with a selection of +-- UTxO entries. +-- +-- However, if the remaining UTxO set is completely exhausted before all +-- outputs can be processed, the algorithm terminates with an error. +-- +-- === Phase 2: Improvement +-- +-- __In this phase, the algorithm attempts to improve upon each of the UTxO__ +-- __selections made in the previous phase, by conservatively expanding the__ +-- __selection made for each output.__ +-- +-- During this phase, the algorithm: +-- +-- * processes outputs in /ascending order of coin value/. +-- +-- * continues to maintain the /remaining UTxO set/ produced by the previous +-- phase. +-- +-- * maintains an /accumulated coin selection/, which is initially /empty/. +-- +-- For each output of value __/v/__, the algorithm: +-- +-- 1. __Calculates a /target range/__ for the total value of inputs used to +-- pay for that output, defined by the triplet: +-- +-- (/minimum/, /ideal/, /maximum/) = (/v/, /2v/, /3v/) +-- +-- 2. __Attempts to /improve/ upon the /existing UTxO selection/__ for that +-- output, by repeatedly selecting additional entries at random from the +-- /remaining UTxO set/, stopping when the selection can be improved upon +-- no further. +-- +-- A selection with value /v1/ is considered to be an /improvement/ over a +-- selection with value /v0/ if __all__ of the following conditions are +-- satisfied: +-- +-- * __Condition 1__: we have moved closer to the /ideal/ value: +-- +-- abs (/ideal/ − /v1/) < abs (/ideal/ − /v0/) +-- +-- * __Condition 2__: we have not exceeded the /maximum/ value: +-- +-- /v1/ ≤ /maximum/ +-- +-- * __Condition 3__: when counting cumulatively across all outputs +-- considered so far, we have not selected more than the /maximum/ number +-- of UTxO entries specified by 'limit'. +-- +-- 3. __Creates a /change value/__ for the output, equal to the total value +-- of the /final UTxO selection/ for that output minus the value /v/ of +-- that output. +-- +-- 4. __Updates the /accumulated coin selection/__: +-- +-- * Adds the /output/ to 'outputs'. +-- * Adds the /improved UTxO selection/ to 'inputs'. +-- * Adds the /change value/ to 'change'. +-- +-- This phase ends when every output has been processed, __or__ when the +-- /remaining UTxO set/ has been exhausted, whichever occurs sooner. +-- +-- = Termination +-- +-- When both phases are complete, the algorithm terminates. +-- +-- The /accumulated coin selection/ and /remaining UTxO set/ are returned to +-- the caller. +-- +-- === 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 +-- 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'. +-- +-- See: __'InputLimitExceededError'__. +-- +-- = Motivating Principles +-- +-- There are several motivating principles behind the design of the algorithm. +-- +-- === Principle 1: Dust Management +-- +-- The probability that random selection will choose dust entries from a UTxO +-- set increases with the proportion of dust in the set. +-- +-- Therefore, for a UTxO set with a large amount of dust, there's a high +-- probability that a random subset will include a large amount of dust. +-- +-- === Principle 2: Change Management +-- +-- Ideally, coin selection algorithms should, over time, create a UTxO set that +-- has /useful/ outputs: outputs that will allow us to process future payments +-- with a minimum number of inputs. +-- +-- If for each payment request of value __/v/__ we create a change output of +-- /roughly/ the same value __/v/__, then we will end up with a distribution of +-- change values that matches the typical value distribution of payment +-- requests. +-- +-- === Principle 3: Performance Management +-- +-- Searching the UTxO set for additional entries to improve our change outputs +-- is /only/ useful if the UTxO set contains entries that are sufficiently +-- small enough. But it is precisely when the UTxO set contains many small +-- entries that it is less likely for a randomly-chosen UTxO entry to push the +-- total above the upper bound. +-- +-- @since 1.0.0 +randomImprove + :: (Ord i, Ord o, MonadRandom m) + => CoinSelectionAlgorithm i o m +randomImprove = CoinSelectionAlgorithm payForOutputs + +payForOutputs + :: (Ord i, Ord o, MonadRandom m) + => CoinSelectionParameters i o + -> ExceptT CoinSelectionError m (CoinSelectionResult i o) +payForOutputs params = do + mRandomSelections <- lift $ runMaybeT $ foldM makeRandomSelection + (inputCountMax, inputsAvailable params, []) outputsDescending + case mRandomSelections of + Just (inputCountRemaining, utxoRemaining, randomSelections) -> do + (_, finalSelection, utxoRemaining') <- lift $ foldM + improveSelection + (inputCountRemaining, mempty, utxoRemaining) + (reverse randomSelections) + pure $ CoinSelectionResult finalSelection utxoRemaining' + Nothing -> + throwE errorCondition + where + errorCondition + | amountAvailable < amountRequested = + InputValueInsufficient $ + InputValueInsufficientError + amountAvailable amountRequested + | utxoCount < outputCount = + InputCountInsufficient $ + InputCountInsufficientError + utxoCount outputCount + | utxoCount <= fromIntegral inputCountMax = + InputsExhausted + InputsExhaustedError + | otherwise = + InputLimitExceeded $ + InputLimitExceededError $ + fromIntegral inputCountMax + amountAvailable = + coinMapValue $ inputsAvailable params + amountRequested = + 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 + +-- | Randomly select entries from the given UTxO set, until the total value of +-- selected entries is greater than or equal to the given output value. +-- +-- Once a random selection has been made that meets the above criterion, this +-- function returns that selection as is, making no attempt to improve upon +-- the selection in any way. +-- +makeRandomSelection + :: forall i o m . MonadRandom m + => (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)]) + -> CoinMapEntry o + -> MaybeT m (Integer, CoinMap i, [([CoinMapEntry i], CoinMapEntry o)]) +makeRandomSelection + (inputCountRemaining, utxoRemaining, existingSelections) txout = do + (utxoSelected, utxoRemaining') <- coverRandomly ([], utxoRemaining) + return + ( inputCountRemaining - fromIntegral (L.length utxoSelected) + , utxoRemaining' + , (utxoSelected, txout) : existingSelections + ) + where + coverRandomly + :: ([CoinMapEntry i], CoinMap i) + -> MaybeT m ([CoinMapEntry i], CoinMap i) + coverRandomly (selected, remaining) + | L.length selected > fromIntegral inputCountRemaining = + MaybeT $ return Nothing + | sumEntries selected >= targetMin (mkTargetRange txout) = + MaybeT $ return $ Just (selected, remaining) + | otherwise = + utxoPickRandomT remaining >>= \(picked, remaining') -> + coverRandomly (picked : selected, remaining') + +-- | Perform an improvement to random selection on a given output. +improveSelection + :: forall i o m . (MonadRandom m, Ord i, Ord o) + => (Integer, CoinSelection i o, CoinMap i) + -> ([CoinMapEntry i], CoinMapEntry o) + -> m (Integer, CoinSelection i o, CoinMap i) +improveSelection (maxN0, selection, utxo0) (inps0, txout) = do + (maxN, inps, utxo) <- improve (maxN0, inps0, utxo0) + return + ( maxN + , selection <> CoinSelection + { inputs = coinMapFromList inps + , outputs = coinMapFromList [txout] + , change = mkChange txout inps + } + , utxo + ) + where + target = mkTargetRange txout + + improve + :: (Integer, [CoinMapEntry i], CoinMap i) + -> m (Integer, [CoinMapEntry i], CoinMap i) + improve (maxN, inps, utxo) + | maxN >= 1 && sumEntries inps < targetAim target = do + runMaybeT (utxoPickRandomT utxo) >>= \case + Nothing -> + return (maxN, inps, utxo) + Just (io, utxo') | isImprovement io inps -> do + let inps' = io : inps + let maxN' = maxN - 1 + improve (maxN', inps', utxo') + Just _ -> + return (maxN, inps, utxo) + | otherwise = + return (maxN, inps, utxo) + + isImprovement :: CoinMapEntry i -> [CoinMapEntry i] -> Bool + isImprovement io selected = + let + condA = -- (a) It doesn’t exceed a specified upper limit. + sumEntries (io : selected) < targetMax target + + condB = -- (b) Addition gets us closer to the ideal change + distanceA < distanceB + where + distanceA = C.distance + (targetAim target) + (sumEntries (io : selected)) + distanceB = C.distance + (targetAim target) + (sumEntries selected) + + -- (c) Doesn't exceed maximum number of inputs + -- Guaranteed by the precondition on 'improve'. + in + condA && condB + +-------------------------------------------------------------------------------- +-- Internals +-------------------------------------------------------------------------------- + +-- | Represents a target range of /total input values/ for a given output. +-- +-- In this context, /total input value/ refers to the total value of a set of +-- inputs selected to pay for a given output. +-- +data TargetRange = TargetRange + { targetMin :: Coin + -- ^ The minimum value, corresponding to exactly the requested target + -- amount, and a change amount of zero. + , targetAim :: Coin + -- ^ The ideal value, corresponding to exactly twice the requested + -- target amount, and a change amount equal to the requested amount. + , targetMax :: Coin + -- ^ The maximum value, corresponding to exactly three times the + -- requested amount, and a change amount equal to twice the requested + -- amount. + } + +-- | Compute the target range of /total input values/ for a given output. +-- +-- See 'TargetRange'. +-- +mkTargetRange :: CoinMapEntry o -> TargetRange +mkTargetRange (CoinMapEntry _ c) = TargetRange + { targetMin = c + , targetAim = c `C.add` c + , targetMax = c `C.add` c `C.add` c + } + +-- | Re-wrap 'utxoPickRandom' in a 'MaybeT' monad +utxoPickRandomT + :: MonadRandom m + => CoinMap i + -> MaybeT m (CoinMapEntry i, CoinMap i) +utxoPickRandomT = + MaybeT + . fmap (\(mi, u) -> (, u) <$> mi) + . coinMapRandomEntry + +-- | Compute change outputs from a target output and a selection of inputs. +-- +-- Pre-condition: +-- +-- The output must be less than (or equal to) the sum of the inputs. +-- +mkChange :: CoinMapEntry o -> [CoinMapEntry i] -> [Coin] +mkChange (CoinMapEntry _ out) inps = + case difference of + Nothing -> + error $ mconcat + [ "mkChange: " + , "output must be less than or equal to sum of inputs" + ] + Just d | C.isZero d -> + [] + Just d -> + [d] + where + difference = sumEntries inps `C.sub` out + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +sumEntries :: [CoinMapEntry i] -> Coin +sumEntries = mconcat . fmap entryValue diff --git a/src/library/Cardano/CoinSelection/Fee.hs b/src/library/Cardano/CoinSelection/Fee.hs new file mode 100644 --- /dev/null +++ b/src/library/Cardano/CoinSelection/Fee.hs @@ -0,0 +1,713 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_HADDOCK prune #-} + +-- | +-- Copyright: © 2018-2020 IOHK +-- License: Apache-2.0 +-- +-- Provides functionality for __adjusting__ coin selections in order to pay for +-- transaction __fees__. +-- +module Cardano.CoinSelection.Fee + ( + -- * Fundamental Types + Fee (..) + , FeeEstimator (..) + + -- * Fee Adjustment + , adjustForFee + , FeeOptions (..) + , FeeBalancingPolicy (..) + , FeeAdjustmentError (..) + + -- * Dust Processing + , DustThreshold (..) + , coalesceDust + + -- # Internal Functions + , calculateFee + , distributeFee + , reduceChangeOutputs + , splitCoin + + ) where + +import Prelude hiding + ( round ) + +import Cardano.CoinSelection + ( CoinMap (..) + , CoinMapEntry (..) + , CoinSelection (..) + , coinMapFromList + , coinMapRandomEntry + , sumChange + , sumInputs + , sumOutputs + ) +import Control.Monad.Trans.Class + ( lift ) +import Control.Monad.Trans.Except + ( ExceptT (..), except, throwE ) +import Control.Monad.Trans.State + ( StateT (..), evalStateT ) +import Crypto.Random.Types + ( MonadRandom ) +import Data.Function + ( (&) ) +import Data.List.NonEmpty + ( NonEmpty ((:|)) ) +import Data.Maybe + ( fromMaybe ) +import Data.Ord + ( Down (..), comparing ) +import Data.Ratio + ( (%) ) +import GHC.Generics + ( Generic ) +import Internal.Coin + ( Coin ) +import Internal.Invariant + ( invariant ) +import Internal.Rounding + ( RoundingDirection (..), round ) +import Quiet + ( Quiet (Quiet) ) + +import qualified Data.Foldable as F +import qualified Data.List.NonEmpty as NE +import qualified Internal.Coin as C + +-------------------------------------------------------------------------------- +-- Fundamental Types +-------------------------------------------------------------------------------- + +-- | Represents a non-negative fee to be paid on a transaction. +-- +-- @since 1.0.0 +newtype Fee = Fee { unFee :: Coin } + deriving newtype (Monoid, Semigroup) + deriving stock (Eq, Generic, Ord) + deriving Show via (Quiet Fee) + +-- | Defines the /maximum/ size of a __dust coin__. +-- +-- Functions that accept a 'DustThreshold' argument will generally exclude +-- values that are /less than or equal to/ this threshold from the 'change' +-- sets of generated selections, /coalescing/ such coins together into larger +-- coins that /exceed/ the threshold. +-- +-- Specifying a dust threshold of __/n/__ causes all coins that are less than +-- or equal to __/n/__ to be treated as dust and coalesced together. +-- +-- Specifying a dust threshold of __0__ completely /disables/ dust elimination +-- with the exception of zero-valued coins, which will always be eliminated. +-- +-- See 'coalesceDust'. +-- +-- @since 1.0.0 +newtype DustThreshold = DustThreshold { unDustThreshold :: Coin } + deriving stock (Eq, Generic, Ord) + deriving Show via (Quiet DustThreshold) + +-- | Provides a function capable of __estimating__ the transaction fee required +-- for a given coin selection, according to the rules of a particular +-- blockchain. +-- +-- The fee estimate should be a function of the __current__ memberships of the +-- 'inputs', 'outputs', and 'change' sets. +-- +-- Depending on the rules of the blockchain under consideration, the fee +-- estimate may take either (or both) of the following factors into account: +-- +-- - the number of entries in each set; +-- - the coin value of each set member. +-- +-- A fee estimate may differ from the final fee required for a selection, as +-- fees are generally paid for by /adjusting/ a given selection to make a /new/ +-- selection. See 'adjustForFee' for more details of this process. +-- +-- @since 1.0.0 +newtype FeeEstimator i o = FeeEstimator + { estimateFee :: CoinSelection i o -> Fee + } deriving Generic + +-------------------------------------------------------------------------------- +-- Fee Adjustment +-------------------------------------------------------------------------------- + +-- | Provides options for fee adjustment. +-- +-- @since 1.0.0 +data FeeOptions i o = FeeOptions + { feeEstimator + :: FeeEstimator i o + -- ^ Estimate fees based on selected inputs and requested outputs. + + , dustThreshold + :: DustThreshold + -- ^ The threshold to use for dust elimination. Specifying a threshold + -- of zero will disable dust elimination. See 'DustThreshold' for more + -- details. + + , feeBalancingPolicy + :: FeeBalancingPolicy + -- ^ Which fee balancing policy to use. + } deriving Generic + +-- | A choice of fee balancing policies for use when adjusting a coin selection. +-- +-- == Background +-- +-- A coin selection __'s'__ is said to have a /perfectly-balanced/ fee when it +-- satisfies the following property: +-- +-- >>> sumInputs s = sumOutputs s + sumChange s + estimateFee s +-- +-- Conversely, a selection is said to have an /unbalanced/ fee when it +-- satisfies the following property: +-- +-- >>> sumInputs s > sumOutputs s + sumChange s + estimateFee s +-- +-- In other words, if a coin selection has an /unbalanced/ fee, the /effective/ +-- fee is greater than the minimum fee /actually required/ by the blockchain. +-- +-- == Balanced Fees vs Minimal Fees +-- +-- Some blockchains /require /that fees are always /perfectly-balanced/. +-- +-- However, for blockchains that allow /unbalanced/ fees, it is sometimes +-- possible to /save money/ by generating a coin selection with an unbalanced +-- fee. This may seem counterintuitive at first, but consider an individual +-- change ouput __/c/__ of value __/v/__. If the /marginal fee/ __/f/__ +-- associated with __/c/__ is greater than its value __/v/__, then we will +-- /save money/ by __not__ including __/c/__ within 'change'. +-- +-- There are two policy choices available for handling change values with +-- marginal fees greater than their value: +-- +-- - For blockchains that __allow__ transactions with /unbalanced/ fees, +-- specifying the 'RequireMinimalFee' policy will allow money to be saved by +-- /excluding/ change outputs that have a marginal fee greater than +-- their value. +-- +-- - For blockchains that do __not__ allow transactions with /unbalanced/ +-- fees, specifying the 'RequireBalancedFee' policy will always generate +-- selections with fees that are perfectly-balanced, even if the resulting +-- fees are higher than could be achieved by allowing unbalanced fees. +-- +data FeeBalancingPolicy + = RequireBalancedFee + -- ^ Generate selections with fees that are perfectly balanced, with the + -- trade-off of allowing slightly higher fees. + | RequireMinimalFee + -- ^ Generate selections with the lowest fees possible, with the + -- trade-off of allowing slightly imbalanced fees. + deriving (Generic, Show, Eq) + +-- | Represents the set of possible failures that can occur when adjusting a +-- 'CoinSelection' with the 'adjustForFee' function. +-- +data FeeAdjustmentError i o + = CannotCoverFee Fee + -- ^ Indicates that the given map of additional inputs was exhausted while + -- attempting to select extra inputs to cover the required fee. + -- + -- Records the shortfall (__/f/__ − __/s/__) between the required fee + -- __/f/__ and the total value __/s/__ of currently-selected inputs. + + | CoinSelectionUnderfunded (CoinSelection i o) + -- ^ Indicates that the given coin selection is __underfunded__: the total + -- value of 'inputs' is less than the total value of 'outputs', as + -- calculated by the 'CoinSelection.coinMapValue' function. + deriving (Show, Eq) + +-- | Adjusts the given 'CoinSelection' in order to pay for a __transaction__ +-- __fee__, required in order to publish the selection as a transaction on +-- a blockchain. +-- +-- == Background +-- +-- Implementations of 'Cardano.CoinSelection.CoinSelectionAlgorithm' generally +-- produce coin selections that are /exactly balanced/, satisfying the +-- following equality: +-- +-- >>> sumInputs s = sumOutputs s + sumChange s +-- +-- In order to pay for a transaction fee, the above equality must be +-- transformed into an /inequality/: +-- +-- >>> sumInputs s > sumOutputs s + sumChange s +-- +-- The difference between these two sides represents value to be paid /by the/ +-- /originator/ of the transaction, in the form of a fee: +-- +-- >>> sumInputs s = sumOutputs s + sumChange s + fee +-- +-- == The Adjustment Process +-- +-- In order to generate a fee that is acceptable to the network, this function +-- adjusts the 'change' and 'inputs' of the given 'CoinSelection', consulting +-- the 'FeeEstimator' as a guide for how much the current selection would cost +-- to publish as a transaction on the network. +-- +-- == Methods of Adjustment +-- +-- There are two methods of adjustment possible: +-- +-- 1. The __'change'__ set can be /reduced/, either by: +-- +-- a. completely removing a change value from the set; or by +-- +-- b. reducing a change value to a lower value. +-- +-- 2. The __'inputs'__ set can be /augmented/, by selecting additional inputs +-- from the specified 'CoinMap' argument. +-- +-- == Dealing with Dust Values +-- +-- If, at any point, a change value is generated that is less than or equal +-- to the 'DustThreshold', this function will eliminate that change value +-- from the 'change' set, redistributing the eliminated value over the remaining +-- change values, ensuring that the total value of all 'change' is preserved. +-- +-- See 'coalesceDust' for more details. +-- +-- == Termination +-- +-- Since adjusting a selection can affect the fee estimate produced by +-- 'estimateFee', the process of adjustment is an /iterative/ process. +-- +-- The termination post-condition depends on the choice of +-- 'FeeBalancingPolicy': +-- +-- - If 'RequireBalancedFee' is specified, this function terminates +-- only when it has generated a 'CoinSelection' __'s'__ that satisfies the +-- following property: +-- +-- >>> sumInputs s = sumOutputs s + sumChange s + estimateFee s +-- +-- - If 'RequireMinimalFee' policy is specified, the above /equality/ +-- is relaxed to the following /inequality/: +-- +-- >>> sumInputs s ≥ sumOutputs s + sumChange s + estimateFee s +-- +-- See 'FeeBalancingPolicy' for more details. +-- +-- @since 1.0.0 +adjustForFee + :: (Ord i, MonadRandom m) + => FeeOptions i o + -> CoinMap i + -> CoinSelection i o + -> ExceptT (FeeAdjustmentError i o) m (CoinSelection i o) +adjustForFee unsafeOpt utxo coinSel = do + let opt = invariant + "adjustForFee: fee must be non-null" unsafeOpt (not . nullFee) + senderPaysFee opt utxo coinSel + where + nullFee opt = estimateFee (feeEstimator opt) coinSel == Fee C.zero + +-------------------------------------------------------------------------------- +-- Internal Functions +-------------------------------------------------------------------------------- + +-- Calculates the current fee associated with a given 'CoinSelection'. +-- +-- If the result is less than zero, returns 'Nothing'. +-- +calculateFee :: CoinSelection i o -> Maybe Fee +calculateFee s = Fee <$> sumInputs s `C.sub` (sumOutputs s `C.add` sumChange s) + +-- The sender pays fee in this scenario, so fees are removed from the change +-- outputs, and new inputs are selected if necessary. +-- +senderPaysFee + :: forall i o m . (Ord i, MonadRandom m) + => FeeOptions i o + -> CoinMap i + -> CoinSelection i o + -> ExceptT (FeeAdjustmentError i o) m (CoinSelection i o) +senderPaysFee opts utxo sel = + evalStateT (go sel) utxo + where + go + :: CoinSelection i o + -> StateT + (CoinMap i) + (ExceptT (FeeAdjustmentError i o) m) + (CoinSelection i o) + go coinSel@(CoinSelection inps outs chgs) = do + -- Substract fee from change outputs, proportionally to their value. + (coinSel', remFee) <- lift $ except $ reduceChangeOutputs opts coinSel + + -- Should the change cover the fee, we're (almost) good. By removing + -- change outputs, we make them smaller and may reduce the size of the + -- transaction, and the fee. Thus, we end up paying slightly more than + -- the upper bound. We could do some binary search and try to + -- re-distribute excess across changes until fee becomes bigger. + if remFee == Fee C.zero + then pure coinSel' + else do + -- Otherwise, we need an extra entries from the available utxo to + -- cover what's left. Note that this entry may increase our change + -- because we may not consume it entirely. So we will just split + -- the extra change across all changes possibly increasing the + -- number of change outputs (if there was none, or if increasing a + -- change value causes an overflow). + -- + -- Because selecting a new input increases the fee, we need to + -- re-run the algorithm with this new elements and using the initial + -- change plus the extra change brought up by this entry and see if + -- we can now correctly cover fee. + inps' <- coverRemainingFee remFee + let extraChange = splitCoin (sumEntries inps') chgs + go $ CoinSelection (inps <> coinMapFromList inps') outs extraChange + +-- A short and simple version of the 'random' fee policy to cover for the fee +-- in the case where existing set of change is not enough. +-- +coverRemainingFee + :: MonadRandom m + => Fee + -> StateT (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) [CoinMapEntry i] +coverRemainingFee (Fee fee) = go [] where + go acc + | sumEntries acc >= fee = + return acc + | otherwise = do + -- We ignore the size of the fee, and just pick randomly + StateT (lift . coinMapRandomEntry) >>= \case + Just entry -> + go (entry : acc) + Nothing -> + lift $ throwE $ CannotCoverFee $ Fee $ + fee `C.distance` (sumEntries acc) + +-- Pays for the given fee by subtracting it from the given list of change +-- outputs, so that each change output is reduced by a portion of the fee +-- that's in proportion to its relative size. +-- +-- == Basic Examples +-- +-- >>> reduceChangeOutputs (DustThreshold 0) (Fee 4) (Coin <$> [2, 2, 2, 2]) +-- [Coin 1, Coin 1, Coin 1, Coin 1] +-- +-- >>> reduceChangeOutputs (DustThreshold 0) (Fee 15) (Coin <$> [2, 4, 8, 16]) +-- [Coin 1, Coin 2, Coin 4, Coin 8] +-- +-- == Handling Dust +-- +-- Any dust outputs in the resulting list are coalesced according to the given +-- dust threshold: (See 'coalesceDust'.) +-- +-- >>> reduceChangeOutputs (DustThreshold 1) (Fee 4) (Coin <$> [2, 2, 2, 2]) +-- [Coin 4] +-- +-- == Handling Insufficient Change +-- +-- If there's not enough change to pay for the fee, or if there's only just +-- enough to pay for it exactly, this function returns the /empty list/: +-- +-- >>> reduceChangeOutputs (DustThreshold 0) (Fee 15) (Coin <$> [10]) +-- [] +-- +-- >>> reduceChangeOutputs (DustThreshold 0) (Fee 15) (Coin <$> [1, 2, 4, 8]) +-- [] +-- +reduceChangeOutputs + :: FeeOptions i o + -> CoinSelection i o + -> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee) +reduceChangeOutputs opts s = do + -- The original requested fee amount + let Fee φ_original = estimateFee (feeEstimator opts) s + -- The initial amount left for fee (i.e. inputs - outputs) + let mδ_original = sumInputs s `C.sub` (sumOutputs s `C.add` sumChange s) + case mδ_original of + -- selection is now balanced, nothing to do. + Just δ_original | φ_original == δ_original -> do + pure (s, Fee C.zero) + + -- some fee left to pay, but we've depleted all change outputs + Just δ_original | φ_original > δ_original && null (change s) -> do + let remainder = φ_original `C.distance` δ_original + pure (s, Fee remainder) + + -- some fee left to pay, and we've haven't depleted all change yet + Just δ_original | φ_original > δ_original && not (null (change s)) -> do + let remainder = φ_original `C.distance` δ_original + let chgs' = distributeFee (Fee remainder) (NE.fromList (change s)) + & fmap payFee + & coalesceDust (dustThreshold opts) + reduceChangeOutputs opts (s { change = chgs' }) + + -- The current selection has a higher fee than necessary. This typically + -- occurs if, after reducing an output to pay for the predicted fee, the + -- required fee turns out to be less than originally predicted. + -- The outcome depends on whether or not the node allows transactions + -- to be unbalanced. + Just δ_original | δ_original > φ_original -> do + let extraChg = δ_original `C.distance` φ_original + let sDangling = s { change = splitCoin extraChg (change s) } + let Fee φ_dangling = estimateFee (feeEstimator opts) sDangling + -- We have `δ_dangling = φ_original` by construction of sDangling. + -- + -- Proof: + -- + -- δ_dangling = Σi_dangling - (Σo_dangling + Σc_dangling) + -- = Σi_original - (Σo_original + Σc_original + extraChg) + -- = Σi_original - (Σo_original + Σc_original) - extraChg + -- = δ_original - extraChg + -- = δ_original - (δ_original - φ_original) + -- = φ_original + let δ_dangling = φ_original + case φ_dangling `C.sub` δ_dangling of + -- we've left too much, but adding a change output would be more + -- expensive than not having it. Here we have two choices: + -- + -- a) If the node allows unbalanced transaction, we can stop + -- here and do nothing. We'll leave slightly more than what's + -- needed for fees, but having an extra change output isn't + -- worth it anyway. + -- + -- b) If we __must__ balance the transaction, then we can choose + -- to pay the extra cost by adding the change output and + -- continue trying to balance the transaction (likely, by + -- selecting another input). + Just remainder | φ_dangling >= δ_original -> + case feeBalancingPolicy opts of + RequireMinimalFee -> + pure (s, Fee C.zero) + RequireBalancedFee -> + pure (sDangling, Fee remainder) + + -- If however, adding the dangling change doesn't cost more than + -- not having it, we might as well add it to get the money and + -- continue balancing! + _otherwise -> + reduceChangeOutputs opts sDangling + + -- The only way to end-up here is if the user has provided an invalid + -- selection where outputs are trying to spend more than inputs. This is + -- simply forbidden. + _Nothing -> + Left (CoinSelectionUnderfunded s) + +-- Distribute the given fee over the given list of coins, so that each coin +-- is allocated a __fraction__ of the fee in proportion to its relative size. +-- +-- == Pre-condition +-- +-- Every coin in the given list must be __non-zero__ in value. +-- +-- == Examples +-- +-- >>> distributeFee (Fee 2) [(Coin 1), (Coin 1)] +-- [(Fee 1, Coin 1), (Fee 1, Coin 1)] +-- +-- >>> distributeFee (Fee 4) [(Coin 1), (Coin 1)] +-- [(Fee 2, Coin 1), (Fee 2, Coin 1)] +-- +-- >>> distributeFee (Fee 7) [(Coin 1), (Coin 2), (Coin 4)] +-- [(Fee 1, Coin 1), (Fee 2, Coin 2), (Fee 4, Coin 4)] +-- +-- >>> distributeFee (Fee 14) [(Coin 1), (Coin 2), (Coin 4)] +-- [(Fee 2, Coin 1), (Fee 4, Coin 2), (Fee 8, Coin 4)] +-- +distributeFee :: Fee -> NonEmpty Coin -> NonEmpty (Fee, Coin) +distributeFee (Fee feeTotal) coinsUnsafe = + NE.zip feesRounded coins + where + -- A list of coins that are non-zero in value. + coins :: NonEmpty Coin + coins = + invariant "distributeFee: all coins must be non-zero in value." + coinsUnsafe (C.zero `F.notElem`) + + -- A list of rounded fee portions, where each fee portion deviates from the + -- ideal unrounded portion by as small an amount as possible. + feesRounded :: NonEmpty Fee + feesRounded + -- 1. Start with the list of ideal unrounded fee portions for each coin: + = feesUnrounded + -- 2. Attach an index to each fee portion, so that we can remember the + -- original order: + & NE.zip indices + -- 3. Sort the fees into descending order of their fractional parts: + & NE.sortBy (comparing (Down . fractionalPart . snd)) + -- 4. Apply pre-computed roundings to each fee portion: + -- * portions with the greatest fractional parts are rounded up; + -- * portions with the smallest fractional parts are rounded down. + & NE.zipWith (\roundDir (i, f) -> (i, round roundDir f)) feeRoundings + -- 5. Restore the original order: + & NE.sortBy (comparing fst) + -- 6. Strip away the indices: + & fmap snd + -- 7. Transform results into fees: + & fmap (Fee . fromMaybe C.zero . C.coinFromIntegral @Integer) + where + indices :: NonEmpty Int + indices = 0 :| [1 ..] + + -- A list of rounding directions, one per fee portion. + -- + -- Since the ideal fee portion for each coin is a rational value, we must + -- therefore round each rational value either /up/ or /down/ to produce a + -- final integer result. + -- + -- However, we can't take the simple approach of either rounding /all/ fee + -- portions down or rounding /all/ fee portions up, as this could cause the + -- sum of fee portions to either undershoot or overshoot the original fee. + -- + -- So in order to hit the fee exactly, we must round /some/ of the portions + -- up, and /some/ of the portions down. + -- + -- Fortunately, we can calculate exactly how many fee portions must be + -- rounded up, by first rounding /all/ portions down, and then computing + -- the /shortfall/ between the sum of the rounded-down portions and the + -- original fee. + -- + -- We return a list where all values of 'RoundUp' occur in a contiguous + -- section at the start of the list, of the following form: + -- + -- [RoundUp, RoundUp, ..., RoundDown, RoundDown, ...] + -- + feeRoundings :: NonEmpty RoundingDirection + feeRoundings = + applyN feeShortfall (NE.cons RoundUp) (NE.repeat RoundDown) + where + -- The part of the total fee that we'd lose if we were to take the + -- simple approach of rounding all ideal fee portions /down/. + feeShortfall + = C.coinToIntegral feeTotal + - fromIntegral @Integer (F.sum $ round RoundDown <$> feesUnrounded) + + -- A list of ideal unrounded fee portions, with one fee portion per coin. + -- + -- A coin's ideal fee portion is the rational portion of the total fee that + -- corresponds to that coin's relative size when compared to other coins. + feesUnrounded :: NonEmpty Rational + feesUnrounded = calculateIdealFee <$> coins + where + calculateIdealFee c + = C.coinToIntegral c + * C.coinToIntegral feeTotal + % C.coinToIntegral totalCoinValue + + -- The total value of all coins. + totalCoinValue :: Coin + totalCoinValue = F.fold coins + +-- | From the given list of coins, remove dust coins with a value less than or +-- equal to the given threshold value, redistributing their total value over +-- the coins that remain. +-- +-- This function satisfies the following properties: +-- +-- >>> sum coins = sum (coalesceDust threshold coins) +-- >>> all (/= Coin 0) (coalesceDust threshold coins) +-- +coalesceDust :: DustThreshold -> NonEmpty Coin -> [Coin] +coalesceDust (DustThreshold threshold) coins = + splitCoin valueToDistribute coinsToKeep + where + (coinsToKeep, coinsToRemove) = NE.partition (> threshold) coins + valueToDistribute = F.fold coinsToRemove + +-- Splits up the given coin of value __@v@__, distributing its value over the +-- given coin list of length __@n@__, so that each coin value is increased by +-- an integral amount within unity of __@v/n@__, producing a new list of coin +-- values where the overall total is preserved. +-- +-- == Basic Examples +-- +-- When it's possible to divide a coin evenly, each coin value is increased by +-- the same integer amount: +-- +-- >>> splitCoin (Coin 40) (Coin <$> [1, 1, 1, 1]) +-- [Coin 11, Coin 11, Coin 11, Coin 11] +-- +-- >>> splitCoin (Coin 40) (Coin <$> [1, 2, 3, 4]) +-- [Coin 11, Coin 12, Coin 13, Coin 14] +-- +-- == Handling Non-Uniform Increases +-- +-- When it's not possible to divide a coin evenly, each integral coin value in +-- the resulting list is always within unity of the ideal unrounded result: +-- +-- >>> splitCoin (Coin 2) (Coin <$> [1, 1, 1, 1]) +-- [Coin 1, Coin 1, Coin 2, Coin 2] +-- +-- >>> splitCoin (Coin 10) (Coin <$> [1, 1, 1, 1]) +-- [Coin 3, Coin 3, Coin 4, Coin 4] +-- +-- == Handling Empty Lists +-- +-- If the given list is empty, this function returns a list with the original +-- given coin as its sole element: +-- +-- >>> splitCoin (Coin 10) [] +-- [Coin 10] +-- +-- == Properties +-- +-- The total value is always preserved: +-- +-- >>> sum (splitCoin x ys) == x + sum ys +-- +splitCoin :: Coin -> [Coin] -> [Coin] +splitCoin coinToSplit coinsToIncrease = + case (mIncrement, mShortfall) of + (Just increment, Just shortfall) -> + zipWith C.add coinsToIncrease increments + where + increments = zipWith C.add majorIncrements minorIncrements + majorIncrements = repeat increment + minorIncrements = replicate (C.coinToIntegral shortfall) C.one + <> repeat C.zero + _ | coinToSplit > C.zero -> + [coinToSplit] + _ -> + [] + where + mCoinCount = length coinsToIncrease + mIncrement = coinToSplit `C.div` mCoinCount + mShortfall = coinToSplit `C.mod` mCoinCount + +-- Extract the fractional part of a rational number. +-- +-- Examples: +-- +-- >>> fractionalPart (3 % 2) +-- 1 % 2 +-- +-- >>> fractionalPart (11 % 10) +-- 1 % 10 +-- +fractionalPart :: Rational -> Rational +fractionalPart = snd . properFraction @_ @Integer + +-- Apply the same function multiple times to a value. +-- +applyN :: Int -> (a -> a) -> a -> a +applyN n f = F.foldr (.) id (replicate n f) + +-- Find the sum of a list of entries. +-- +sumEntries :: [CoinMapEntry i] -> Coin +sumEntries = F.fold . fmap entryValue + +-- | Reduce a coin value by a given fee amount. If fees are too big for +-- a single coin, returns a `Coin 0`. +payFee :: (Fee, Coin) -> Coin +payFee (Fee f, c) = fromMaybe C.zero (c `C.sub` f) diff --git a/src/test/Cardano/CoinSelection/Algorithm/LargestFirstSpec.hs b/src/test/Cardano/CoinSelection/Algorithm/LargestFirstSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Cardano/CoinSelection/Algorithm/LargestFirstSpec.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.CoinSelection.Algorithm.LargestFirstSpec + ( spec + ) where + +import Prelude + +import Cardano.CoinSelection + ( CoinMap (..) + , CoinMapEntry (..) + , CoinSelection (..) + , CoinSelectionAlgorithm (..) + , CoinSelectionError (..) + , CoinSelectionLimit (..) + , CoinSelectionParameters (..) + , CoinSelectionResult (..) + , InputCountInsufficientError (..) + , InputLimitExceededError (..) + , InputValueInsufficientError (..) + , InputsExhaustedError (..) + , coinMapToList + ) +import Cardano.CoinSelection.Algorithm.LargestFirst + ( largestFirst ) +import Cardano.CoinSelectionSpec + ( CoinSelProp (..) + , CoinSelectionFixture (..) + , CoinSelectionTestResult (..) + , coinSelectionUnitTest + ) +import Cardano.Test.Utilities + ( Address, TxIn, excluding, unsafeCoin ) +import Control.Monad + ( unless ) +import Control.Monad.Trans.Except + ( runExceptT ) +import Data.Either + ( isRight ) +import Data.Functor.Identity + ( Identity (runIdentity) ) +import Test.Hspec + ( Spec, describe, it, shouldSatisfy ) +import Test.QuickCheck + ( Property, property, (==>) ) + +import qualified Data.List as L +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +spec :: Spec +spec = do + describe "Coin selection: largest-first algorithm: unit tests" $ do + + coinSelectionUnitTest largestFirst "" + (Right $ CoinSelectionTestResult + { rsInputs = [17] + , rsChange = [] + , rsOutputs = [17] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [10,10,17] + , txOutputs = [17] + }) + + coinSelectionUnitTest largestFirst "" + (Right $ CoinSelectionTestResult + { rsInputs = [17] + , rsChange = [16] + , rsOutputs = [1] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [12,10,17] + , txOutputs = [1] + }) + + coinSelectionUnitTest largestFirst "" + (Right $ CoinSelectionTestResult + { rsInputs = [12, 17] + , rsChange = [11] + , rsOutputs = [18] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [12,10,17] + , txOutputs = [18] + }) + + coinSelectionUnitTest largestFirst "" + (Right $ CoinSelectionTestResult + { rsInputs = [10, 12, 17] + , rsChange = [9] + , rsOutputs = [30] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [12,10,17] + , txOutputs = [30] + }) + + coinSelectionUnitTest largestFirst "" + (Right $ CoinSelectionTestResult + { rsInputs = [6,10,5] + , rsChange = [5,4] + , rsOutputs = [11,1] + }) + (CoinSelectionFixture + { maxNumOfInputs = 3 + , utxoInputs = [1,2,10,6,5] + , txOutputs = [11, 1] + }) + + coinSelectionUnitTest largestFirst + "UTxO balance not sufficient" + (Left $ InputValueInsufficient $ InputValueInsufficientError + (unsafeCoin @Int 39) (unsafeCoin @Int 40)) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [12,10,17] + , txOutputs = [40] + }) + + coinSelectionUnitTest largestFirst + "UTxO balance not sufficient, and not fragmented enough" + (Left $ InputValueInsufficient $ InputValueInsufficientError + (unsafeCoin @Int 39) (unsafeCoin @Int 43)) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [12,10,17] + , txOutputs = [40,1,1,1] + }) + + coinSelectionUnitTest largestFirst + "UTxO balance sufficient, but not fragmented enough" + (Left $ InputCountInsufficient $ InputCountInsufficientError 3 4) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [12,20,17] + , txOutputs = [40,1,1,1] + }) + + coinSelectionUnitTest largestFirst + "UTxO balance sufficient, fragmented enough, but single output \ + \depletes all UTxO entries" + (Left (InputsExhausted InputsExhaustedError)) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [12,20,17] + , txOutputs = [40, 1] + }) + + coinSelectionUnitTest largestFirst + "UTxO balance sufficient, fragmented enough, but single output \ + \depletes all UTxO entries" + (Left (InputsExhausted InputsExhaustedError)) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [20,20,10,5] + , txOutputs = [41, 6] + }) + + coinSelectionUnitTest largestFirst + "UTxO balance sufficient, fragmented enough, but maximum input \ + \count exceeded" + (Left $ InputLimitExceeded $ InputLimitExceededError 9) + (CoinSelectionFixture + { maxNumOfInputs = 9 + , utxoInputs = replicate 100 1 + , txOutputs = replicate 100 1 + }) + + coinSelectionUnitTest largestFirst + "UTxO balance sufficient, fragmented enough, but maximum input \ + \count exceeded" + (Left $ InputLimitExceeded $ InputLimitExceededError 9) + (CoinSelectionFixture + { maxNumOfInputs = 9 + , utxoInputs = replicate 100 1 + , txOutputs = replicate 10 10 + }) + + coinSelectionUnitTest largestFirst + "UTxO balance sufficient, fragmented enough, but maximum input \ + \count exceeded" + (Left $ InputLimitExceeded $ InputLimitExceededError 2) + (CoinSelectionFixture + { maxNumOfInputs = 2 + , utxoInputs = [1,2,10,6,5] + , txOutputs = [11, 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) + +-------------------------------------------------------------------------------- +-- 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 + -> Property +propInputDecreasingOrder (CoinSelProp utxo txOuts) = + isRight selection ==> + let Right (CoinSelectionResult s _) = selection in + prop s + where + prop (CoinSelection inps _ _) = + let + utxo' = (Map.toList . unCoinMap) $ utxo `excluding` + Set.fromList (entryKey <$> coinMapToList inps) + in unless (L.null utxo') $ + (L.minimum (entryValue <$> coinMapToList inps)) + `shouldSatisfy` + (>= (L.maximum (snd <$> utxo'))) + selection = runIdentity + $ runExceptT + $ selectCoins largestFirst + $ CoinSelectionParameters utxo txOuts selectionLimit + selectionLimit = CoinSelectionLimit $ const 100 diff --git a/src/test/Cardano/CoinSelection/Algorithm/MigrationSpec.hs b/src/test/Cardano/CoinSelection/Algorithm/MigrationSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Cardano/CoinSelection/Algorithm/MigrationSpec.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.CoinSelection.Algorithm.MigrationSpec + ( spec + ) where + +import Prelude + +import Cardano.CoinSelection + ( CoinMap (..) + , CoinMapEntry (..) + , CoinSelection (..) + , coinMapToList + , coinMapValue + , sumChange + , sumInputs + ) +import Cardano.CoinSelection.Algorithm.Migration + ( BatchSize (..), idealBatchSize, selectCoins ) +import Cardano.CoinSelection.Fee + ( DustThreshold (..) + , Fee (..) + , FeeBalancingPolicy (..) + , FeeEstimator (..) + , FeeOptions (..) + ) +import Cardano.CoinSelection.FeeSpec + ( FeeParameters, stableEstimator ) +import Cardano.CoinSelectionSpec + () +import Cardano.Test.Utilities + ( Address + , Hash (..) + , TxIn (..) + , unsafeCoin + , unsafeDustThreshold + , unsafeFee + ) +import Data.ByteString + ( ByteString ) +import Data.Function + ( (&) ) +import Internal.Coin + ( Coin, coinToIntegral ) +import Numeric.Natural + ( Natural ) +import Test.Hspec + ( Spec, SpecWith, describe, it, shouldSatisfy ) +import Test.QuickCheck + ( Arbitrary (..) + , Gen + , Property + , arbitrarySizedIntegral + , choose + , conjoin + , counterexample + , frequency + , label + , property + , scale + , vectorOf + , withMaxSuccess + , (===) + ) +import Test.QuickCheck.Monadic + ( monadicIO, monitor, pick ) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Internal.Coin as C + +spec :: Spec +spec = do + describe "idealBatchSize" $ do + it "Eventually converge for decreasing functions" $ do + property $ \coinselOpts -> do + let batchSize = idealBatchSize coinselOpts + label (show batchSize) True + + describe "accuracy of selectCoins" $ do + let testAccuracy :: Double -> SpecWith () + testAccuracy r = it title $ withMaxSuccess 1000 $ monadicIO $ do + let dust = unsafeCoin @Int 100 + utxo <- pick (genUTxO r dust) + batchSize <- pick genBatchSize + feeOpts <- pick (genFeeOptions dust) + let selections = selectCoins feeOpts batchSize utxo + monitor $ label $ accuracy dust + (coinToIntegral $ coinMapValue utxo) + (sum $ coinToIntegral . sumInputs <$> selections) + where + title :: String + title = "dust=" <> show (round (100 * r) :: Int) <> "%" + + accuracy :: Coin -> Natural -> Natural -> String + accuracy dust sup real + | a >= 1.0 = + "PERFECT (== 100%)" + | a > 0.99 || (sup - real) < coinToIntegral dust = + "OKAY (> 99%)" + | otherwise = + "MEDIOCRE (<= 99%)" + where + a = double real / double sup + double = fromRational @Double . fromIntegral + + mapM_ testAccuracy [ 0.01 , 0.05 , 0.10 , 0.25 , 0.50 ] + + describe "selectCoins properties" $ do + it "No coin selection has outputs" $ + property $ withMaxSuccess 10000 $ prop_onlyChangeOutputs + @(Wrapped TxIn) @Address + + it "Every coin in the selection change >= minimum threshold coin" $ + property $ withMaxSuccess 10000 $ prop_noLessThanThreshold + @(Wrapped TxIn) @Address + + it "Total input UTxO value >= sum of selection change coins" $ + property $ withMaxSuccess 10000 $ prop_inputsGreaterThanOutputs + @(Wrapped TxIn) @Address + + it "Every selection input is unique" $ + property $ withMaxSuccess 10000 $ prop_inputsAreUnique + @(Wrapped TxIn) @Address + + it "Every selection input is a member of the UTxO" $ + property $ withMaxSuccess 10000 $ prop_inputsStillInUTxO + @(Wrapped TxIn) @Address + + it "Every coin selection is well-balanced" $ + property $ withMaxSuccess 10000 $ prop_wellBalanced + @(Wrapped TxIn) @Address + + describe "selectCoins regressions" $ do + it "regression #1" $ do + let feeOpts = FeeOptions + { dustThreshold = unsafeDustThreshold @Int 9 + , feeEstimator = FeeEstimator $ \s -> unsafeFee @Int + $ fromIntegral + $ 5 * (length (inputs s) + length (outputs s)) + , feeBalancingPolicy = RequireBalancedFee + } + let batchSize = BatchSize 1 + let utxo = CoinMap $ Map.fromList + [ ( TxIn + { txinId = Hash "|\243^\SUBg\242\231\&1\213\203" + , txinIx = 2 + } + , unsafeCoin @Int 2 + ) + ] + property $ prop_inputsGreaterThanOutputs + @TxIn @Address feeOpts batchSize utxo + +-------------------------------------------------------------------------------- +-- Properties +-------------------------------------------------------------------------------- + +-- | No coin selection has outputs +prop_onlyChangeOutputs + :: forall i o . (Ord i, Ord o, Show o) + => FeeOptions i o + -> BatchSize + -> CoinMap i + -> Property +prop_onlyChangeOutputs feeOpts batchSize utxo = do + let allOutputs = + coinMapToList . outputs =<< selectCoins feeOpts batchSize utxo + property (allOutputs `shouldSatisfy` null) + +-- | Every coin in the selection change >= minimum threshold coin +prop_noLessThanThreshold + :: forall i o . (Ord i, Ord o) + => FeeOptions i o + -> BatchSize + -> CoinMap i + -> Property +prop_noLessThanThreshold feeOpts batchSize utxo = do + let allChange = change + =<< selectCoins feeOpts batchSize utxo + let undersizedCoins = + filter (< threshold) allChange + property (undersizedCoins `shouldSatisfy` null) + where + threshold = unDustThreshold $ dustThreshold feeOpts + +-- | Total input UTxO value >= sum of selection change coins +prop_inputsGreaterThanOutputs + :: forall i o . (Ord i, Ord o, Show i, Show o) + => FeeOptions i o + -> BatchSize + -> CoinMap i + -> Property +prop_inputsGreaterThanOutputs feeOpts batchSize utxo = do + let selections = selectCoins feeOpts batchSize utxo + let totalChange = mconcat (sumChange <$> selections) + let balanceUTxO = coinMapValue utxo + property (balanceUTxO >= totalChange) + & counterexample ("Total change balance: " <> show totalChange) + & counterexample ("Total UTxO balance: " <> show balanceUTxO) + & counterexample ("Selections: " <> show selections) + +-- | Every selected input is unique, i.e. selected only once +prop_inputsAreUnique + :: forall i o . (Ord i, Ord o) + => FeeOptions i o + -> BatchSize + -> CoinMap i + -> Property +prop_inputsAreUnique feeOpts batchSize utxo = do + let selectionInputList = + coinMapToList . inputs =<< selectCoins feeOpts batchSize utxo + let selectionInputSet = + Set.fromList selectionInputList + Set.size selectionInputSet === length selectionInputSet + +-- | Every selection input is still a member of the UTxO" $ +prop_inputsStillInUTxO + :: forall i o . (Ord i, Ord o) + => FeeOptions i o + -> BatchSize + -> CoinMap i + -> Property +prop_inputsStillInUTxO feeOpts batchSize utxo = do + let selectionInputSet = Set.fromList $ + coinMapToList . inputs =<< selectCoins feeOpts batchSize utxo + let utxoSet = Set.fromList $ + fmap (uncurry CoinMapEntry) $ Map.toList $ unCoinMap utxo + property (selectionInputSet `Set.isSubsetOf` utxoSet) + +-- | Every coin selection is well-balanced (i.e. actual fees are exactly the +-- expected fees) +prop_wellBalanced + :: forall i o . (Ord i, Ord o, Show i, Show o) + => FeeParameters i o + -> BatchSize + -> CoinMap i + -> Property +prop_wellBalanced feeParams batchSize utxo = do + let feeOpts = FeeOptions + { dustThreshold = DustThreshold mempty + , feeEstimator = stableEstimator feeParams + , feeBalancingPolicy = RequireBalancedFee + } + let selections = selectCoins feeOpts batchSize utxo + conjoin + [ counterexample example (actualFee === expectedFee) + | s <- selections + , let actualFee + = coinToIntegral (sumInputs s) + - coinToIntegral (sumChange s) + , let expectedFee + = coinToIntegral @Integer + $ unFee $ estimateFee (feeEstimator feeOpts) s + , let example = unlines + [ "Coin Selection: " <> show s + , "Actual fee: " <> show actualFee + , "Expected fee: " <> show expectedFee + ] + ] + +-------------------------------------------------------------------------------- +-- Arbitrary Instances +-------------------------------------------------------------------------------- + +-- A wrapper to avoid overlapping instances imported from other modules. +newtype Wrapped a = Wrapped { unwrap :: a } + deriving (Eq, Ord, Show) + +-- TODO: Move similar Arbitrary instances to a shared module for better reuse. +instance Arbitrary (Wrapped TxIn) where + arbitrary = fmap Wrapped . TxIn + <$> fmap unwrap arbitrary + <*> scale (`mod` 3) arbitrary + +-- TODO: Move similar Arbitrary instances to a shared module for better reuse. +instance Arbitrary (Wrapped (Hash "Tx")) where + arbitrary = Wrapped . Hash <$> (BS.pack <$> vectorOf 32 arbitrary) + +instance Arbitrary BatchSize where + arbitrary = BatchSize <$> arbitrarySizedIntegral + shrink (BatchSize s) = BatchSize <$> shrink s + +-------------------------------------------------------------------------------- +-- Generators +-------------------------------------------------------------------------------- + +genBatchSize :: Gen BatchSize +genBatchSize = BatchSize <$> choose (50, 150) + +genFeeOptions :: Coin -> Gen (FeeOptions TxIn Address) +genFeeOptions dust = do + pure $ FeeOptions + { feeEstimator = FeeEstimator $ \s -> + let x = fromIntegral @_ @Integer + (length (inputs s) + length (outputs s)) + in unsafeFee $ + (C.coinToIntegral dust `div` 100) * x + C.coinToIntegral dust + , dustThreshold = DustThreshold dust + , feeBalancingPolicy = RequireBalancedFee + } + +-- | Generate a given UTxO with a particular percentage of dust +genUTxO :: Double -> Coin -> Gen (CoinMap TxIn) +genUTxO r dust = do + n <- choose (10, 1000) + inps <- genTxIn n + coins <- vectorOf n genCoin + pure $ CoinMap $ Map.fromList $ zip inps coins + where + genTxIn :: Int -> Gen [TxIn] + genTxIn n = do + ids <- vectorOf n (Hash <$> genBytes 8) + ixs <- vectorOf n arbitrary + pure $ zipWith TxIn ids ixs + + genBytes :: Int -> Gen ByteString + genBytes n = B8.pack <$> vectorOf n arbitrary + + genCoin :: Gen Coin + genCoin = unsafeCoin @Int <$> frequency + [ (round (100*r), choose (1, integralDust)) + , (round (100*(1-r)), choose (integralDust, 1000 * integralDust)) + ] + where + integralDust = C.coinToIntegral dust + +-------------------------------------------------------------------------------- +-- Utility Functions +-------------------------------------------------------------------------------- diff --git a/src/test/Cardano/CoinSelection/Algorithm/RandomImproveSpec.hs b/src/test/Cardano/CoinSelection/Algorithm/RandomImproveSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Cardano/CoinSelection/Algorithm/RandomImproveSpec.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.CoinSelection.Algorithm.RandomImproveSpec + ( spec + ) where + +import Prelude + +import Cardano.CoinSelection + ( CoinSelection (..) + , CoinSelectionAlgorithm (..) + , CoinSelectionError (..) + , CoinSelectionLimit (..) + , CoinSelectionParameters (..) + , CoinSelectionResult (..) + , InputCountInsufficientError (..) + , InputLimitExceededError (..) + , InputValueInsufficientError (..) + , InputsExhaustedError (..) + ) +import Cardano.CoinSelection.Algorithm.LargestFirst + ( largestFirst ) +import Cardano.CoinSelection.Algorithm.RandomImprove + ( randomImprove ) +import Cardano.CoinSelectionSpec + ( CoinSelProp (..) + , CoinSelectionFixture (..) + , CoinSelectionTestResult (..) + , coinSelectionUnitTest + ) +import Cardano.Test.Utilities + ( Address, TxIn, unsafeCoin ) +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 Test.Hspec + ( Spec, before, describe, it, shouldSatisfy ) +import Test.QuickCheck + ( Property, property, (===), (==>) ) + +import qualified Data.List as L + +spec :: Spec +spec = do + describe "Coin selection : random algorithm unit tests" $ do + let oneAda = 1000000 + + coinSelectionUnitTest randomImprove "" + (Right $ CoinSelectionTestResult + { rsInputs = [1,1,1,1] + , rsChange = [2] + , rsOutputs = [2] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [1,1,1,1,1,1] + , txOutputs = [2] + }) + + coinSelectionUnitTest randomImprove "" + (Right $ CoinSelectionTestResult + { rsInputs = [1,1,1,1,1,1] + , rsChange = [2,1] + , rsOutputs = [2,1] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [1,1,1,1,1,1] + , txOutputs = [2,1] + }) + + coinSelectionUnitTest randomImprove "" + (Right $ CoinSelectionTestResult + { rsInputs = [1,1,1,1,1] + , rsChange = [2] + , rsOutputs = [2,1] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [1,1,1,1,1] + , txOutputs = [2,1] + }) + + coinSelectionUnitTest randomImprove "" + (Right $ CoinSelectionTestResult + { rsInputs = [1,1,1,1] + , rsChange = [1] + , rsOutputs = [2,1] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [1,1,1,1] + , txOutputs = [2,1] + }) + + coinSelectionUnitTest randomImprove "" + (Right $ CoinSelectionTestResult + { rsInputs = [5] + , rsChange = [3] + , rsOutputs = [2] + }) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [5,5,5] + , txOutputs = [2] + }) + + coinSelectionUnitTest randomImprove "" + (Right $ CoinSelectionTestResult + { rsInputs = [10,10] + , rsChange = [8,8] + , rsOutputs = [2,2] + } + ) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [10,10,10] + , txOutputs = [2,2] + }) + + coinSelectionUnitTest randomImprove "cannot cover aim, but only min" + (Right $ CoinSelectionTestResult + { rsInputs = [1,1,1,1] + , rsChange = [1] + , rsOutputs = [3] + }) + (CoinSelectionFixture + { maxNumOfInputs = 4 + , utxoInputs = [1,1,1,1,1,1] + , txOutputs = [3] + }) + + coinSelectionUnitTest randomImprove "REG CO-450: no fallback" + (Right $ CoinSelectionTestResult + { 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 randomImprove + "enough funds, proper fragmentation, inputs depleted" + (Left (InputsExhausted InputsExhaustedError)) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [10,10,10,10] + , txOutputs = [38,1] + }) + + coinSelectionUnitTest randomImprove "" + (Left $ InputLimitExceeded $ InputLimitExceededError 2) + (CoinSelectionFixture + { maxNumOfInputs = 2 + , utxoInputs = [1,1,1,1,1,1] + , txOutputs = [3] + }) + + coinSelectionUnitTest randomImprove "each output needs maxNumInputs" + (Left $ InputLimitExceeded $ InputLimitExceededError 9) + (CoinSelectionFixture + { maxNumOfInputs = 9 + , utxoInputs = replicate 100 1 + , txOutputs = replicate 10 10 + }) + + coinSelectionUnitTest randomImprove "" + (Left $ InputValueInsufficient $ InputValueInsufficientError + (unsafeCoin @Int 39) (unsafeCoin @Int 40)) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [12,10,17] + , txOutputs = [40] + }) + + coinSelectionUnitTest randomImprove "" + (Left $ InputValueInsufficient $ InputValueInsufficientError + (unsafeCoin @Int 39) (unsafeCoin @Int 43)) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [12,10,17] + , txOutputs = [40,1,1,1] + }) + + coinSelectionUnitTest randomImprove "" + (Left $ InputCountInsufficient $ InputCountInsufficientError 3 4) + (CoinSelectionFixture + { maxNumOfInputs = 100 + , utxoInputs = [12,20,17] + , txOutputs = [40,1,1,1] + }) + + 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 @TxIn @Address) + it "forall (UTxO, NonEmpty TxOut), running algorithm gives the \ + \same errors as LargestFirst algorithm" + (property . propErrors @TxIn @Address) + +-------------------------------------------------------------------------------- +-- Properties +-------------------------------------------------------------------------------- + +propFragmentation + :: (Ord i, Ord o) + => SystemDRG + -> CoinSelProp i o + -> Property +propFragmentation drg (CoinSelProp utxo txOuts) = do + isRight selection1 && isRight selection2 ==> + let Right (CoinSelectionResult s1 _) = selection1 in + let Right (CoinSelectionResult s2 _) = selection2 in + prop (s1, s2) + where + prop (CoinSelection inps1 _ _, CoinSelection inps2 _ _) = + L.length inps1 `shouldSatisfy` (>= L.length inps2) + (selection1,_) = withDRG drg $ + runExceptT $ selectCoins randomImprove params + selection2 = runIdentity $ runExceptT $ + selectCoins largestFirst params + selectionLimit = CoinSelectionLimit $ const 100 + params = CoinSelectionParameters txOuts utxo selectionLimit + +propErrors + :: (Ord i, Ord o) + => SystemDRG + -> CoinSelProp i o + -> Property +propErrors drg (CoinSelProp 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 $ selectCoins randomImprove params + selection2 = runIdentity $ runExceptT $ + selectCoins largestFirst params + selectionLimit = CoinSelectionLimit $ const 1 + params = CoinSelectionParameters txOuts utxo selectionLimit diff --git a/src/test/Cardano/CoinSelection/FeeSpec.hs b/src/test/Cardano/CoinSelection/FeeSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Cardano/CoinSelection/FeeSpec.hs @@ -0,0 +1,1103 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.CoinSelection.FeeSpec + ( spec + + -- Internals + , FeeParameters + , stableEstimator + , valueDependentEstimator + ) where + +import Prelude hiding + ( round ) + +import Cardano.CoinSelection + ( CoinMap (..) + , CoinMapEntry (..) + , CoinSelection (..) + , CoinSelectionAlgorithm (..) + , CoinSelectionResult (..) + , coinMapFromList + , coinMapToList + , sumChange + , sumInputs + , sumOutputs + ) +import Cardano.CoinSelection.Algorithm.LargestFirst + ( largestFirst ) +import Cardano.CoinSelection.Fee + ( DustThreshold (..) + , Fee (..) + , FeeAdjustmentError (..) + , FeeBalancingPolicy (..) + , FeeEstimator (..) + , FeeOptions (..) + , adjustForFee + , coalesceDust + , distributeFee + , reduceChangeOutputs + , splitCoin + ) +import Cardano.Test.Utilities + ( Address (..) + , Hash (..) + , ShowFmt (..) + , TxIn (..) + , unsafeCoin + , unsafeDustThreshold + , unsafeFee + ) +import Control.Arrow + ( left ) +import Control.Monad + ( replicateM ) +import Control.Monad.IO.Class + ( liftIO ) +import Control.Monad.Trans.Except + ( runExceptT ) +import Crypto.Random + ( SystemDRG, getSystemDRG ) +import Crypto.Random.Types + ( withDRG ) +import Data.Either + ( isRight ) +import Data.Function + ( (&) ) +import Data.Functor.Identity + ( Identity (runIdentity) ) +import Data.List.NonEmpty + ( NonEmpty (..) ) +import Data.Monoid + ( All (..) ) +import Data.Ratio + ( (%) ) +import Fmt + ( Buildable (..), nameF, tupleF ) +import GHC.Generics + ( Generic ) +import Internal.Coin + ( Coin, coinToIntegral ) +import Internal.Rounding + ( RoundingDirection (..), round ) +import Test.Hspec + ( Spec, SpecWith, before, describe, it, shouldBe, shouldSatisfy ) +import Test.QuickCheck + ( Arbitrary (..) + , Gen + , Positive (getPositive) + , Property + , arbitraryBoundedIntegral + , checkCoverage + , choose + , counterexample + , cover + , coverTable + , disjoin + , elements + , expectFailure + , generate + , genericShrink + , oneof + , property + , scale + , tabulate + , vectorOf + , withMaxSuccess + , (.&&.) + , (===) + , (==>) + ) +import Test.QuickCheck.Monadic + ( monadicIO ) + +import qualified Cardano.CoinSelection as CS +import qualified Data.ByteString as BS +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified Internal.Coin as C + +spec :: Spec +spec = do + describe "Fee calculation : unit tests" $ do + -- Change covers fee exactly, single change output + feeUnitTest (FeeFixture + { fInps = [20] + , fOuts = [17] + , fChngs = [3] + , fUtxo = [] + , fFee = 3 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [20] + , csOuts = [17] + , csChngs = [] + }) + + -- Total change covers fee, multiple change outputs + feeUnitTest (FeeFixture + { fInps = [20,20] + , fOuts = [16,18] + , fChngs = [4,2] + , fUtxo = [] + , fFee = 6 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [20,20] + , csOuts = [16,18] + , csChngs = [] + }) + + -- Fee split evenly across change outputs + feeUnitTest (FeeFixture + { fInps = [20,20] + , fOuts = [18,18] + , fChngs = [2,2] + , fUtxo = [] + , fFee = 2 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [20,20] + , csOuts = [18,18] + , csChngs = [1,1] + }) + + -- Fee split evenly across change outputs + feeUnitTest (FeeFixture + { fInps = [20,20] + , fOuts = [17,18] + , fChngs = [3,2] + , fUtxo = [] + , fFee = 2 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [20,20] + , csOuts = [17,18] + , csChngs = [2,1] + }) + + -- Fee divvied, dust removed (dust = 0) + feeUnitTest (FeeFixture + { fInps = [20,20,20] + , fOuts = [14,18,19] + , fChngs = [6,2,1] + , fUtxo = [] + , fFee = 3 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [20,20,20] + , csOuts = [14,18,19] + , csChngs = [4,1,1] + }) + + -- Fee divvied, dust removed (dust = 1) + feeUnitTest (FeeFixture + { fInps = [20,20,20] + , fOuts = [14,18,19] + , fChngs = [6,2,1] + , fUtxo = [] + , fFee = 3 + , fDust = 1 + }) (Right $ FeeOutput + { csInps = [20,20,20] + , csOuts = [14,18,19] + , csChngs = [6] + }) + + -- Cannot cover fee, no extra inputs + feeUnitTest (FeeFixture + { fInps = [20] + , fOuts = [17] + , fChngs = [3] + , fUtxo = [] + , fFee = 4 + , fDust = 0 + }) (Left $ CannotCoverFee $ unsafeFee @Int 1) + + -- Cannot cover fee even with an extra (too small) inputs + feeUnitTest (FeeFixture + { fInps = [10] + , fOuts = [7] + , fChngs = [3] + , fUtxo = [1] + , fFee = 5 + , fDust = 0 + }) (Left $ CannotCoverFee $ unsafeFee @Int 1) + + -- Can select extra inputs to exactly cover fee, no change back + feeUnitTest (FeeFixture + { fInps = [10] + , fOuts = [7] + , fChngs = [3] + , fUtxo = [1,1] + , fFee = 5 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [10,1,1] + , csOuts = [7] + , csChngs = [] + }) + + -- Can select extra inputs to cover for fee, and leave a change back + feeUnitTest (FeeFixture + { fInps = [10] + , fOuts = [7] + , fChngs = [3] + , fUtxo = [3] + , fFee = 5 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [10,3] + , csOuts = [7] + , csChngs = [1] + }) + + -- Multiple change output, can select extra inputs to cover fee, no + -- change + feeUnitTest (FeeFixture + { fInps = [10,10] + , fOuts = [7,7] + , fChngs = [3,3] + , fUtxo = [2,2] + , fFee = 10 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [10,10,2,2] + , csOuts = [7,7] + , csChngs = [] + }) + + -- Multiple outputs, extra inputs selected, resulting change + feeUnitTest (FeeFixture + { fInps = [10,10] + , fOuts = [7,7] + , fChngs = [3,3] + , fUtxo = [3,3] + , fFee = 10 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [10,10,3,3] + , csOuts = [7,7] + , csChngs = [1,1] + }) + + -- Multiple change outputs, some bigger than actual Dust + feeUnitTest (FeeFixture + { fInps = [20,20] + , fOuts = [16,18] + , fChngs = [4,2] + , fUtxo = [] + , fFee = 6 + , fDust = 2 + }) (Right $ FeeOutput + { csInps = [20,20] + , csOuts = [16,18] + , csChngs = [] + }) + + -- Change created when there was no change before + feeUnitTest (FeeFixture + { fInps = [1] + , fOuts = [1] + , fChngs = [] + , fUtxo = [2] + , fFee = 1 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [1,2] + , csOuts = [1] + , csChngs = [1] + }) + + feeUnitTest (FeeFixture + { fInps = [] + , fOuts = [] + , fChngs = [] + , fUtxo = [3] + , fFee = 3 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [3] + , csOuts = [] + , csChngs = [] + }) + + feeUnitTest (FeeFixture + { fInps = [] + , fOuts = [] + , fChngs = [] + , fUtxo = [2,2] + , fFee = 3 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [2,2] + , csOuts = [] + , csChngs = [1] + }) + + feeUnitTest (FeeFixture + { fInps = [] + , fOuts = [] + , fChngs = [] + , fUtxo = [2,2] + , fFee = 3 + , fDust = 1 + }) (Right $ FeeOutput + { csInps = [2,2] + , csOuts = [] + , csChngs = [1] + }) + + describe "Fee Calculation: Generators" $ do + it "Arbitrary CoinSelection" $ property $ \(ShowFmt cs) -> + property $ isValidSelection @TxIn @Address cs + + before getSystemDRG $ describe "Fee Adjustment properties" $ do + it "Fee adjustment is deterministic when there's no extra inputs" + (\_ -> property $ propDeterministic @TxIn @Address) + it "Adjusting for fee (/= 0) reduces the change outputs or increase \ + \inputs" + (property . propReducedChanges @TxIn @Address) + + describe "distributeFee" $ do + it "fee portions are all within unity of ideal unrounded portions" + (checkCoverage propDistributeFeeFair) + it "fee portions are allocated optimally" + (checkCoverage propDistributeFeeOptimal) + it "Σ fst (distributeFee fee outs) == fee" + (checkCoverage propDistributeFeeSame) + it "snd (distributeFee fee outs) == outs" + (checkCoverage propDistributeFeeOuts) + it "expectFailure: not (any null (fst <$> distributeFee fee outs))" + (expectFailure propDistributeFeeNoNullFee) + + describe "coalesceDust" $ do + it "sum coins = sum (coalesceDust threshold coins)" + (checkCoverage propCoalesceDustPreservesSum) + it "all (/= Coin 0) (coalesceDust threshold coins)" + (checkCoverage propCoalesceDustLeavesNoZeroCoins) + it "leaves at most one dust coin" + (checkCoverage propCoalesceDustLeavesAtMostOneDustCoin) + it "length coins >= (coalesceDust threshold coins)" + (checkCoverage propCoalesceDustNeverLengthensList) + + describe "reduceChangeOutputs" $ do + it "data coverage is adequate" + (checkCoverage propReduceChangeOutputsDataCoverage) + it "the fee balancing algorithm converges for any coin selection" + ( withMaxSuccess 100_000 + $ propReduceChangeOutputsConverge @TxIn @Address + ) + + describe "splitCoin" $ do + it "data coverage is adequate" + (checkCoverage propSplitCoinDataCoverage) + it "preserves the total sum" + (checkCoverage propSplitCoinPreservesSum) + it "results are all within unity of ideal unrounded results" + (checkCoverage propSplitCoinFair) + +-------------------------------------------------------------------------------- +-- Fee Adjustment - Properties +-------------------------------------------------------------------------------- + +-- Check whether a selection is valid +isValidSelection :: CoinSelection i o -> Bool +isValidSelection s = + sumInputs s >= sumOutputs s `C.add` sumChange s + +-- | Data for running fee calculation properties +data FeeProp i o = FeeProp + { selection :: CoinSelection i o + -- ^ inputs from wich largestFirst can be calculated + , availableUtxo :: CoinMap i + -- ^ additional UTxO from which fee calculation will pick needed coins + , feeDust :: (Integer, Integer) + -- ^ constant fee and dust threshold + } deriving Show + +instance (Buildable i, Buildable o) => + Buildable (FeeProp i o) where + build (FeeProp cc utxo opt) = mempty + <> nameF "selection" (build cc) + <> nameF "utxo" (build (coinMapToList utxo)) + <> nameF "options" (tupleF opt) + +propDeterministic + :: forall i o . (Ord i, Ord o, Show i, Show o) + => ShowFmt (FeeProp i o) + -> Property +propDeterministic (ShowFmt (FeeProp coinSel _ (fee, dust))) = + monadicIO $ liftIO $ do + let feeOpt = feeOptions fee dust + let utxo = mempty + resultOne <- runExceptT $ adjustForFee feeOpt utxo coinSel + resultTwo <- runExceptT $ adjustForFee feeOpt utxo coinSel + resultOne `shouldBe` resultTwo + +propReducedChanges + :: forall i o . (Ord i, Show i, Show o) + => SystemDRG + -> ShowFmt (FeeProp i o) + -> Property +propReducedChanges drg (ShowFmt (FeeProp coinSel utxo (fee, dust))) = do + isRight coinSel' ==> let Right s = coinSel' in prop s + where + prop s = do + let chgs' = F.fold $ change s + let chgs = F.fold $ change coinSel + let inps' = CS.inputs s + let inps = CS.inputs coinSel + disjoin + [ chgs' `shouldSatisfy` (<= chgs) + , length inps' `shouldSatisfy` (>= length inps) + ] + feeOpt = feeOptions fee dust + coinSel' = left show $ fst $ withDRG drg $ runExceptT $ + adjustForFee feeOpt utxo coinSel + +-------------------------------------------------------------------------------- +-- distributeFee - Properties +-------------------------------------------------------------------------------- + +-- | Helper to re-apply the pre-conditions for distributeFee +propDistributeFee + :: ((Fee, NonEmpty Coin) -> Property) + -> (Fee, NonEmpty Coin) + -> Property +propDistributeFee prop (fee, outs) = + coverTable "properties" + [ ("fee > 0", 50) + , ("nOuts=1", 1) + , ("nOuts=2", 1) + , ("nOuts=2+", 10) + ] + $ tabulate "properties" + [ if fee > Fee C.zero then "fee > 0" else "fee == 0" + , "nOuts=" <> case length outs of + n | n <= 2 -> show n + _ -> "2+" + ] + $ prop (fee, outs) + +-- | Verify that fees are distributed fairly across outputs, so that every +-- rounded fee portion is always within unity of the ideal unrounded fee +-- portion. +propDistributeFeeFair + :: (Fee, NonEmpty Coin) + -> Property +propDistributeFeeFair (fee, coins) = (.&&.) + (F.all (uncurry (<=)) (NE.zip fees feeUpperBounds)) + (F.all (uncurry (>=)) (NE.zip fees feeLowerBounds)) + where + fees = fst <$> distributeFee fee coins + + feeUpperBounds = unsafeFee @Integer . ceiling . computeIdealFee <$> coins + feeLowerBounds = unsafeFee @Integer . floor . computeIdealFee <$> coins + + computeIdealFee :: Coin -> Rational + computeIdealFee c + = coinToIntegral c + * coinToIntegral (unFee fee) + % coinToIntegral (F.fold coins) + +-- | Verify that fees are distributed optimally across coins, such that the +-- absolute deviation from the ideal (unrounded) fee distribution is minimal. +propDistributeFeeOptimal + :: Fee + -> NonEmpty Coin + -> Property +propDistributeFeeOptimal fee coins = property $ + computeDeviation (fst <$> distributeFee fee coins) + `shouldBe` minimumPossibleDeviation + where + -- Compute the deviation of a fee portion distribution from the ideal + -- unrounded fee portion distribution. + computeDeviation :: NonEmpty Fee -> Rational + computeDeviation feesRounded = F.sum $ + NE.zipWith zipper + feesRounded + idealUnroundedDistribution + where + zipper :: Fee -> Rational -> Rational + zipper (Fee roundedFee) unroundedFee = abs $ + fromIntegral (coinToIntegral @Integer roundedFee) - unroundedFee + + -- The minimum deviation across all possible distributions for the given + -- fee and set of coins. + minimumPossibleDeviation :: Rational + minimumPossibleDeviation = + F.minimum $ computeDeviation <$> allPossibleDistributions + + -- The set of all possible fee distributions for the given fee and coins. + allPossibleDistributions :: [NonEmpty Fee] + allPossibleDistributions = filter isValidDistribution $ NE.zipWith + (\f roundDir -> + unsafeFee @Integer $ fromIntegral @Integer $ round roundDir f) + idealUnroundedDistribution <$> allPossibleRoundings + where + -- Indicates whether the given distribution has the correct total fee. + isValidDistribution :: NonEmpty Fee -> Bool + isValidDistribution r = F.fold r == fee + + -- All possible ways to round an unrounded fee distribution. + allPossibleRoundings :: [NonEmpty RoundingDirection] + allPossibleRoundings = traverse (const [RoundUp, RoundDown]) coins + + -- The ideal unrounded fee distribution. + idealUnroundedDistribution :: NonEmpty Rational + idealUnroundedDistribution = computeIdealFee <$> coins + where + computeIdealFee :: Coin -> Rational + computeIdealFee c + = coinToIntegral c + * coinToIntegral (unFee fee) + % coinToIntegral (F.fold coins) + +-- | Sum of the fees divvied over each output is the same as the initial total +-- fee. +propDistributeFeeSame + :: (Fee, NonEmpty Coin) + -> Property +propDistributeFeeSame = propDistributeFee $ \(fee, outs) -> + F.fold (fst <$> distributeFee fee outs) === fee + +-- | distributeFee doesn't change any of the outputs +propDistributeFeeOuts + :: (Fee, NonEmpty Coin) + -> Property +propDistributeFeeOuts = propDistributeFee $ \(fee, outs) -> + (snd <$> distributeFee fee outs) === outs + +-- | distributeFee never generates null fees for a given output. +-- +-- This is NOT a property. It is here to illustrate that this can happen in +-- practice, and is known as a possible outcome for the distributeFee function +-- (it is fine for one of the output to be assigned no fee). The only reason +-- this would happen is because there would be less outputs than the fee amount +-- which is probably never going to happen in practice... +propDistributeFeeNoNullFee + :: (Fee, NonEmpty Coin) + -> Property +propDistributeFeeNoNullFee (fee, outs) = + not (null outs) ==> withMaxSuccess 100000 prop + where + prop = property $ Fee C.zero `F.notElem` (fst <$> distributeFee fee outs) + +-------------------------------------------------------------------------------- +-- coalesceDust - Properties +-------------------------------------------------------------------------------- + +data CoalesceDustData = CoalesceDustData + { cddThreshold :: DustThreshold + , cddCoins :: NonEmpty Coin + } deriving (Eq, Generic, Show) + +instance Arbitrary CoalesceDustData where + arbitrary = do + coinCount <- genCoinCount + coins <- (:|) <$> genCoin <*> replicateM coinCount genCoin + threshold <- DustThreshold <$> oneof + [ -- Two possibilities: + genCoin + -- ^ A completely fresh coin. + , elements (F.toList coins) + -- ^ A coin picked from the existing coin set. + ] + pure $ CoalesceDustData threshold coins + where + genCoin = unsafeCoin @Int <$> oneof [pure 0, choose (1, 100)] + genCoinCount = choose (0, 10) + shrink = genericShrink + +propCoalesceDustPreservesSum :: CoalesceDustData -> Property +propCoalesceDustPreservesSum (CoalesceDustData threshold coins) = + property $ + let total = F.fold coins in + cover 8 (total == C.zero) "sum coins = 0" $ + cover 8 (total /= C.zero) "sum coins ≠ 0" $ + total == F.fold (coalesceDust threshold coins) + +propCoalesceDustLeavesNoZeroCoins :: CoalesceDustData -> Property +propCoalesceDustLeavesNoZeroCoins (CoalesceDustData threshold coins) = + property $ + cover 4 (F.all (== C.zero) coins) "∀ coin ∈ coins . coin = 0" $ + cover 4 (F.elem (C.zero) coins) "∃ coin ∈ coins . coin = 0" $ + cover 8 (F.notElem (C.zero) coins) "∀ coin ∈ coins . coin > 0" $ + F.notElem C.zero $ coalesceDust threshold coins + +propCoalesceDustLeavesAtMostOneDustCoin :: CoalesceDustData -> Property +propCoalesceDustLeavesAtMostOneDustCoin (CoalesceDustData threshold coins) = + property $ + let result = coalesceDust threshold coins in + -- Check that we cover different kinds of extreme threshold conditions: + cover 2 (F.all (< threshold') coins) "∀ coin ∈ coins . coin < threshold" $ + cover 2 (F.all (> threshold') coins) "∀ coin ∈ coins . coin > threshold" $ + cover 2 (F.all (== threshold') coins) "∀ coin ∈ coins . coin = threshold" $ + cover 2 (F.all (/= threshold') coins) "∀ coin ∈ coins . coin ≠ threshold" $ + -- Check that we cover typical threshold conditions: + let haveMixture = getAll $ mconcat $ All <$> + [ F.any (< threshold') coins + , F.any (== threshold') coins + , F.any (> threshold') coins + ] in + cover 8 haveMixture "have mixture of coin values in relation to threshold" $ + -- Check that we cover different result lengths: + cover 8 (null result) "length result = 0" $ + cover 8 (length result == 1) "length result = 1" $ + cover 8 (length result >= 2) "length result ≥ 2" $ + case result of + [ ] -> F.fold coins == C.zero + [x] -> F.fold coins == x + cxs -> all (> threshold') cxs + where + threshold' = unDustThreshold threshold + +propCoalesceDustNeverLengthensList :: CoalesceDustData -> Property +propCoalesceDustNeverLengthensList (CoalesceDustData threshold coins) = + property $ length coins >= length (coalesceDust threshold coins) + +-------------------------------------------------------------------------------- +-- reduceChangeOutputs - Properties +-------------------------------------------------------------------------------- + +data ReduceChangeOutputsData = ReduceChangeOutputsData + { rcodFee :: Fee + , rcodThreshold :: DustThreshold + , rcodCoins :: [Coin] + } deriving (Eq, Generic, Show) + +instance Arbitrary ReduceChangeOutputsData where + arbitrary = do + coalesceDustData <- arbitrary + let threshold = cddThreshold coalesceDustData + let coins = F.toList $ cddCoins coalesceDustData + let coinSum = sum $ coinToIntegral <$> coins + fee <- unsafeFee <$> oneof + [ pure 0 + , choose (1, safePred coinSum) + , pure coinSum + , choose (coinSum + 1, coinSum * 2) + ] + pure $ ReduceChangeOutputsData fee threshold coins + where + safePred :: Integer -> Integer + safePred x + | x > 0 = x - 1 + | otherwise = 0 + shrink = genericShrink + +propReduceChangeOutputsDataCoverage :: ReduceChangeOutputsData -> Property +propReduceChangeOutputsDataCoverage + (ReduceChangeOutputsData (Fee fee) _ coins) = + let coinSum = F.fold coins in + property + -- Test coverage of fee amount, relative to sum of coins: + $ cover 100 (fee >= C.zero) + "fee >= 0" + $ cover 8 (fee == C.zero) + "fee = 0" + $ cover 8 (length (filter (> C.zero) coins) == 1) + "one non-empty coin" + $ cover 8 (length (filter (> C.zero) coins) == 2) + "two non-empty coins" + $ cover 8 (length (filter (> C.zero) coins) >= 3) + "several non-empty coins" + $ cover 8 (any (> C.zero) coins && C.zero < fee && fee < coinSum) + "0 < fee < sum coins" + $ cover 8 (any (> C.zero) coins && fee == coinSum) + "fee = sum coins" + $ cover 8 (any (> C.zero) coins && fee > coinSum) + "fee > sum coins" + True + +propReduceChangeOutputsConverge + :: (Show i, Show o) + => CoinSelection i o + -> FeeOptions i o + -> Property +propReduceChangeOutputsConverge sel opts = do + let Right (sel', remainder) = reduceChangeOutputs opts sel + let fee = estimateFee (feeEstimator opts) sel' + let prop = case feeBalancingPolicy opts of + -- If fees are null and we require balanced selections, then the + -- selection must be exactly balanced. + RequireBalancedFee | remainder == Fee C.zero -> + (Fee <$> delta sel') == Just fee + + -- Otherwise, either the change outputs are null, or the delta is + -- positive because of the dangling output and we'll have to pay for + -- it. + RequireBalancedFee -> + null (change sel') || (delta sel' >= Just C.zero) + + -- If fees are null and we do not require balanced selections, then + -- the selection must leave __at least__ the fee amount. + RequireMinimalFee | remainder == Fee C.zero -> + (Fee <$> delta sel') >= Just fee + + -- Otherwise, the change outputs are necessarily null. + RequireMinimalFee -> + null (change sel') + property prop + & counterexample (unlines + [ "new selection: " <> show sel' + , "delta (before): " <> show (delta sel) + , "delta (after): " <> show (delta sel') + , "remainder: " <> show remainder + ]) + where + delta s = sumInputs s `C.sub` (sumOutputs s `C.add` sumChange s) + +-------------------------------------------------------------------------------- +-- splitCoin - Properties +-------------------------------------------------------------------------------- + +data SplitCoinData = SplitCoinData + { scdCoinToSplit :: Coin + , scdCoinsToIncrease :: [Coin] + } deriving (Eq, Generic, Show) + +instance Arbitrary SplitCoinData where + arbitrary = do + coinToSplit <- genCoin + n <- oneof + [ pure 0 + , pure 1 + , choose (2, 10) + ] + coinsToIncrease <- replicateM n genCoin + pure $ SplitCoinData coinToSplit coinsToIncrease + where + genCoin :: Gen Coin + genCoin = oneof + [ pure $ unsafeCoin @Integer 0 + , pure $ unsafeCoin @Integer 1 + , unsafeCoin @Int . (+ 1) . getPositive <$> arbitrary + ] + shrink = genericShrink + +propSplitCoinDataCoverage :: SplitCoinData -> Property +propSplitCoinDataCoverage (SplitCoinData coinToSplit coinsToIncrease) = + property + $ cover 8 (null coinsToIncrease) + "list of coins is empty" + $ cover 8 (length coinsToIncrease == 1) + "list of coins is singleton" + $ cover 8 (length coinsToIncrease > 1) + "list of coins has multiple entries" + $ cover 8 (C.zero `elem` coinsToIncrease) + "list of coins has at least one zero coin" + $ cover 8 (any (> C.zero) coinsToIncrease) + "list of coins has at least one non-zero coin" + $ cover 8 (coinToSplit == C.zero) + "coin to split is zero" + $ cover 8 (coinToSplit > C.zero) + "coin to split is non-zero" + $ cover 8 (length coinsToIncrease > coinToIntegral coinToSplit) + "coin to split is smaller than number of coins to increase" + True + +propSplitCoinPreservesSum :: SplitCoinData -> Property +propSplitCoinPreservesSum (SplitCoinData coinToSplit coinsToIncrease) = + property $ totalBefore `shouldBe` totalAfter + where + totalAfter = F.fold (splitCoin coinToSplit coinsToIncrease) + totalBefore = coinToSplit `C.add` F.fold coinsToIncrease + +propSplitCoinFair :: (Coin, NonEmpty Coin) -> Property +propSplitCoinFair (coinToSplit, coinsToIncrease) = (.&&.) + (F.all (uncurry (<=)) (NE.zip results upperBounds)) + (F.all (uncurry (>=)) (NE.zip results lowerBounds)) + where + results = NE.fromList $ splitCoin coinToSplit $ NE.toList coinsToIncrease + + upperBounds = unsafeCoin @Integer . ceiling + . computeIdealResult <$> coinsToIncrease + lowerBounds = unsafeCoin @Integer . floor + . computeIdealResult <$> coinsToIncrease + + computeIdealResult :: Coin -> Rational + computeIdealResult c + = fromIntegral (coinToIntegral @Integer c) + + coinToIntegral @Integer coinToSplit + % fromIntegral (length coinsToIncrease) + +-------------------------------------------------------------------------------- +-- Fee Adjustment - Unit Tests +-------------------------------------------------------------------------------- + +feeOptions + :: Integer + -> Integer + -> FeeOptions i o +feeOptions fee dust = FeeOptions + { feeEstimator = FeeEstimator $ + \_ -> unsafeFee fee + , dustThreshold = + unsafeDustThreshold dust + , feeBalancingPolicy = + RequireBalancedFee + } + +feeUnitTest + :: FeeFixture + -> Either (FeeAdjustmentError TxIn Address) FeeOutput + -> SpecWith () +feeUnitTest (FeeFixture inpsF outsF chngsF utxoF feeF dustF) expected = + it title $ do + (utxo, sel) <- setup @TxIn @Address + result <- runExceptT $ do + (CoinSelection inps outs chngs) <- + adjustForFee (feeOptions feeF dustF) utxo sel + return $ FeeOutput + { csInps = coinToIntegral . entryValue <$> coinMapToList inps + , csOuts = coinToIntegral . entryValue <$> coinMapToList outs + , csChngs = coinToIntegral <$> chngs + } + fmap sortFeeOutput result `shouldBe` fmap sortFeeOutput expected + where + setup + :: forall i o . (Arbitrary i, Arbitrary o, Ord i, Ord o) + => IO (CoinMap i, CoinSelection i o) + setup = do + utxo <- generate (genInputs $ unsafeCoin <$> utxoF) + inps <- (fmap (uncurry CoinMapEntry) . Map.toList . unCoinMap) <$> + generate (genInputs $ unsafeCoin <$> inpsF) + outs <- generate (genOutputs $ unsafeCoin <$> outsF) + let chngs = map unsafeCoin chngsF + pure (utxo, CoinSelection (coinMapFromList inps) outs chngs) + + title :: String + title = mempty + <> "CoinSelection (inps=" <> show inpsF + <> "outs=" <> show outsF + <> "chngs=" <> show chngsF + <> "), UTxO=" <> show utxoF + <> "), fee=" <> show feeF + <> " --> " <> show expected + +-- | A fixture for testing the fee calculation +data FeeFixture = FeeFixture + { fInps :: [Integer] + -- ^ Value (in Lovelace) & number of coins in inputs + , fOuts :: [Integer] + -- ^ Value (in Lovelace) & number of requested outputs + , fChngs :: [Integer] + -- ^ Value (in Lovelace) & number of changes + , fUtxo :: [Integer] + -- ^ Value (in Lovelace) & number of available coins in the UTxO + , fFee :: Integer + -- ^ Value (in Lovelace) of rigid fee + , fDust :: Integer + -- ^ Value (in Lovelace) of dust + } deriving Show + +-- | A fee calculation output +data FeeOutput = FeeOutput + { csInps :: [Integer] + -- ^ Value (in Lovelace) & number of available coins in the UTxO + , csOuts :: [Integer] + -- ^ Value (in Lovelace) & number of requested outputs + , csChngs :: [Integer] + -- ^ Value (in Lovelace) & number of changes + } deriving (Show, Eq) + +sortFeeOutput :: FeeOutput -> FeeOutput +sortFeeOutput (FeeOutput is os cs) = + FeeOutput (L.sort is) (L.sort os) (L.sort cs) + +-------------------------------------------------------------------------------- +-- Arbitrary Instances +-------------------------------------------------------------------------------- + +deriving newtype instance Arbitrary a => Arbitrary (ShowFmt a) + +genInputs :: (Arbitrary i, Ord i) => [Coin] -> Gen (CoinMap i) +genInputs coins = do + let n = length coins + inps <- vectorOf n arbitrary + return $ CoinMap $ Map.fromList $ zip inps coins + +genOutputs :: (Arbitrary o, Ord o) => [Coin] -> Gen (CoinMap o) +genOutputs coins = do + let n = length coins + outs <- vectorOf n arbitrary + return $ coinMapFromList $ zipWith CoinMapEntry outs coins + +genSelection + :: (Arbitrary i, Ord i, Ord o) + => CoinMap o + -> Gen (CoinSelection i o) +genSelection outs = do + utxo <- vectorOf (length outs * 3) arbitrary >>= genInputs + let selectionLimit = CS.CoinSelectionLimit $ const 100 + let params = CS.CoinSelectionParameters utxo outs selectionLimit + case runIdentity $ runExceptT $ selectCoins largestFirst params of + Left _ -> genSelection outs + Right (CoinSelectionResult s _) -> return s + +instance Arbitrary TxIn where + shrink _ = [] + arbitrary = TxIn + <$> arbitrary + <*> scale (`mod` 3) arbitrary -- No need for a high indexes + +instance Arbitrary Coin where + arbitrary = unsafeCoin @Int <$> choose (1, 100_000) + shrink = fmap unsafeCoin . filter (> 0) . shrink . coinToIntegral @Int + +instance Arbitrary DustThreshold where + arbitrary = unsafeDustThreshold @Int <$> choose (0, 100) + shrink = fmap DustThreshold . shrink . unDustThreshold + +instance Arbitrary Fee where + arbitrary = unsafeFee @Int <$> choose (1, 100_000) + shrink = fmap Fee . shrink . unFee + +instance (Arbitrary i, Arbitrary o, Ord i, Ord o) => + Arbitrary (FeeProp i o) + where + shrink (FeeProp cs utxo opts) = + case Map.toList $ unCoinMap utxo of + [] -> + map (\cs' -> FeeProp cs' utxo opts) (shrink cs) + us -> + concatMap (\cs' -> + [ FeeProp cs' mempty opts + , FeeProp cs' (CoinMap $ Map.fromList (drop 1 us)) opts + ] + ) (shrink cs) + arbitrary = do + cs <- arbitrary + utxo <- choose (0, 50) + >>= \n -> vectorOf n arbitrary + >>= genInputs + fee <- choose (100000, 500000) + dust <- choose (0, 10000) + return $ FeeProp cs utxo (fee, dust) + +instance Arbitrary (Hash "Tx") where + shrink _ = [] + arbitrary = do + bytes <- BS.pack <$> vectorOf 8 arbitraryBoundedIntegral + pure $ Hash bytes + +instance Arbitrary Address where + shrink _ = [] + arbitrary = do + bytes <- BS.pack <$> vectorOf 8 arbitraryBoundedIntegral + pure $ Address bytes + +instance (Arbitrary i, Arbitrary o, Ord i, Ord o) => + Arbitrary (CoinSelection i o) + where + shrink sel = case unCoinSelection sel of + ([_], [_], []) -> + [] + (inps, outs, chgs) -> + let + inps' = if length inps > 1 then drop 1 inps else inps + outs' = if length outs > 1 then drop 1 outs else outs + chgs' = if not (null chgs) then drop 1 chgs else chgs + in + filter (\s -> s /= sel && isValidSelection s) $ + mkCoinSelection <$> + [ (inps', outs', chgs') + , (inps', outs , chgs ) + , (inps , outs', chgs ) + , (inps , outs , chgs') + ] + where + unCoinSelection s = + (coinMapToList $ inputs s, coinMapToList $ outputs s, change s) + mkCoinSelection (is, os, cs) = + CoinSelection (coinMapFromList is) (coinMapFromList os) cs + arbitrary = do + outs <- choose (1, 10) + >>= \n -> vectorOf n arbitrary + >>= genOutputs + genSelection outs + +data FeeParameters i o = FeeParameters + { feePerTransaction + :: Fee + -- ^ Base fee for a transaction. + , feePerTransactionEntry + :: Fee + -- ^ Incremental fee for each input, output, and change output. + } deriving (Eq, Generic, Show) + +instance Arbitrary (FeeParameters i o) where + arbitrary = do + feePerTransaction <- unsafeFee @Int <$> choose (0, 10) + feePerTransactionEntry <- unsafeFee @Int <$> choose (0, 10) + pure $ FeeParameters {feePerTransaction, feePerTransactionEntry} + shrink = genericShrink + +-- An estimator that solely depends on the number of inputs and outputs. +stableEstimator :: FeeParameters i o -> FeeEstimator i o +stableEstimator + FeeParameters {feePerTransaction, feePerTransactionEntry} = + FeeEstimator $ \s -> Fee $ maybe C.zero + (C.add (unFee feePerTransaction)) + (C.mul + (unFee feePerTransactionEntry) + (length (inputs s) + length (outputs s))) + +-- An estimator which depends on the size of inputs and outputs, where the size +-- is a function of their number and their value. The bigger the coins, the +-- bigger the fee. +valueDependentEstimator :: FeeParameters i o -> FeeEstimator i o +valueDependentEstimator + FeeParameters {feePerTransaction, feePerTransactionEntry} = + FeeEstimator $ \s -> Fee $ maybe C.zero + (C.add (unFee feePerTransaction)) + (C.mul + (unFee feePerTransactionEntry) + (length (inputs s) + length (outputs s) + size (change s))) + where + size :: [Coin] -> Int + size = sum . fmap sizeOfOne + where + sizeOfOne :: Coin -> Int + sizeOfOne coin + | coin < C.coinFromNatural 1_000 = 1 + | coin < C.coinFromNatural 10_000 = 2 + | coin < C.coinFromNatural 100_000 = 3 + | otherwise = 4 + +instance Arbitrary (FeeOptions i o) where + arbitrary = do + dustThreshold <- unsafeDustThreshold @Int <$> choose (0, 10) + feeEstimator <- oneof + [ stableEstimator <$> arbitrary + , valueDependentEstimator <$> arbitrary + ] + feeBalancingPolicy <- elements [RequireBalancedFee, RequireMinimalFee] + return $ FeeOptions {dustThreshold, feeEstimator, feeBalancingPolicy} + +instance Arbitrary a => Arbitrary (NonEmpty a) where + arbitrary = do + tailLength <- choose (0, 10) + (:|) <$> arbitrary <*> replicateM tailLength arbitrary + shrink = genericShrink + +instance Show (FeeOptions i o) where + show (FeeOptions _ dust policy) = show (dust, policy) diff --git a/src/test/Cardano/CoinSelection/TypesSpec.hs b/src/test/Cardano/CoinSelection/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Cardano/CoinSelection/TypesSpec.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.CoinSelection.TypesSpec + ( spec + ) where + +import Prelude + +import Cardano.CoinSelection + ( CoinMap (..), coinMapValue ) +import Cardano.Test.Utilities + ( Address (..) + , Hash (..) + , ShowFmt (..) + , TxIn (..) + , TxOut (..) + , excluding + , isSubsetOf + , restrictedBy + , restrictedTo + , unsafeCoin + , unsafeFromHex + ) +import Data.Set + ( Set, (\\) ) +import Internal.Coin + ( Coin ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Arbitrary (..) + , Property + , checkCoverage + , choose + , cover + , oneof + , property + , scale + , vectorOf + , (===) + ) + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Internal.Coin as C + +spec :: Spec +spec = do + + describe "Lemma 2.1 - Properties of UTxO operations" $ do + it "2.1.1) ins⊲ u ⊆ u" + (checkCoverage $ prop_2_1_1 @TxIn) + it "2.1.2) ins⋪ u ⊆ u" + (checkCoverage $ prop_2_1_2 @TxIn) + it "2.1.3) u ⊳ outs ⊆ u" + (checkCoverage $ prop_2_1_3 @TxIn) + it "2.1.4) ins⊲ (u ⋃ v) = (ins⊲ u) ⋃ (ins⊲ v)" + (checkCoverage $ prop_2_1_4 @TxIn) + it "2.1.5) ins⋪ (u ⋃ v) = (ins⋪ u) ⋃ (ins⋪ v)" + (checkCoverage $ prop_2_1_5 @TxIn) + it "2.1.6) (dom u ⋂ ins) ⊲ u = ins⊲ u" + (checkCoverage $ prop_2_1_6 @TxIn) + it "2.1.7) (dom u ⋂ ins) ⋪ u = ins⋪ u" + (checkCoverage $ prop_2_1_7 @TxIn) + it "2.1.8) (dom u ⋃ ins) ⋪ (u ⋃ v) = (ins ⋃ dom u) ⋪ v" + (checkCoverage $ prop_2_1_8 @TxIn) + it "2.1.9) ins⋪ u = (dom u \\ ins)⊲ u" + (checkCoverage $ prop_2_1_9 @TxIn) + + describe "Lemma 2.6 - Properties of balance" $ do + it "2.6.1) dom u ⋂ dom v ==> balance (u ⋃ v) = balance u + balance v" + (checkCoverage $ prop_2_6_1 @TxIn) + it "2.6.2) balance (ins⋪ u) = balance u - balance (ins⊲ u)" + (checkCoverage $ prop_2_6_2 @TxIn) + +-------------------------------------------------------------------------------- +-- Wallet Specification - Lemma 2.1 - Properties of UTxO operations +-------------------------------------------------------------------------------- + +prop_2_1_1 :: Ord u => (Set u, CoinMap u) -> Property +prop_2_1_1 (ins, u) = + cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop) + where + cond = not $ Set.null $ dom u `Set.intersection` ins + prop = (u `restrictedBy` ins) `isSubsetOf` u + +prop_2_1_2 :: Ord u => (Set u, CoinMap u) -> Property +prop_2_1_2 (ins, u) = + cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop) + where + cond = not $ Set.null $ dom u `Set.intersection` ins + prop = (u `excluding` ins) `isSubsetOf` u + +prop_2_1_3 :: Ord u => (Set Coin, CoinMap u) -> Property +prop_2_1_3 (outs, u) = + cover 50 cond "u ⋂ outs ≠ ∅" (property prop) + where + cond = not $ Set.null $ + Set.fromList (Map.elems (unCoinMap u)) `Set.intersection` outs + prop = (u `restrictedTo` outs) `isSubsetOf` u + +prop_2_1_4 :: (Ord u, Show u) => (Set u, CoinMap u, CoinMap u) -> Property +prop_2_1_4 (ins, u, v) = + cover 50 cond "(dom u ⋃ dom v) ⋂ ins ≠ ∅" (property prop) + where + cond = not $ Set.null $ Set.union (dom u) (dom v) `Set.intersection` ins + prop = + ((u <> v) `restrictedBy` ins) + === + (u `restrictedBy` ins) <> (v `restrictedBy` ins) + +prop_2_1_5 :: (Ord u, Show u) => (Set u, CoinMap u, CoinMap u) -> Property +prop_2_1_5 (ins, u, v) = + cover 50 cond "(dom u ⋃ dom v) ⋂ ins ≠ ∅" (property prop) + where + cond = not $ Set.null $ Set.union (dom u) (dom v) `Set.intersection` ins + prop = + ((u <> v) `excluding` ins) + === + (u `excluding` ins) <> (v `excluding` ins) + +prop_2_1_6 :: (Ord u, Show u) => (Set u, CoinMap u) -> Property +prop_2_1_6 (ins, u) = + cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop) + where + cond = not $ Set.null $ dom u `Set.intersection` ins + prop = + (u `restrictedBy` (dom u `Set.intersection` ins)) + === + (u `restrictedBy` ins) + +prop_2_1_7 :: (Ord u, Show u) => (Set u, CoinMap u) -> Property +prop_2_1_7 (ins, u) = + cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop) + where + cond = not $ Set.null $ dom u `Set.intersection` ins + prop = + (u `excluding` (dom u `Set.intersection` ins)) + === + (u `excluding` ins) + +prop_2_1_8 :: (Ord u, Show u) => (Set u, CoinMap u, CoinMap u) -> Property +prop_2_1_8 (ins, u, v) = + cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop) + where + cond = not $ Set.null $ dom u `Set.intersection` ins + prop = + ((u <> v) `excluding` (dom u <> ins)) + === + v `excluding` (ins <> dom u) + +prop_2_1_9 :: (Ord u, Show u) => (Set u, CoinMap u) -> Property +prop_2_1_9 (ins, u) = + cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop) + where + cond = not $ Set.null $ dom u `Set.intersection` ins + prop = (u `excluding` ins) === u `restrictedBy` (dom u \\ ins) + +-------------------------------------------------------------------------------- +-- Wallet Specification - Lemma 2.6 - Properties of Balance +-------------------------------------------------------------------------------- + +prop_2_6_1 :: Ord u => (CoinMap u, CoinMap u) -> Property +prop_2_6_1 (u, v) = + cover 50 cond "u ≠ ∅ , v ≠ ∅" (property prop) + where + -- NOTE: + -- A precondition (u ⋂ v = ∅ ) is hard to satisfy because our generators + -- are built in order to not be 'too entropic'. So, we better just create + -- a v' that has no overlap with u. + v' = v `excluding` dom u + cond = not (u `isSubsetOf` mempty || v' `isSubsetOf` mempty) + prop = coinMapValue (u <> v') + === coinMapValue u `C.add` coinMapValue v' + +prop_2_6_2 :: Ord u => (Set u, CoinMap u) -> Property +prop_2_6_2 (ins, u) = + cover 50 cond "dom u ⋂ ins ≠ ∅" (property prop) + where + cond = not $ Set.null $ dom u `Set.intersection` ins + prop = + Just (coinMapValue (u `excluding` ins)) + === + coinMapValue u `C.sub` + coinMapValue (u `restrictedBy` ins) + +-------------------------------------------------------------------------------- +-- UTxO Utilities +-------------------------------------------------------------------------------- + +-- | Extracts the domain of a UTxO: the set of references to unspent transaction +-- ouputs. +dom :: CoinMap u -> Set u +dom (CoinMap utxo) = Map.keysSet utxo + +-------------------------------------------------------------------------------- +-- Arbitrary Instances +-- +-- Arbitrary instances define here aren't necessarily reflecting on real-life +-- scenario, but they help test the property above by constructing data +-- structures that don't have much entropy and therefore, allow us to even test +-- something when checking for intersections and set restrictions! +-------------------------------------------------------------------------------- + +deriving instance Arbitrary a => Arbitrary (ShowFmt a) + +instance Arbitrary (Hash "Tx") where + -- No Shrinking + arbitrary = oneof + [ pure $ Hash $ unsafeFromHex + "0000000000000000000000000000000000000000000000000000000000000001" + , pure $ Hash $ unsafeFromHex + "0000000000000000000000000000000000000000000000000000000000000002" + , pure $ Hash $ unsafeFromHex + "0000000000000000000000000000000000000000000000000000000000000003" + ] + +instance Arbitrary Address where + -- No Shrinking + arbitrary = oneof + [ pure $ Address "ADDR01" + , pure $ Address "ADDR02" + , pure $ Address "ADDR03" + ] + +instance Arbitrary Coin where + -- No Shrinking + arbitrary = unsafeCoin @Int <$> choose (0, 3) + +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 crazy high indexes + +instance (Arbitrary u, Ord u) => Arbitrary (CoinMap u) where + shrink (CoinMap utxo) = CoinMap <$> shrink utxo + arbitrary = do + n <- choose (0, 10) + utxo <- zip + <$> vectorOf n arbitrary + <*> vectorOf n arbitrary + return $ CoinMap $ Map.fromList utxo diff --git a/src/test/Cardano/CoinSelectionSpec.hs b/src/test/Cardano/CoinSelectionSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Cardano/CoinSelectionSpec.hs @@ -0,0 +1,460 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.CoinSelectionSpec + ( spec + + -- * Export used to test various coin selection implementations + , CoinSelectionFixture (..) + , CoinSelectionTestResult (..) + , CoinSelProp (..) + , coinSelectionUnitTest + ) where + +-- | This module contains shared functionality for coin selection tests. +-- +-- Coin selection algorithms share a common interface, and therefore it makes +-- sense for them to also share arbitrary instances and tests. + +import Prelude + +import Cardano.CoinSelection + ( CoinMap (..) + , CoinMapEntry (..) + , CoinSelection (..) + , CoinSelectionAlgorithm (..) + , CoinSelectionError (..) + , CoinSelectionLimit (..) + , CoinSelectionParameters (..) + , CoinSelectionResult (..) + , coinMapFromList + , coinMapToList + , coinMapValue + , sumChange + , sumInputs + , sumOutputs + ) +import Cardano.Test.Utilities + ( Address (..), Hash (..), ShowFmt (..), TxIn (..), unsafeCoin ) +import Control.Arrow + ( (&&&) ) +import Control.Monad.Trans.Except + ( runExceptT ) +import Data.Function + ( (&) ) +import Data.List.NonEmpty + ( NonEmpty (..) ) +import Data.Maybe + ( catMaybes ) +import Data.Set + ( Set ) +import Data.Word + ( Word16, Word8 ) +import Fmt + ( Buildable (..), blockListF, nameF ) +import Internal.Coin + ( Coin, coinToIntegral ) +import Test.Hspec + ( Spec, SpecWith, describe, it, shouldBe ) +import Test.QuickCheck + ( Arbitrary (..) + , Confidence (..) + , Gen + , NonEmptyList (..) + , Property + , arbitraryBoundedIntegral + , checkCoverage + , checkCoverageWith + , choose + , cover + , elements + , generate + , genericShrink + , oneof + , property + , scale + , vectorOf + ) +import Test.QuickCheck.Monadic + ( monadicIO ) +import Test.Vector.Shuffle + ( shuffle ) + +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 +import qualified Data.Set as Set +import qualified Internal.Coin as C +import qualified Test.QuickCheck.Monadic as QC + +spec :: Spec +spec = do + describe "CoinMap properties" $ do + it "CoinMap coverage is adequate" $ + checkCoverage $ prop_CoinMap_coverage @Int + it "CoinMapEntry coverage is adequate" $ + checkCoverage $ prop_CoinMapEntry_coverage @Int + it "coinMapFromList preserves total value for each unique key" $ + checkCoverage $ + prop_coinMapFromList_preservesTotalValueForEachUniqueKey @Int + it "coinMapFromList preserves total value" $ + checkCoverage $ prop_coinMapFromList_preservesTotalValue @Int + it "coinMapToList preserves total value" $ + checkCoverage $ prop_coinMapToList_preservesTotalValue @Int + it "coinMapFromList . coinMapToList = id" $ + checkCoverage $ prop_coinMapToList_coinMapFromList @Int + it "coinMapToList . coinMapFromList = id (when no keys duplicated)" $ + checkCoverage $ prop_coinMapFromList_coinMapToList @Int + it "coinMapToList order deterministic" $ + checkCoverageWith lowerConfidence $ + prop_coinMapToList_orderDeterministic @Int + + describe "CoinSelection properties" $ do + it "monoidal append preserves keys" $ + checkCoverage $ prop_coinSelection_mappendPreservesKeys @Int @Int + it "monoidal append preserves value" $ + checkCoverage $ + prop_coinSelection_mappendPreservesTotalValue @Int @Int + + where + lowerConfidence :: Confidence + lowerConfidence = Confidence (10^(6 :: Integer)) 0.75 + +-------------------------------------------------------------------------------- +-- Properties +-------------------------------------------------------------------------------- + +prop_CoinMap_coverage + :: CoinMap u + -> Property +prop_CoinMap_coverage m = property + $ cover 10 (null m) + "coin map is empty" + $ cover 10 (length m == 1) + "coin map has one entry" + $ cover 10 (length m >= 2) + "coin map has multiple entries" + $ cover 10 (1 == length (Set.fromList $ entryValue <$> coinMapToList m)) + "coin map has one unique value" + $ cover 10 (1 < length (Set.fromList $ entryValue <$> coinMapToList m)) + "coin map has several unique values" + True + +prop_CoinMapEntry_coverage :: forall u . Ord u => [CoinMapEntry u] -> Property +prop_CoinMapEntry_coverage entries = property + $ cover 2 (null entries) + "coin map entry list is empty" + $ cover 2 (length entries == 1) + "coin map entry list has one entry" + $ cover 2 (length entries == 2) + "coin map entry list has two entries" + $ cover 2 (length entries >= 3) + "coin map entry list has multiple entries" + $ cover 2 (not (null entries) && length uniqueKeys == 1) + "coin map entry list has one unique key" + $ cover 2 (not (null entries) && length uniqueKeys == 2) + "coin map entry list has two unique keys" + $ cover 2 (not (null entries) && length uniqueKeys >= 3) + "coin map entry list has multiple unique keys" + $ cover 2 (not (null entries) && null duplicateKeys) + "coin map entry list has no duplicate keys" + $ cover 2 (not (null entries) && length duplicateKeys == 1) + "coin map entry list has one duplicate key" + $ cover 2 (not (null entries) && length duplicateKeys == 2) + "coin map entry list has two duplicate keys" + $ cover 2 (not (null entries) && length duplicateKeys >= 3) + "coin map entry list has multiple duplicate keys" + True + where + uniqueKeys :: Set u + uniqueKeys = entries + & fmap entryKey + & Set.fromList + duplicateKeys :: Set u + duplicateKeys = entries + & fmap (entryKey &&& const (1 :: Int)) + & Map.fromListWith (+) + & Map.filter (> 1) + & Map.keysSet + +prop_coinMapFromList_preservesTotalValueForEachUniqueKey + :: (Ord u, Show u) + => [CoinMapEntry u] + -> Property +prop_coinMapFromList_preservesTotalValueForEachUniqueKey entries = property $ + mkEntryMap entries + `shouldBe` + mkEntryMap (coinMapToList (coinMapFromList entries)) + where + mkEntryMap + = Map.fromListWith C.add + . fmap (entryKey &&& entryValue) + +prop_coinMapFromList_preservesTotalValue + :: Ord u + => [CoinMapEntry u] + -> Property +prop_coinMapFromList_preservesTotalValue entries = property $ + mconcat (entryValue <$> entries) + `shouldBe` coinMapValue (coinMapFromList entries) + +prop_coinMapToList_preservesTotalValue + :: CoinMap u + -> Property +prop_coinMapToList_preservesTotalValue m = property $ + mconcat (entryValue <$> coinMapToList m) + `shouldBe` coinMapValue m + +prop_coinMapToList_coinMapFromList + :: (Ord u, Show u) + => CoinMap u + -> Property +prop_coinMapToList_coinMapFromList m = property $ + coinMapFromList (coinMapToList m) + `shouldBe` m + +prop_coinMapFromList_coinMapToList + :: (Ord u, Show u) + => [CoinMapEntry u] + -> Property +prop_coinMapFromList_coinMapToList entries + | duplicateKeyCount == 0 = + property $ x `shouldBe` y + | otherwise = + property $ length x > length y + where + x = L.sort entries + y = L.sort $ coinMapToList $ coinMapFromList entries + + duplicateKeyCount :: Int + duplicateKeyCount = entries + & fmap (entryKey &&& const (1 :: Int)) + & Map.fromListWith (+) + & Map.filter (> 1) + & Map.keysSet + & length + +prop_coinMapToList_orderDeterministic + :: Ord u => CoinMap u -> Property +prop_coinMapToList_orderDeterministic u = monadicIO $ QC.run $ do + let list0 = coinMapToList u + list1 <- shuffle list0 + return $ + cover 10 (list0 /= list1) "shuffled" $ + list0 == coinMapToList (coinMapFromList list1) + +prop_coinSelection_mappendPreservesKeys + :: (Ord i, Ord o, Show i, Show o) + => CoinSelection i o + -> CoinSelection i o + -> Property +prop_coinSelection_mappendPreservesKeys s1 s2 = property $ do + Map.keysSet (unCoinMap $ inputs $ s1 <> s2) + `shouldBe` + Map.keysSet (unCoinMap $ inputs s1) + `Set.union` + Map.keysSet (unCoinMap $ inputs s2) + Map.keysSet (unCoinMap $ outputs $ s1 <> s2) + `shouldBe` + Map.keysSet (unCoinMap $ outputs s1) + `Set.union` + Map.keysSet (unCoinMap $ outputs s2) + +prop_coinSelection_mappendPreservesTotalValue + :: (Ord i, Ord o) + => CoinSelection i o + -> CoinSelection i o + -> Property +prop_coinSelection_mappendPreservesTotalValue s1 s2 = property $ do + sumInputs s1 <> sumInputs s2 `shouldBe` sumInputs (s1 <> s2) + sumOutputs s1 <> sumOutputs s2 `shouldBe` sumOutputs (s1 <> s2) + sumChange s1 <> sumChange s2 `shouldBe` sumChange (s1 <> s2) + change s1 <> change s2 `shouldBe` change (s1 <> s2) + +-------------------------------------------------------------------------------- +-- 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 + } deriving Show + +instance (Buildable i, Buildable o) => Buildable (CoinSelProp i o) where + build (CoinSelProp utxo outs) = mempty + <> nameF "utxo" (blockListF $ coinMapToList utxo) + <> nameF "outs" (blockListF $ coinMapToList outs) + +-- | A fixture for testing the coin selection +data CoinSelectionFixture i o = CoinSelectionFixture + { maxNumOfInputs :: Word16 + -- ^ Maximum number of inputs that can be selected + , utxoInputs :: [Integer] + -- ^ Value (in Lovelace) & number of available coins in the UTxO + , txOutputs :: [Integer] + -- ^ Value (in Lovelace) & number of requested outputs + } + +-- | Testing-friendly format for 'CoinSelection' results of unit tests. +data CoinSelectionTestResult = CoinSelectionTestResult + { rsInputs :: [Integer] + , rsChange :: [Integer] + , rsOutputs :: [Integer] + } deriving (Eq, Show) + +sortCoinSelectionTestResult + :: CoinSelectionTestResult -> CoinSelectionTestResult +sortCoinSelectionTestResult (CoinSelectionTestResult is cs os) = + CoinSelectionTestResult (L.sort is) (L.sort cs) (L.sort os) + +-- | Generate a 'UTxO' and 'TxOut' matching the given 'Fixture', and perform +-- the given coin selection on it. +coinSelectionUnitTest + :: CoinSelectionAlgorithm TxIn Address IO + -> String + -> Either CoinSelectionError CoinSelectionTestResult + -> CoinSelectionFixture TxIn Address + -> SpecWith () +coinSelectionUnitTest alg lbl expected (CoinSelectionFixture n utxoF outsF) = + it title $ do + (utxo,txOuts) <- setup + result <- runExceptT $ do + CoinSelectionResult (CoinSelection inps outs chngs) _ <- + selectCoins alg $ + CoinSelectionParameters utxo txOuts selectionLimit + return $ CoinSelectionTestResult + { rsInputs = coinToIntegral . entryValue <$> coinMapToList inps + , rsChange = coinToIntegral <$> chngs + , rsOutputs = coinToIntegral . entryValue <$> coinMapToList outs + } + fmap sortCoinSelectionTestResult result + `shouldBe` fmap sortCoinSelectionTestResult expected + where + selectionLimit = CoinSelectionLimit $ const n + + title :: String + title = mempty + <> if null lbl then "" else lbl <> ":\n\t" + <> "max=" <> show n + <> ", UTxO=" <> show utxoF + <> ", Output=" <> show outsF + <> " --> " <> show (rsInputs <$> expected) + + setup :: IO (CoinMap TxIn, CoinMap Address) + setup = do + utxo <- generate (genUTxO utxoF) + outs <- generate (genOutputs outsF) + pure (utxo, outs) + +-------------------------------------------------------------------------------- +-- Arbitrary Instances +-------------------------------------------------------------------------------- + +deriving instance Arbitrary a => Arbitrary (ShowFmt a) + +instance (Arbitrary i, Arbitrary o, Ord i, Ord o) => + Arbitrary (CoinSelection i o) + where + arbitrary = CoinSelection + <$> arbitrary + <*> arbitrary + <*> arbitrary + shrink = genericShrink + +instance Arbitrary (CoinSelectionLimit) where + arbitrary = do + -- NOTE Functions have to be decreasing functions + fn <- elements + [ (maxBound -) + , \x -> + if x > maxBound `div` 2 + then maxBound + else maxBound - (2 * x) + , const 42 + ] + pure $ CoinSelectionLimit fn + +instance Show (CoinSelectionLimit) where + show _ = "CoinSelectionLimit" + +instance Arbitrary a => Arbitrary (NonEmpty a) where + shrink xs = catMaybes (NE.nonEmpty <$> shrink (NE.toList xs)) + arbitrary = do + n <- choose (1, 10) + NE.fromList <$> vectorOf n arbitrary + +instance (Arbitrary i, Arbitrary o, Ord i, Ord o) => + Arbitrary (CoinSelProp i o) + where + shrink (CoinSelProp utxo outs) = uncurry CoinSelProp <$> zip + (shrink utxo) + (coinMapFromList <$> filter (not . null) (shrink (coinMapToList outs))) + arbitrary = CoinSelProp + <$> (coinMapFromList . getNonEmpty <$> arbitrary) + <*> (coinMapFromList . getNonEmpty <$> arbitrary) + +instance Arbitrary Address where + shrink _ = [] + arbitrary = do + bytes <- BS.pack <$> vectorOf 8 arbitraryBoundedIntegral + pure $ Address bytes + +instance Arbitrary Coin where + -- No Shrinking + arbitrary = unsafeCoin @Int <$> 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 a => Arbitrary (CoinMapEntry a) where + -- No Shrinking + arbitrary = CoinMapEntry + <$> arbitrary + <*> arbitrary + +instance (Arbitrary a, Ord a) => Arbitrary (CoinMap a) where + shrink (CoinMap m) = CoinMap <$> shrink m + arbitrary = do + n <- oneof + [ pure 0 + , pure 1 + , choose (2, 100) + ] + entries <- zip + <$> vectorOf n arbitrary + <*> vectorOf n arbitrary + return $ CoinMap $ Map.fromList entries + +genUTxO :: [Integer] -> Gen (CoinMap TxIn) +genUTxO coins = do + let n = length coins + inps <- vectorOf n arbitrary + return $ CoinMap $ Map.fromList $ zip inps (unsafeCoin <$> coins) + +genOutputs :: [Integer] -> Gen (CoinMap Address) +genOutputs coins = do + let n = length coins + outs <- vectorOf n arbitrary + return $ coinMapFromList $ zipWith CoinMapEntry outs (map unsafeCoin coins) diff --git a/src/test/Cardano/Test/Utilities.hs b/src/test/Cardano/Test/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/test/Cardano/Test/Utilities.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Utility functions, types, and type class instances used purely for testing. +-- +-- Copyright: © 2018-2020 IOHK +-- License: Apache-2.0 +-- +module Cardano.Test.Utilities + ( + -- * Addresses + Address (..) + + -- * Hashes + , Hash (..) + + -- * Formatting + , ShowFmt (..) + + -- * Transactions + , TxIn (..) + , TxOut (..) + + -- * UTxO Operations + , excluding + , isSubsetOf + , restrictedBy + , restrictedTo + + -- * Unsafe Operations + , unsafeCoin + , unsafeDustThreshold + , unsafeFee + , unsafeFromHex + + ) where + +import Prelude + +import Cardano.CoinSelection + ( CoinMap (..), CoinMapEntry (..), CoinSelection (..), coinMapToList ) +import Cardano.CoinSelection.Fee + ( DustThreshold (..), Fee (..) ) +import Control.DeepSeq + ( NFData (..) ) +import Data.ByteArray + ( ByteArrayAccess ) +import Data.ByteArray.Encoding + ( Base (Base16), convertFromBase, convertToBase ) +import Data.ByteString + ( ByteString ) +import Data.Maybe + ( fromMaybe ) +import Data.Set + ( Set ) +import Data.Word + ( Word32 ) +import Fmt + ( Buildable (..) + , blockListF + , fmt + , listF + , nameF + , ordinalF + , prefixF + , suffixF + ) +import GHC.Generics + ( Generic ) +import GHC.Stack + ( HasCallStack ) +import GHC.TypeLits + ( Symbol ) +import Internal.Coin + ( Coin, coinFromIntegral ) +import Numeric.Natural + ( Natural ) +import Quiet + ( Quiet (Quiet) ) + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text.Encoding as T +import qualified Internal.Coin as C + +-------------------------------------------------------------------------------- +-- Addresses +-------------------------------------------------------------------------------- + +newtype Address = Address + { unAddress :: ByteString } + deriving stock (Eq, Generic, Ord) + deriving Show via (Quiet Address) + +instance NFData Address + +instance Buildable Address where + build addr = mempty + <> prefixF 8 addrF + <> "..." + <> suffixF 8 addrF + where + addrF = build (toText addr) + toText = T.decodeUtf8 + . convertToBase Base16 + . unAddress + +-------------------------------------------------------------------------------- +-- Unsafe Operations +-------------------------------------------------------------------------------- + +unsafeCoin :: (Integral i, Show i) => i -> Coin +unsafeCoin i = fromMaybe die $ coinFromIntegral i + where + die = error $ mconcat + [ "Test suite attempted to create a coin with negative value: " + , show i + ] + +unsafeDustThreshold :: (Integral i, Show i) => i -> DustThreshold +unsafeDustThreshold i = DustThreshold $ fromMaybe die $ coinFromIntegral i + where + die = error $ mconcat + [ "Test suite attempted to create a dust theshold with negative value: " + , show i + ] + +unsafeFee :: (Integral i, Show i) => i -> Fee +unsafeFee i = Fee $ fromMaybe die $ coinFromIntegral i + where + die = error $ mconcat + [ "Test suite attempted to create a fee with negative value: " + , show i + ] + +-- | Decode an hex-encoded 'ByteString' into raw bytes, or fail. +unsafeFromHex :: HasCallStack => ByteString -> ByteString +unsafeFromHex = + either (error . show) id . convertFromBase @ByteString @ByteString Base16 + +-------------------------------------------------------------------------------- +-- Hashes +-------------------------------------------------------------------------------- + +newtype Hash (tag :: Symbol) = Hash { getHash :: ByteString } + deriving stock (Eq, Generic, Ord) + deriving newtype (ByteArrayAccess) + deriving Show via (Quiet (Hash tag)) + +instance NFData (Hash tag) + +instance Buildable (Hash tag) where + build h = mempty + <> prefixF 8 builder + where + builder = build . toText $ h + toText = T.decodeUtf8 . convertToBase Base16 . getHash + +-------------------------------------------------------------------------------- +-- Formatting +-------------------------------------------------------------------------------- + +-- | A polymorphic wrapper type with a custom 'Show' instance to display data +-- through 'Buildable' instances. +newtype ShowFmt a = ShowFmt { unShowFmt :: a } + deriving (Generic, Eq, Ord) + +instance NFData a => NFData (ShowFmt a) + +instance Buildable a => Show (ShowFmt a) where + show (ShowFmt a) = fmt (build a) + +-------------------------------------------------------------------------------- +-- Transactions +-------------------------------------------------------------------------------- + +data TxIn = TxIn + { txinId + :: !(Hash "Tx") + , txinIx + :: !Word32 + } deriving (Show, Generic, Eq, Ord) + +instance NFData TxIn + +instance Buildable TxIn where + build txin = mempty + <> ordinalF (txinIx txin + 1) + <> " " + <> build (txinId txin) + +data TxOut = TxOut + { txoutAddress + :: !Address + , txoutCoin + :: !Coin + } deriving (Show, Generic, Eq, Ord) + +instance Buildable TxOut where + build txout = mempty + <> build (txoutCoin txout) + <> " @ " + <> prefixF 8 addrF + <> "..." + <> suffixF 8 addrF + where + addrF = build $ txoutAddress txout + +-------------------------------------------------------------------------------- +-- UTxO Operations +-------------------------------------------------------------------------------- + +-- | ins⋪ u +excluding :: Ord u => CoinMap u -> Set u -> CoinMap u +excluding (CoinMap utxo) = + CoinMap . Map.withoutKeys utxo + +-- | a ⊆ b +isSubsetOf :: Ord u => CoinMap u -> CoinMap u -> Bool +isSubsetOf (CoinMap a) (CoinMap b) = + a `Map.isSubmapOf` b + +-- | ins⊲ u +restrictedBy :: Ord u => CoinMap u -> Set u -> CoinMap u +restrictedBy (CoinMap utxo) = + CoinMap . Map.restrictKeys utxo + +-- | u ⊳ outs +restrictedTo :: CoinMap u -> Set Coin -> CoinMap u +restrictedTo (CoinMap utxo) outs = + CoinMap $ Map.filter (`Set.member` outs) utxo + +-------------------------------------------------------------------------------- +-- Buildable Instances +-------------------------------------------------------------------------------- + +instance Buildable Coin where + build = build . fromIntegral @Natural @Integer . C.coinToIntegral + +instance Buildable a => Buildable (CoinMapEntry a) where + build a = mempty + <> build (entryKey a) + <> ":" + <> build (entryValue a) + +instance (Buildable i, Buildable o) => Buildable (CoinSelection i o) where + build s = mempty + <> nameF "inputs" + (blockListF $ coinMapToList $ inputs s) + <> nameF "outputs" + (blockListF $ coinMapToList $ outputs s) + <> nameF "change" + (listF $ change s) diff --git a/src/test/Internal/CoinSpec.hs b/src/test/Internal/CoinSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Internal/CoinSpec.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Internal.CoinSpec + ( spec + ) where + +import Prelude + +import Data.Maybe + ( catMaybes, fromMaybe ) +import Internal.Coin + ( Coin ) +import Test.Hspec + ( Spec, describe, it, shouldBe, shouldSatisfy ) +import Test.QuickCheck + ( Arbitrary (..) + , NonNegative (..) + , Property + , checkCoverage + , cover + , oneof + , property + ) + +import qualified Internal.Coin as C + +spec :: Spec +spec = do + + describe "Coin properties" $ do + it "Only construction of non-negative values is possible." $ + checkCoverage prop_construction + it "Coverage of generated values is acceptable." $ + checkCoverage prop_generation + it "Addition" $ + checkCoverage prop_add + it "Multiplication" $ + checkCoverage prop_mul + it "Subtraction" $ + checkCoverage prop_sub + it "Division" $ + checkCoverage prop_div + it "Modulus" $ + checkCoverage prop_mod + it "Distance" $ + checkCoverage prop_distance + +prop_construction + :: Integer + -> Property +prop_construction i = property + $ cover 10 (i < 0) + "input is negative" + $ cover 10 (i > 0) + "input is positive" + $ cover 2 (i == 0) + "input is zero" + $ if i < 0 + then C.coinFromIntegral i `shouldBe` Nothing + else (C.coinToIntegral <$> C.coinFromIntegral i) `shouldBe` Just i + +prop_generation + :: Coin + -> Property +prop_generation n = property + $ cover 2 (n == C.zero) + "value is zero" + $ cover 2 (n == C.one) + "value is one" + $ cover 10 (n > C.one) + "value is more than one" + True + +prop_add :: Coin -> Coin -> Property +prop_add x y = property $ + C.coinToIntegral @Integer (x `C.add` y) + `shouldBe` + (C.coinToIntegral x + C.coinToIntegral y) + +prop_mul :: Coin -> Integer -> Property +prop_mul x y = property + $ cover 2 (y == 0) + "scaling factor is zero" + $ cover 8 (y < 0) + "scaling factor is negative" + $ cover 8 (y > 0) + "scaling factor is positive" + $ case (x `C.mul` y) of + Nothing -> + y `shouldSatisfy` (< 0) + Just r -> + (C.coinToIntegral x * y) `shouldBe` C.coinToIntegral @Integer r + +prop_sub :: Coin -> Coin -> Property +prop_sub x y = property + $ cover 4 (x == y) + "values are equal" + $ cover 8 (x < y) + "x < y" + $ cover 8 (x > y) + "x > y" + $ case x `C.sub` y of + Nothing -> + x `shouldSatisfy` (< y) + Just r -> + C.coinToIntegral x - C.coinToIntegral y + `shouldBe` C.coinToIntegral @Integer r + +prop_div :: Coin -> Integer -> Property +prop_div x y = property + $ cover 2 (y == 0) + "denominator is zero" + $ cover 8 (y < 0) + "denominator is negative" + $ cover 8 (y > 0) + "denominator is positive" + $ case (x `C.div` y) of + Nothing -> + y `shouldSatisfy` (<= 0) + Just r -> + (C.coinToIntegral x `div` y) + `shouldBe` C.coinToIntegral @Integer r + +prop_mod :: Coin -> Integer -> Property +prop_mod x y = property + $ cover 2 (y == 0) + "denominator is zero" + $ cover 8 (y < 0) + "denominator is negative" + $ cover 8 (y > 0) + "denominator is positive" + $ case (x `C.mod` y) of + Nothing -> + y `shouldSatisfy` (<= 0) + Just r -> + (C.coinToIntegral x `mod` y) + `shouldBe` C.coinToIntegral @Integer r + +prop_distance :: Coin -> Coin -> Property +prop_distance x y = property + $ cover 4 (x == y) + "values are equal" + $ cover 8 (x < y) + "x < y" + $ cover 8 (x > y) + "x > y" + $ C.coinToIntegral @Integer (x `C.distance` y) + `shouldBe` + abs (C.coinToIntegral x - C.coinToIntegral y) + +instance Arbitrary Coin where + arbitrary = oneof + [ pure C.zero + , pure C.one + , somethingElse + ] + where + somethingElse = + fromMaybe C.zero + . C.coinFromIntegral @Integer + . getNonNegative <$> arbitrary + shrink n = catMaybes + $ C.coinFromIntegral @Integer <$> shrink (C.coinToIntegral @Integer n) diff --git a/src/test/Spec.hs b/src/test/Spec.hs new file mode 100644 --- /dev/null +++ b/src/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/test/Test/Vector/Shuffle.hs b/src/test/Test/Vector/Shuffle.hs new file mode 100644 --- /dev/null +++ b/src/test/Test/Vector/Shuffle.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Vector.Shuffle + ( -- * Simple + shuffle + , shuffleNonEmpty + + -- * Advanced + , mkSeed + , shuffleWith + , shuffleNonEmptyWith + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Control.Monad.Trans.Class + ( lift ) +import Control.Monad.Trans.State.Strict + ( evalStateT, state ) +import Crypto.Hash + ( hash ) +import Crypto.Hash.Algorithms + ( MD5 ) +import Data.List.NonEmpty + ( NonEmpty (..) ) +import Data.Maybe + ( fromMaybe ) +import Data.Text + ( Text ) +import Data.Vector.Mutable + ( IOVector ) +import Data.Word + ( Word8 ) +import System.Random + ( RandomGen, StdGen, mkStdGen, newStdGen, randomR ) + +import qualified Data.ByteArray as BA +import qualified Data.ByteString as BS +import qualified Data.List.NonEmpty as NE +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV + +-- | Generate a random generator seed from a text string +mkSeed :: Text -> StdGen +mkSeed = mkStdGen . toInt . quickHash . T.encodeUtf16LE + where + quickHash = BA.convert . hash @_ @MD5 + toInt = snd . BS.foldl' exponentiation (0,0) + where + exponentiation :: (Int, Int) -> Word8 -> (Int, Int) + exponentiation (e, n) i = (e+1, n + fromIntegral i*2^e) + +-- | Shuffles a list of elements. +-- +-- >>> shuffle (outputs coinSel) +-- [...] +shuffle :: [a] -> IO [a] +shuffle xs = newStdGen >>= flip shuffleWith xs + +-- | Like 'shuffle', but from a given seed. 'shuffle' will use a randomly +-- generate seed using 'newStdGen' from @System.Random@. +-- +-- __Properties:__ +-- +-- - @shuffleWith g es == shuffleWith g es@ +-- - @∃Δ> 1. g ≠g', length es > Δ⇒ shuffleWith g es ≠shuffleWith g' es@ +shuffleWith :: RandomGen g => g -> [a] -> IO [a] +shuffleWith seed = modifyInPlace $ \v -> flip evalStateT seed $ do + let (lo, hi) = (0, MV.length v - 1) + forM_ [lo .. hi] $ \i -> do + j <- fromInteger <$> state (randomR (fromIntegral lo, fromIntegral hi)) + lift $ swapElems v i j + where + swapElems :: IOVector a -> Int -> Int -> IO () + swapElems v i j = do + x <- MV.read v i + y <- MV.read v j + MV.write v i y + MV.write v j x + + modifyInPlace :: forall a. (IOVector a -> IO ()) -> [a] -> IO [a] + modifyInPlace f xs = do + v' <- V.thaw $ V.fromList xs + f v' + V.toList <$> V.freeze v' + +-- | Shuffles a /non-empty/ list of elements. +-- +-- See 'shuffle'. +-- +shuffleNonEmpty :: NonEmpty a -> IO (NonEmpty a) +shuffleNonEmpty xs = newStdGen >>= flip shuffleNonEmptyWith xs + +-- | Shuffles a /non-empty/ list of elements with the given random generator. +-- +-- See 'shuffleWith'. +-- +shuffleNonEmptyWith :: RandomGen g => g -> NonEmpty a -> IO (NonEmpty a) +shuffleNonEmptyWith g = + fmap (fromMaybe raiseError . NE.nonEmpty) . shuffleWith g . NE.toList + where + raiseError = error "shuffleNonEmptyWith encountered an empty list." diff --git a/src/test/Test/Vector/ShuffleSpec.hs b/src/test/Test/Vector/ShuffleSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Test/Vector/ShuffleSpec.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.Vector.ShuffleSpec + ( spec + ) where + +import Prelude + +import Data.List.NonEmpty + ( NonEmpty (..) ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Arbitrary (..) + , Confidence (..) + , NonEmptyList (..) + , Positive (..) + , PrintableString (..) + , Property + , Testable + , arbitrary + , checkCoverageWith + , cover + , genericShrink + , label + , vectorOf + , (==>) + ) +import Test.QuickCheck.Monadic + ( assert, monadicIO, monitor, pick, run ) +import Test.Vector.Shuffle + ( mkSeed, shuffle, shuffleNonEmpty, shuffleWith ) + +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T + +spec :: Spec +spec = do + describe "shuffle" $ do + it "every list can be shuffled, ultimately" $ + check prop_shuffleCanShuffle + it "shuffle is non-deterministic" $ + check prop_shuffleNotDeterministic + it "sort (shuffle xs) == sort xs" $ + check prop_shufflePreserveElements + + describe "shuffleNonEmpty" $ do + it "every non-empty list can be shuffled, ultimately" $ + check prop_shuffleNonEmptyCanShuffle + it "shuffleNonEmpty is non-deterministic" $ + check prop_shuffleNonEmptyNotDeterministic + it "sort (shuffleNonEmpty xs) == sort xs" $ + check prop_shuffleNonEmptyPreserveElements + + describe "shuffleWith / mkSeed" $ do + it "shuffling with the same seed is deterministic" $ + check prop_shuffleWithDeterministic + it "different seed means different shuffles" $ + check prop_shuffleDifferentSeed + + where + check :: forall p. Testable p => p -> Property + check = checkCoverageWith lowerConfidence + + lowerConfidence :: Confidence + lowerConfidence = Confidence (10^(6 :: Integer)) 0.75 + +-------------------------------------------------------------------------------- +-- Properties +-------------------------------------------------------------------------------- + +prop_shuffleCanShuffle + :: NonEmptyList Int + -> Property +prop_shuffleCanShuffle (NonEmpty xs) = monadicIO $ run $ do + xs' <- shuffle xs + return $ cover 90 (xs /= xs') "shuffled" () + +prop_shuffleNonEmptyCanShuffle + :: NonEmpty Int + -> Property +prop_shuffleNonEmptyCanShuffle xs = monadicIO $ run $ do + xs' <- shuffleNonEmpty xs + return $ cover 90 (xs /= xs') "shuffled" () + +prop_shuffleNotDeterministic + :: NonEmptyList Int + -> Property +prop_shuffleNotDeterministic (NonEmpty xs) = monadicIO $ run $ do + xs1 <- shuffle xs + xs2 <- shuffle xs + return $ cover 90 (xs1 /= xs2) "not deterministic" () + +prop_shuffleNonEmptyNotDeterministic + :: NonEmpty Int + -> Property +prop_shuffleNonEmptyNotDeterministic xs = monadicIO $ run $ do + xs1 <- shuffleNonEmpty xs + xs2 <- shuffleNonEmpty xs + return $ cover 90 (xs1 /= xs2) "not deterministic" () + +prop_shufflePreserveElements + :: [Int] + -> Property +prop_shufflePreserveElements xs = monadicIO $ run $ do + xs' <- shuffle xs + return $ cover 90 (not $ null xs) "non-empty" (L.sort xs == L.sort xs') + +prop_shuffleNonEmptyPreserveElements + :: NonEmpty Int + -> Property +prop_shuffleNonEmptyPreserveElements xs = monadicIO $ run $ do + xs' <- shuffleNonEmpty xs + return $ cover 90 (not $ null xs) "non-empty" (NE.sort xs == NE.sort xs') + +-- ∀(g :: RandomGen). +-- ∀(es :: [a]). +-- +-- shuffleWith g es == shuffleWith g es +prop_shuffleWithDeterministic + :: PrintableString + -> NonEmptyList Int + -> Property +prop_shuffleWithDeterministic (PrintableString seed) (NonEmpty xs) = + monadicIO $ do + ys0 <- run $ shuffleWith (mkSeed $ T.pack seed) xs + ys1 <- run $ shuffleWith (mkSeed $ T.pack seed) xs + monitor $ cover 90 (length xs > 1) "non singleton" + assert (ys0 == ys1) + +-- ∀(x0 : Text, x1 : Text). g0 = mkSeed x0, g1 = mkSeed x1 +-- ∃(Δ: Int). +-- ∀(es :: [a]). +-- +-- g0 ≠g1, length es > Δ⇒ shuffleWith g0 es ≠shuffleWith g1 es +prop_shuffleDifferentSeed + :: (PrintableString, PrintableString) + -> Positive Int + -> Property +prop_shuffleDifferentSeed (x0, x1) (Positive len) = do + x0 /= x1 ==> monadicIO $ do + let g0 = mkSeed $ T.pack $ getPrintableString x0 + let g1 = mkSeed $ T.pack $ getPrintableString x1 + es <- pick $ vectorOf len (arbitrary @Int) + ys0 <- run $ shuffleWith g0 es + ys1 <- run $ shuffleWith g1 es + monitor $ label (prettyLen es) + monitor $ cover 90 (ys0 /= ys1) "different" + where + prettyLen :: [a] -> String + prettyLen xs = case length xs of + n | n <= 1 -> "singleton" + n | n <= 10 -> "small list" + _ -> "big list" + +instance Arbitrary a => Arbitrary (NonEmpty a) where + arbitrary = (:|) <$> arbitrary <*> arbitrary + shrink = genericShrink