diff --git a/src/library/Cardano/CoinSelection/Algorithm/Migration.hs b/src/library/Cardano/CoinSelection/Algorithm/Migration.hs index f5c5ef22a..e95a6b5a7 100644 --- a/src/library/Cardano/CoinSelection/Algorithm/Migration.hs +++ b/src/library/Cardano/CoinSelection/Algorithm/Migration.hs @@ -33,6 +33,7 @@ import Cardano.CoinSelection , CoinSelectionLimit (..) , coinMapFromList , coinMapToList + , coinMapValue , sumChange , sumInputs ) @@ -42,13 +43,14 @@ import Cardano.CoinSelection.Fee , FeeBalancingPolicy (..) , FeeEstimator (..) , FeeOptions (..) + , isDust ) import Control.Monad.Trans.State ( State, evalState, get, put ) import Data.List.NonEmpty ( NonEmpty ((:|)) ) import Data.Maybe - ( fromMaybe, mapMaybe ) + ( fromMaybe ) import Data.Word ( Word16 ) import GHC.Generics @@ -113,19 +115,20 @@ selectCoins options (BatchSize batchSize) utxo = -- Note that the selection may look a bit weird at first sight as it has -- no outputs (we are paying everything to ourselves!). mkCoinSelection :: [CoinMapEntry i] -> CoinSelection i o - mkCoinSelection inps = CoinSelection - { inputs = coinMapFromList inps - , outputs = mempty - , change = - let chgs = mapMaybe (noDust . entryValue) inps - in if null chgs then [threshold] else chgs - } + mkCoinSelection inputEntries = CoinSelection {inputs, outputs, change} where - threshold = unDustThreshold dustThreshold - noDust :: Coin -> Maybe Coin - noDust c - | c < threshold = Nothing - | otherwise = Just c + inputs = coinMapFromList inputEntries + outputs = mempty + change + | null nonDustInputCoins && totalInputValue >= smallestNonDustCoin = + [smallestNonDustCoin] + | otherwise = + nonDustInputCoins + nonDustInputCoins = filter + (not . isDust dustThreshold) + (entryValue <$> inputEntries) + smallestNonDustCoin = C.succ $ unDustThreshold dustThreshold + totalInputValue = coinMapValue inputs -- | Attempt to balance the coin selection by reducing or increasing the -- change values based on the computed fees. diff --git a/src/library/Cardano/CoinSelection/Fee.hs b/src/library/Cardano/CoinSelection/Fee.hs index 84f4df2bd..cf6961d9c 100644 --- a/src/library/Cardano/CoinSelection/Fee.hs +++ b/src/library/Cardano/CoinSelection/Fee.hs @@ -31,6 +31,7 @@ module Cardano.CoinSelection.Fee -- * Dust Processing , DustThreshold (..) + , isDust , coalesceDust -- # Internal Functions @@ -119,6 +120,17 @@ newtype DustThreshold = DustThreshold { unDustThreshold :: Coin } deriving stock (Eq, Generic, Ord) deriving Show via (Quiet DustThreshold) +-- | Returns 'True' if and only if the given 'Coin' is a __dust coin__ +-- according to the given 'DustThreshold'. +-- +-- A coin is considered to be a dust coin if it is /less than or equal to/ +-- the threshold. +-- +-- See 'DustThreshold'. +-- +isDust :: DustThreshold -> Coin -> Bool +isDust (DustThreshold dt) c = c <= dt + -- | Provides a function capable of __estimating__ the transaction fee required -- for a given coin selection, according to the rules of a particular -- blockchain. @@ -618,10 +630,10 @@ distributeFee (Fee feeTotal) coinsUnsafe = -- >>> all (/= Coin 0) (coalesceDust threshold coins) -- coalesceDust :: DustThreshold -> NonEmpty Coin -> [Coin] -coalesceDust (DustThreshold threshold) coins = +coalesceDust threshold coins = splitCoin valueToDistribute coinsToKeep where - (coinsToKeep, coinsToRemove) = NE.partition (> threshold) coins + (coinsToRemove, coinsToKeep) = NE.partition (isDust threshold) coins valueToDistribute = F.fold coinsToRemove -- Splits up the given coin of value __@v@__, distributing its value over the diff --git a/src/test/Cardano/CoinSelection/Algorithm/MigrationSpec.hs b/src/test/Cardano/CoinSelection/Algorithm/MigrationSpec.hs index e1a816799..1008f3451 100644 --- a/src/test/Cardano/CoinSelection/Algorithm/MigrationSpec.hs +++ b/src/test/Cardano/CoinSelection/Algorithm/MigrationSpec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -117,27 +118,27 @@ spec = do describe "selectCoins properties" $ do it "No coin selection has outputs" $ - property $ withMaxSuccess 10000 $ prop_onlyChangeOutputs + property $ withMaxSuccess 10_000 $ prop_onlyChangeOutputs @(Wrapped TxIn) @Address - it "Every coin in the selection change >= minimum threshold coin" $ - property $ withMaxSuccess 10000 $ prop_noLessThanThreshold + it "Every coin in the selection change > dust threshold" $ + property $ withMaxSuccess 10_000 $ prop_allAboveThreshold @(Wrapped TxIn) @Address it "Total input UTxO value >= sum of selection change coins" $ - property $ withMaxSuccess 10000 $ prop_inputsGreaterThanOutputs + property $ withMaxSuccess 10_000 $ prop_inputsGreaterThanOutputs @(Wrapped TxIn) @Address it "Every selection input is unique" $ - property $ withMaxSuccess 10000 $ prop_inputsAreUnique + property $ withMaxSuccess 10_000 $ prop_inputsAreUnique @(Wrapped TxIn) @Address it "Every selection input is a member of the UTxO" $ - property $ withMaxSuccess 10000 $ prop_inputsStillInUTxO + property $ withMaxSuccess 10_000 $ prop_inputsStillInUTxO @(Wrapped TxIn) @Address it "Every coin selection is well-balanced" $ - property $ withMaxSuccess 10000 $ prop_wellBalanced + property $ withMaxSuccess 10_000 $ prop_wellBalanced @(Wrapped TxIn) @Address describe "selectCoins regressions" $ do @@ -177,18 +178,18 @@ prop_onlyChangeOutputs feeOpts batchSize utxo = do coinMapToList . outputs =<< selectCoins feeOpts batchSize utxo property (allOutputs `shouldSatisfy` null) --- | Every coin in the selection change >= minimum threshold coin -prop_noLessThanThreshold +-- | Every coin in the selection change > dust threshold +prop_allAboveThreshold :: forall i o . (Ord i, Ord o) => FeeOptions i o -> BatchSize -> CoinMap i -> Property -prop_noLessThanThreshold feeOpts batchSize utxo = do +prop_allAboveThreshold feeOpts batchSize utxo = do let allChange = change =<< selectCoins feeOpts batchSize utxo let undersizedCoins = - filter (< threshold) allChange + filter (<= threshold) allChange property (undersizedCoins `shouldSatisfy` null) where threshold = unDustThreshold $ dustThreshold feeOpts