From 01c16c7a9f1c1f86db4560cfaf9fd25d8ca1d404 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Fri, 16 Nov 2018 19:08:39 +0100 Subject: [PATCH 1/3] [RCD-45] & [RCD-44] Review fee calculation So, basically, by conflating a bit the selected entries and changes, a lot of things become easier. At the price of one thing: fairness. The previous code was splitting fee across change proportionally to inputs. So here, I just split the fee across all changes, regardless of the input. So everyone's got to pay the same part of for the transaction. One could see it as another type of fairness :upside_down_face: ... But that's also a lot simpler to handle, because we can just manipulate all inputs and all changes directly and compute fee for those directly. --- .../Kernel/CoinSelection/FromGeneric.hs | 56 +---- .../Wallet/Kernel/CoinSelection/Generic.hs | 6 + .../Kernel/CoinSelection/Generic/Fees.hs | 233 +++++++++++------- .../test/unit/InputSelection/FromGeneric.hs | 5 + .../test/unit/Test/Spec/CoinSelection.hs | 7 +- 5 files changed, 171 insertions(+), 136 deletions(-) diff --git a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs index dd0bc107ce7..7c06960d11e 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs @@ -70,6 +70,7 @@ instance IsValue Core.Coin where else a `Core.unsafeSubCoin` b valueRatio = \ a b -> coinToDouble a / coinToDouble b valueAdjust = \r d a -> coinFromDouble r (d * coinToDouble a) + valueDiv = divCoin instance CoinSelDom Cardano where type Input Cardano = Core.TxIn @@ -191,14 +192,6 @@ feeOptions CoinSelectionOptions{..} = FeeOptions{ type PickUtxo m = forall e. Core.Coin -- ^ Fee to still cover -> CoinSelT Core.Utxo e m (Maybe (Core.TxIn, Core.TxOutAux)) -data CoinSelFinalResult = CoinSelFinalResult { - csrInputs :: NonEmpty (Core.TxIn, Core.TxOutAux) - -- ^ Picked inputs - , csrOutputs :: NonEmpty Core.TxOutAux - -- ^ Picked outputs - , csrChange :: [Core.Coin] - } - -- | Run coin selection -- -- NOTE: Final UTxO is /not/ returned: coin selection runs /outside/ any wallet @@ -215,8 +208,8 @@ runCoinSelT :: forall m. Monad m -> (forall utxo. PickFromUtxo utxo => NonEmpty (Output (Dom utxo)) -> CoinSelT utxo CoinSelHardErr m [CoinSelResult (Dom utxo)]) - -> CoinSelPolicy Core.Utxo m CoinSelFinalResult -runCoinSelT opts pickUtxo policy (NE.sortBy (flip (comparing outVal)) -> request) utxo = do + -> CoinSelPolicy Core.Utxo m (CoinSelFinalResult Cardano) +runCoinSelT opts pickUtxo policy (NE.sortBy (flip (comparing outVal)) -> request) = -- NOTE: we sort the payees by output value, to maximise our chances of succees. -- In particular, let's consider a scenario where: -- @@ -233,44 +226,9 @@ runCoinSelT opts pickUtxo policy (NE.sortBy (flip (comparing outVal)) -> request -- -- Therefore, just always considering them in order from large to small -- is probably a good idea. - mSelection <- unwrapCoinSelT policy' utxo - case mSelection of - Left err -> return (Left err) - Right ((css, additionalUtxo, additionalChange), _utxo') -> do - let inps = concatMap selectedEntries - (additionalUtxo : map coinSelInputs css) - outs = map coinSelOutput css - changesWithDust = splitChange additionalChange $ concatMap coinSelChange css - let allInps = case inps of - [] -> error "runCoinSelT: empty list of inputs" - i:is -> i :| is - originalOuts = case outs of - [] -> error "runCoinSelT: empty list of outputs" - o:os -> o :| os - changes = changesRemoveDust (csoDustThreshold opts) changesWithDust - return . Right $ CoinSelFinalResult allInps - originalOuts - changes + evalCoinSelT policy' where - -- we should have (x + (sum ls) = sum result), but this check could overflow. - splitChange :: Value Cardano -> [Value Cardano] -> [Value Cardano] - splitChange = go - where - go remaining [] = [remaining] - -- we only create new change if for whatever reason there is none already - -- or if is some overflow happens when we try to add. - go remaining [a] = case valueAdd remaining a of - Just newChange -> [newChange] - Nothing -> [a, remaining] - go remaining ls@(a : as) = - let piece = divCoin remaining (length ls) - newRemaining = unsafeValueSub remaining piece -- unsafe because of div. - in case valueAdd piece a of - Just newChange -> newChange : go newRemaining as - Nothing -> a : go remaining as - - policy' :: CoinSelT Core.Utxo CoinSelHardErr m - ([CoinSelResult Cardano], SelectedUtxo Cardano, Value Cardano) + policy' :: CoinSelT Core.Utxo CoinSelHardErr m (CoinSelFinalResult Cardano) policy' = do mapM_ validateOutput request css <- intInputGrouping (csoInputGrouping opts) @@ -346,7 +304,7 @@ validateOutput out = random :: forall m. MonadRandom m => CoinSelectionOptions -> Word64 -- ^ Maximum number of inputs - -> CoinSelPolicy Core.Utxo m CoinSelFinalResult + -> CoinSelPolicy Core.Utxo m (CoinSelFinalResult Cardano) random opts maxInps = runCoinSelT opts pickUtxo $ Random.random Random.PrivacyModeOn maxInps . NE.toList @@ -361,7 +319,7 @@ random opts maxInps = largestFirst :: forall m. Monad m => CoinSelectionOptions -> Word64 - -> CoinSelPolicy Core.Utxo m CoinSelFinalResult + -> CoinSelPolicy Core.Utxo m (CoinSelFinalResult Cardano) largestFirst opts maxInps = runCoinSelT opts pickUtxo $ LargestFirst.largestFirst maxInps . NE.toList diff --git a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic.hs b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic.hs index 52a10fa1fb6..4579e6bee9e 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic.hs @@ -28,6 +28,7 @@ module Cardano.Wallet.Kernel.CoinSelection.Generic ( , mapCoinSelErr , mapCoinSelUtxo , unwrapCoinSelT + , evalCoinSelT , wrapCoinSelT -- * Errors , CoinSelHardErr(..) @@ -91,6 +92,7 @@ class Ord v => IsValue v where valueDist :: v -> v -> v -- ^ @|a - b|@ valueRatio :: v -> v -> Double -- ^ @a / b@ valueAdjust :: Rounding -> Double -> v -> Maybe v -- ^ @a * b@ + valueDiv :: v -> Int -> v -- ^ @a / k@ class ( Ord (Input dom) , IsValue (Value dom) @@ -246,6 +248,10 @@ mapCoinSelUtxo inj proj act = wrapCoinSelT $ \st -> unwrapCoinSelT :: CoinSelT utxo e m a -> utxo -> m (Either e (a, utxo)) unwrapCoinSelT act = runExceptT . runStrictStateT (unCoinSelT act) +-- | Unwrap the 'CoinSelT' stack, only getting the resulting selection +evalCoinSelT :: Monad m => CoinSelT utxo e m a -> utxo -> m (Either e a) +evalCoinSelT act = runExceptT . evalStrictStateT (unCoinSelT act) + -- | Inverse of 'unwrapCoinSelT' wrapCoinSelT :: Monad m => (utxo -> m (Either e (a, utxo))) -> CoinSelT utxo e m a diff --git a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic/Fees.hs b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic/Fees.hs index cd66daabf64..b5b0c1b551f 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic/Fees.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic/Fees.hs @@ -1,10 +1,11 @@ {-# LANGUAGE BangPatterns #-} -module Cardano.Wallet.Kernel.CoinSelection.Generic.Fees ( - ExpenseRegulation(..) - , FeeOptions(..) - , adjustForFees - ) where +module Cardano.Wallet.Kernel.CoinSelection.Generic.Fees + ( ExpenseRegulation(..) + , FeeOptions(..) + , CoinSelFinalResult(..) + , adjustForFees + ) where import Universum @@ -35,107 +36,167 @@ data FeeOptions dom = FeeOptions { , foExpenseRegulation :: ExpenseRegulation } +data CoinSelFinalResult dom = CoinSelFinalResult + { csrInputs :: NonEmpty (UtxoEntry dom) + -- ^ Picked inputs + , csrOutputs :: NonEmpty (Output dom) + -- ^ Picked outputs + , csrChange :: [Value dom] + -- ^ Resulting changes + } + +type PickUtxo m utxo + = Value (Dom utxo) + -> CoinSelT utxo CoinSelHardErr m (Maybe (UtxoEntry (Dom utxo))) + -- | Given the coin selection result from a policy run, adjust the outputs -- for fees, potentially returning additional inputs that we need to cover -- all fees. -adjustForFees :: forall utxo m. (CoinSelDom (Dom utxo), Monad m) - => FeeOptions (Dom utxo) - -> (Value (Dom utxo) -> - CoinSelT utxo CoinSelHardErr m (Maybe (UtxoEntry (Dom utxo)))) - -> [CoinSelResult (Dom utxo)] - -> CoinSelT utxo CoinSelHardErr m - ([CoinSelResult (Dom utxo)], SelectedUtxo (Dom utxo), Value (Dom utxo)) +adjustForFees + :: forall utxo m. (CoinSelDom (Dom utxo), Monad m) + => FeeOptions (Dom utxo) + -> PickUtxo m utxo + -> [CoinSelResult (Dom utxo)] + -> CoinSelT utxo CoinSelHardErr m (CoinSelFinalResult (Dom utxo)) adjustForFees feeOptions pickUtxo css = do - case foExpenseRegulation feeOptions of - ReceiverPaysFee -> coinSelLiftExcept $ - (, emptySelection, valueZero) <$> receiverPaysFee upperBound css - SenderPaysFee -> - senderPaysFee pickUtxo upperBound css - where - upperBound = feeUpperBound feeOptions css + let inps = concatMap (selectedEntries . coinSelInputs) css + let outs = map coinSelOutput css + let chgs = concatMap coinSelChange css + + (inps', outs', chgs') <- + case foExpenseRegulation feeOptions of + ReceiverPaysFee -> + coinSelLiftExcept $ receiverPaysFee feeOptions inps outs chgs + + SenderPaysFee -> + senderPaysFee pickUtxo feeOptions inps outs chgs + + let neInps = case inps' of + [] -> error "adjustForFees: empty list of inputs" + i:is -> i :| is + + let neOuts = case outs' of + [] -> error "adjustForFees: empty list of outputs" + o:os -> o :| os + + return $ CoinSelFinalResult neInps neOuts chgs' + {------------------------------------------------------------------------------- Receiver pays fee -------------------------------------------------------------------------------} -receiverPaysFee :: forall dom. CoinSelDom dom - => Fee dom - -> [CoinSelResult dom] - -> Except CoinSelHardErr [CoinSelResult dom] -receiverPaysFee totalFee = - mapM go . divvyFee (outVal . coinSelRequest) totalFee +receiverPaysFee + :: forall dom. CoinSelDom dom + => FeeOptions dom + -> [UtxoEntry dom] + -> [Output dom] + -> [Value dom] + -> Except CoinSelHardErr ([UtxoEntry dom], [Output dom], [Value dom]) +receiverPaysFee feeOptions inps outs chgs = do + let totalFee = feeUpperBound feeOptions inps outs chgs + outs' <- mapM go . divvyFee outVal totalFee $ outs + return (inps, outs', chgs) where - go :: (Fee dom, CoinSelResult dom) - -> Except CoinSelHardErr (CoinSelResult dom) - go (fee, cs) = - case outSubFee fee (coinSelRequest cs) of + go + :: (Fee dom, Output dom) + -> Except CoinSelHardErr (Output dom) + go (fee, out) = + case outSubFee fee out of Just newOut -> - return $ cs { coinSelOutput = newOut } + return newOut Nothing -> throwError $ - CoinSelHardErrOutputCannotCoverFee (pretty (coinSelRequest cs)) (pretty fee) + CoinSelHardErrOutputCannotCoverFee (pretty out) (pretty fee) {------------------------------------------------------------------------------- Sender pays fee -------------------------------------------------------------------------------} -senderPaysFee :: (Monad m, CoinSelDom (Dom utxo)) - => (Value (Dom utxo) -> - CoinSelT utxo CoinSelHardErr m (Maybe (UtxoEntry (Dom utxo)))) - -> Fee (Dom utxo) - -> [CoinSelResult (Dom utxo)] - -> CoinSelT utxo CoinSelHardErr m - ([CoinSelResult (Dom utxo)], SelectedUtxo (Dom utxo), Value (Dom utxo)) -senderPaysFee pickUtxo totalFee css = do - let (css', remainingFee) = feeFromChange totalFee css - (additionalUtxo, additionalChange) <- coverRemainingFee pickUtxo remainingFee - return (css', additionalUtxo, additionalChange) - -coverRemainingFee :: forall utxo m. (Monad m, CoinSelDom (Dom utxo)) - => (Value (Dom utxo) -> CoinSelT utxo CoinSelHardErr m (Maybe (UtxoEntry (Dom utxo)))) - -> Fee (Dom utxo) - -> CoinSelT utxo CoinSelHardErr m (SelectedUtxo (Dom utxo), Value (Dom utxo)) +senderPaysFee + :: (Monad m, CoinSelDom (Dom utxo)) + => PickUtxo m utxo + -> FeeOptions (Dom utxo) + -> [UtxoEntry (Dom utxo)] + -> [Output (Dom utxo)] + -> [Value (Dom utxo)] + -> CoinSelT utxo CoinSelHardErr m ([UtxoEntry (Dom utxo)], [Output (Dom utxo)], [Value (Dom utxo)]) +senderPaysFee pickUtxo feeOptions = go + where + go inps outs chgs = do + -- 1/ + -- We compute fees using all inputs, outputs and changes since + -- all of them have an influence on the fee calculation. + let fee = feeUpperBound feeOptions inps outs chgs + + -- 2/ + -- We try to cover fee with the available change by substracting equally + -- across all inputs. There's no fairness in that in the case of a + -- multi-account transaction. Everyone pays the same part. + let (chgs', remainingFee) = reduceChangeOutputs fee chgs + if getFee remainingFee == valueZero then + -- 3.1/ + -- Should the change cover the fee, we're done. + return (inps, outs, chgs') + + -- 3.2/ + -- 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. + else do + extraUtxo <- coverRemainingFee pickUtxo remainingFee + let inps' = selectedEntries extraUtxo + let extraChange = selectedBalance extraUtxo + go (inps <> inps') outs (splitChange extraChange chgs) + + +coverRemainingFee + :: forall utxo m. (Monad m, CoinSelDom (Dom utxo)) + => PickUtxo m utxo + -> Fee (Dom utxo) + -> CoinSelT utxo CoinSelHardErr m (SelectedUtxo (Dom utxo)) coverRemainingFee pickUtxo fee = go emptySelection where go :: SelectedUtxo (Dom utxo) - -> CoinSelT utxo CoinSelHardErr m (SelectedUtxo (Dom utxo), Value (Dom utxo)) + -> CoinSelT utxo CoinSelHardErr m (SelectedUtxo (Dom utxo)) go !acc | selectedBalance acc >= getFee fee = - return (acc, unsafeValueSub (selectedBalance acc) (getFee fee)) + return acc | otherwise = do mio <- (pickUtxo $ unsafeValueSub (getFee fee) (selectedBalance acc)) io <- maybe (throwError CoinSelHardErrCannotCoverFee) return mio go (select io acc) --- | Attempt to pay the fee from change outputs, returning any fee remaining --- --- NOTE: For sender pays fees, distributing the fee proportionally over the --- outputs is not strictly necessary (fairness is not a concern): we could just --- use the change of the first output to cover the entire fee (if sufficiently --- large). Doing it proportionally however has the benefit that the fee --- adjustment doesn't change the payment:change ratio too much, which may be --- important for the correct operation of the coin selection policy. --- --- NOTE: This does mean that /if/ the policy generates small outputs with --- very large corresponding change outputs, we may not make optional use of --- those change outputs and perhaps unnecessarily add additional UTxO entries. --- However, in most cases the policy cares about the output:change ratio, --- so we stick with this approach nonetheless. -feeFromChange :: forall dom. CoinSelDom dom - => Fee dom - -> [CoinSelResult dom] - -> ([CoinSelResult dom], Fee dom) -feeFromChange totalFee = - bimap identity unsafeFeeSum - . unzip - . map go - . divvyFee (outVal . coinSelRequest) totalFee - where - -- | Adjust the change output, returning any fee remaining - go :: (Fee dom, CoinSelResult dom) -> (CoinSelResult dom, Fee dom) - go (fee, cs) = - let (change', fee') = reduceChangeOutputs fee (coinSelChange cs) - in (cs { coinSelChange = change' }, fee') + +-- we should have (x + (sum ls) = sum result), but this check could overflow. +splitChange + :: forall dom. (CoinSelDom dom) + => Value dom + -> [Value dom] + -> [Value dom] +splitChange = go + where + go remaining [] = [remaining] + -- we only create new change if for whatever reason there is none already + -- or if is some overflow happens when we try to add. + go remaining [a] = case valueAdd remaining a of + Just newChange -> [newChange] + Nothing -> [a, remaining] + go remaining ls@(a : as) = + let piece = valueDiv remaining (length ls) + newRemaining = unsafeValueSub remaining piece -- unsafe because of div. + in case valueAdd piece a of + Just newChange -> newChange : go newRemaining as + Nothing -> a : go remaining as + -- | Reduce the given change outputs by the total fee, returning the remainig -- change outputs if any are left, or the remaining fee otherwise @@ -167,13 +228,19 @@ reduceChangeOutputs totalFee cs = Auxiliary -------------------------------------------------------------------------------} -feeUpperBound :: CoinSelDom dom - => FeeOptions dom -> [CoinSelResult dom] -> Fee dom -feeUpperBound FeeOptions{..} css = +feeUpperBound + :: forall dom. (CoinSelDom dom) + => FeeOptions dom + -> [UtxoEntry dom] + -> [Output dom] + -> [Value dom] + -> Fee dom +feeUpperBound FeeOptions{..} inps outs chgs = foEstimate numInputs outputs where - numInputs = fromIntegral $ sum (map (sizeToWord . coinSelInputSize) css) - outputs = concatMap coinSelOutputs css + numInputs = fromIntegral $ sizeToWord $ selectedSize $ foldr' select emptySelection inps + outputs = map outVal outs <> chgs + -- | divvy fee across outputs, discarding zero-output if any. Returns `Nothing` -- when there's no more outputs after filtering, in which case, we just can't diff --git a/wallet-new/test/unit/InputSelection/FromGeneric.hs b/wallet-new/test/unit/InputSelection/FromGeneric.hs index 163b574b64a..f30faa442bf 100644 --- a/wallet-new/test/unit/InputSelection/FromGeneric.hs +++ b/wallet-new/test/unit/InputSelection/FromGeneric.hs @@ -46,6 +46,7 @@ instance IsValue (SafeValue h a) where valueDist = safeDist valueRatio = safeRatio valueAdjust = safeAdjust + valueDiv = safeDiv instance (DSL.Hash h a, Buildable a) => CoinSelDom (DSL h a) where type Input (DSL h a) = DSL.Input h a @@ -109,6 +110,10 @@ safeRatio :: SafeValue h a -> SafeValue h a -> Double safeRatio (Value x) (Value y) = fromIntegral x / fromIntegral y +safeDiv :: SafeValue h a -> Int -> SafeValue h a +safeDiv (Value x) k = + Value (x `div` fromIntegral k) + -- TODO: check for underflow/overflow safeAdjust :: Rounding -> Double -> SafeValue h a -> Maybe (SafeValue h a) safeAdjust RoundUp d (Value x) = Just $ Value $ ceiling (d * fromIntegral x) diff --git a/wallet-new/test/unit/Test/Spec/CoinSelection.hs b/wallet-new/test/unit/Test/Spec/CoinSelection.hs index 65b24b3fbbd..97a5e9ef518 100644 --- a/wallet-new/test/unit/Test/Spec/CoinSelection.hs +++ b/wallet-new/test/unit/Test/Spec/CoinSelection.hs @@ -41,9 +41,8 @@ import Cardano.Wallet.Kernel.CoinSelection (CoinSelFinalResult (..), CoinSelectionOptions (..), ExpenseRegulation (..), InputGrouping (..), estimateMaxTxInputsExplicitBounds, largestFirst, newOptions, random) -import Cardano.Wallet.Kernel.CoinSelection.FromGeneric - (estimateCardanoFee, - estimateHardMaxTxInputsExplicitBounds) +import Cardano.Wallet.Kernel.CoinSelection.FromGeneric (Cardano, + estimateCardanoFee, estimateHardMaxTxInputsExplicitBounds) import Cardano.Wallet.Kernel.Transactions (mkStdTx) import Cardano.Wallet.Kernel.Util.Core (paymentAmount, utxoBalance, utxoRestrictToInputs) @@ -464,7 +463,7 @@ encodedSize = fromBytes . fromIntegral . LBS.length . toLazyByteString . encode type Policy = CoinSelectionOptions -> Word64 - -> CoinSelPolicy Core.Utxo Gen CoinSelFinalResult + -> CoinSelPolicy Core.Utxo Gen (CoinSelFinalResult Cardano) type RunResult = ( Core.Utxo , NonEmpty Core.TxOut From b6c72083c64a08376eb615f911a413d438dc7c9b Mon Sep 17 00:00:00 2001 From: KtorZ Date: Mon, 19 Nov 2018 09:54:19 +0100 Subject: [PATCH 2/3] fixup: Review comments & adjust estimateCardanoFee The 'estimateCardanoFee' was using 'round' but as pointed out by @duncan, core nodes use 'ceiling' which may cause some divergence in the fee computation. --- .../Kernel/CoinSelection/FromGeneric.hs | 4 +- .../Kernel/CoinSelection/Generic/Fees.hs | 39 ++++++++++++++++--- 2 files changed, 36 insertions(+), 7 deletions(-) diff --git a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs index 7c06960d11e..fbc46f711fe 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs @@ -392,8 +392,8 @@ estimateSize saa sta ins outs = -- here with some (hopefully) realistic values. estimateCardanoFee :: TxSizeLinear -> Int -> [Word64] -> Word64 estimateCardanoFee linearFeePolicy ins outs - = round $ calculateTxSizeLinear linearFeePolicy - $ hi $ estimateSize boundAddrAttrSize boundTxAttrSize ins outs + = ceiling $ calculateTxSizeLinear linearFeePolicy + $ hi $ estimateSize boundAddrAttrSize boundTxAttrSize ins outs checkCardanoFeeSanity :: TxSizeLinear -> Coin -> Bool checkCardanoFeeSanity linearFeePolicy fees = diff --git a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic/Fees.hs b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic/Fees.hs index b5b0c1b551f..909c7bbdf59 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic/Fees.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic/Fees.hs @@ -52,6 +52,29 @@ type PickUtxo m utxo -- | Given the coin selection result from a policy run, adjust the outputs -- for fees, potentially returning additional inputs that we need to cover -- all fees. +-- We lose the relationship between the transaction outputs and their +-- corresponding inputs/change outputs here. This is a decision we +-- may wish to revisit later. For now however note that since +-- +-- (a) coin selection tries to establish a particular ratio +-- between payment outputs and change outputs (currently it +-- aims for an average of 1:1) +-- +-- (b) coin selection currently only generates a single change +-- output per payment output, distributing the fee +-- proportionally across all change outputs is roughly +-- equivalent to distributing it proportionally over the +-- payment outputs (roughly, not exactly, because the 1:1 +-- proportion is best effort only, and may in some cases be +-- wildly different). +-- +-- Note that for (a) we don't need the ratio to be 1:1, the above +-- reasoning will remain true for any proportion 1:n. For (b) however, +-- if coin selection starts creating multiple outputs, and this number +-- may vary, then losing the connection between outputs and change +-- outputs will mean that that some outputs may pay a larger +-- percentage of the fee (depending on how many change outputs the +-- algorithm happened to choose). adjustForFees :: forall utxo m. (CoinSelDom (Dom utxo), Monad m) => FeeOptions (Dom utxo) @@ -129,10 +152,7 @@ senderPaysFee pickUtxo feeOptions = go -- all of them have an influence on the fee calculation. let fee = feeUpperBound feeOptions inps outs chgs - -- 2/ - -- We try to cover fee with the available change by substracting equally - -- across all inputs. There's no fairness in that in the case of a - -- multi-account transaction. Everyone pays the same part. + -- 2/ Substract fee from all change outputs, proportionally to their value. let (chgs', remainingFee) = reduceChangeOutputs fee chgs if getFee remainingFee == valueZero then -- 3.1/ @@ -176,7 +196,16 @@ coverRemainingFee pickUtxo fee = go emptySelection go (select io acc) --- we should have (x + (sum ls) = sum result), but this check could overflow. +-- Equally split the extra change obtained when picking new inputs across all +-- other change. Note that, it may create an extra change output if: +-- +-- (a) There's no change at all initially +-- (b) Adding change to an exiting one would cause an overflow +-- +-- It makes no attempt to divvy the new output proportionally over the change +-- outputs. This means that if we happen to pick a very large UTxO entry, adding +-- this evenly rather than proportionally might skew the payment:change ratio a +-- lot. Could consider defining this in terms of divvy instead. splitChange :: forall dom. (CoinSelDom dom) => Value dom From 132e63dcd7bb1450b022dc008ff672232ab9e48d Mon Sep 17 00:00:00 2001 From: KtorZ Date: Mon, 19 Nov 2018 12:35:18 +0100 Subject: [PATCH 3/3] Filter out dust change when reducing them --- .../Kernel/CoinSelection/FromGeneric.hs | 5 +- .../Kernel/CoinSelection/Generic/Fees.hs | 69 +++++++++++-------- 2 files changed, 43 insertions(+), 31 deletions(-) diff --git a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs index fbc46f711fe..43ac4633052 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs @@ -172,8 +172,9 @@ newOptions estimateFee check = CoinSelectionOptions { } feeOptions :: CoinSelectionOptions -> FeeOptions Cardano -feeOptions CoinSelectionOptions{..} = FeeOptions{ - foExpenseRegulation = csoExpenseRegulation +feeOptions CoinSelectionOptions{..} = FeeOptions + { foExpenseRegulation = csoExpenseRegulation + , foDustThreshold = csoDustThreshold , foEstimate = \numInputs outputs -> case outputs of [] -> error "feeOptions: empty list" diff --git a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic/Fees.hs b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic/Fees.hs index 909c7bbdf59..6fe5eda8a74 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic/Fees.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic/Fees.hs @@ -28,12 +28,15 @@ data ExpenseRegulation = -- and they wish to trasfer an @exact@ amount (or, for example, the max -- amount). -data FeeOptions dom = FeeOptions { - -- | Estimate fees based on number of inputs and values of the outputs - foEstimate :: Int -> [Value dom] -> Fee dom - - -- | Expense regulation (who pays the fees?) +data FeeOptions dom = FeeOptions + { foEstimate :: Int -> [Value dom] -> Fee dom + -- ^ Estimate fees based on number of inputs and values of the outputs , foExpenseRegulation :: ExpenseRegulation + -- ^ Expense regulation (who pays the fees?) + , foDustThreshold :: Value dom + -- ^ Change addresses below the given threshold will be evicted + -- from the created transaction. If you only want to remove change + -- outputs equal to 0, set 'csoDustThreshold' to 0. } data CoinSelFinalResult dom = CoinSelFinalResult @@ -137,7 +140,7 @@ receiverPaysFee feeOptions inps outs chgs = do -------------------------------------------------------------------------------} senderPaysFee - :: (Monad m, CoinSelDom (Dom utxo)) + :: forall utxo m. (Monad m, CoinSelDom (Dom utxo)) => PickUtxo m utxo -> FeeOptions (Dom utxo) -> [UtxoEntry (Dom utxo)] @@ -146,6 +149,9 @@ senderPaysFee -> CoinSelT utxo CoinSelHardErr m ([UtxoEntry (Dom utxo)], [Output (Dom utxo)], [Value (Dom utxo)]) senderPaysFee pickUtxo feeOptions = go where + removeDust :: [Value (Dom utxo)] -> [Value (Dom utxo)] + removeDust = changesRemoveDust (foDustThreshold feeOptions) + go inps outs chgs = do -- 1/ -- We compute fees using all inputs, outputs and changes since @@ -153,29 +159,30 @@ senderPaysFee pickUtxo feeOptions = go let fee = feeUpperBound feeOptions inps outs chgs -- 2/ Substract fee from all change outputs, proportionally to their value. - let (chgs', remainingFee) = reduceChangeOutputs fee chgs + let (chgs', remainingFee) = reduceChangeOutputs removeDust fee chgs + + -- 3.1/ + -- Should the change cover the fee, we're done. if getFee remainingFee == valueZero then - -- 3.1/ - -- Should the change cover the fee, we're done. return (inps, outs, chgs') - -- 3.2/ - -- 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. + -- 3.2/ + -- 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. else do extraUtxo <- coverRemainingFee pickUtxo remainingFee - let inps' = selectedEntries extraUtxo - let extraChange = selectedBalance extraUtxo - go (inps <> inps') outs (splitChange extraChange chgs) + let inps' = selectedEntries extraUtxo + let extraChange = splitChange (selectedBalance extraUtxo) chgs + go (inps <> inps') outs extraChange coverRemainingFee @@ -233,14 +240,18 @@ splitChange = go -- As for the overall fee in 'feeFromChange', we divvy up the fee over all -- change outputs proportionally, to try and keep any output:change ratio -- as unchanged as possible -reduceChangeOutputs :: forall dom. CoinSelDom dom - => Fee dom -> [Value dom] -> ([Value dom], Fee dom) -reduceChangeOutputs totalFee cs = +reduceChangeOutputs + :: forall dom. CoinSelDom dom + => ([Value dom] -> [Value dom]) + -> Fee dom + -> [Value dom] + -> ([Value dom], Fee dom) +reduceChangeOutputs removeDust totalFee cs = case divvyFeeSafe identity totalFee cs of Nothing -> - (cs, totalFee) + (removeDust cs, totalFee) Just xs -> - bimap identity unsafeFeeSum + bimap removeDust unsafeFeeSum . unzip . map go $ xs