From f5cded74b39abdf7a6c77639d3bc3f6bff9118e6 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 | 65 +--- .../Wallet/Kernel/CoinSelection/Generic.hs | 6 + .../Kernel/CoinSelection/Generic/Fees.hs | 293 ++++++++++++------ .../test/unit/InputSelection/FromGeneric.hs | 5 + .../test/unit/Test/Spec/CoinSelection.hs | 7 +- 5 files changed, 229 insertions(+), 147 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..43ac4633052 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 @@ -171,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" @@ -191,14 +193,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 +209,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 +227,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 +305,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 +320,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 @@ -434,8 +393,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.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..a89d3e759e1 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 @@ -27,115 +28,217 @@ 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 + { 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)) +-- 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. (Monad m, CoinSelDom (Dom utxo)) + => 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 + :: forall utxo m. (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 + 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 + -- all of them have an influence on the fee calculation. + let fee = feeUpperBound feeOptions inps outs chgs + + -- 2/ Substract fee from all change outputs, proportionally to their value. + let (chgs', remainingFee) = reduceChangeOutputs removeDust fee chgs + + -- 3.1/ + -- 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 getFee remainingFee == valueZero then do + 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 = splitChange (selectedBalance extraUtxo) chgs + go (inps <> inps') outs extraChange + + +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 + +-- Equally split the extra change obtained when picking new inputs across all +-- other change. Note that, it may create an extra change output if: -- --- 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. +-- (a) There's no change at all initially +-- (b) Adding change to an exiting one would cause an overflow -- --- 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 +-- 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 + -> [Value dom] + -> [Value dom] +splitChange = go 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') + go remaining as | remaining == valueZero = + as + 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 @@ -143,14 +246,18 @@ feeFromChange totalFee = -- 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 @@ -167,13 +274,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 b1de3cda550d292a0ad96eb34ac84c9964f6ce77 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Mon, 19 Nov 2018 16:25:42 +0100 Subject: [PATCH 2/3] [RCD-44] & [RCD-45] Add integration tests to illustrate fix --- wallet-new/integration/TransactionSpecs.hs | 93 +++++++++++++++++++--- 1 file changed, 82 insertions(+), 11 deletions(-) diff --git a/wallet-new/integration/TransactionSpecs.hs b/wallet-new/integration/TransactionSpecs.hs index bd9a5ecce39..13ca0cf9b82 100644 --- a/wallet-new/integration/TransactionSpecs.hs +++ b/wallet-new/integration/TransactionSpecs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} @@ -162,19 +163,19 @@ transactionSpecs wRef wc = beforeAll_ (setupLogging "wallet-new_transactionSpecs <> show err randomTest "fails if you don't have any money" 1 $ run $ do - (wallet, account) <- fixtureWallet Nothing + (wallet, account) <- fixtureWallet [] resp <- makePayment (Core.mkCoin 14) (wallet, account) =<< getRandomAddress let err = NotEnoughMoney (ErrAvailableBalanceIsInsufficient 0) expectFailure (ClientWalletError err) resp randomTest "fails if you spend more money than your available balance" 1 $ run $ do - (wallet, account) <- fixtureWallet (Just $ Core.mkCoin 42) + (wallet, account) <- fixtureWallet (Core.mkCoin <$> [42]) resp <- makePayment (Core.mkCoin 10000) (wallet, account) =<< getRandomAddress let err = NotEnoughMoney (ErrAvailableBalanceIsInsufficient 42) expectFailure (ClientWalletError err) resp randomTest "fails if you can't cover fee with a transaction" 1 $ run $ do - (wallet, account) <- fixtureWallet (Just $ Core.mkCoin 42) + (wallet, account) <- fixtureWallet (Core.mkCoin <$> [42]) resp <- makePayment (Core.mkCoin 42) (wallet, account) =<< getRandomAddress let err = NotEnoughMoney ErrCannotCoverFee expectFailure (ClientWalletError err) resp @@ -222,6 +223,66 @@ transactionSpecs wRef wc = beforeAll_ (setupLogging "wallet-new_transactionSpecs let utxoStatisticsExpected = computeUtxoStatistics log10 utxos liftIO $ utxoStatistics `shouldBe` utxoStatisticsExpected + -- NOTE: + -- Cases where we have to increase the number of change outputs are hard + -- to test in practice. We either need: + -- + -- - A BIG change to cause an overflow (but even with all the genesis + -- wallets, we don't have enough funds) + -- + -- - A selection that will have no change such that a new one will be + -- created for the change. However, the coin selection tends to always + -- generate a change output. + + + -- Initial Selection: Final Selection: + -- inputs : [200000] inputs : [200000] + -- outputs: [1] outputs: [1] + -- changes: [199999] changes: [28094] + -- fee+ : 171905 fee+ : 171817 + -- + -- Actual fee: 171905 (+88) + randomTest "fee calculation: no extra inputs, no extra change" 1 $ run $ do + source <- fixtureWallet (Core.mkCoin <$> [200000]) + resp <- makePayment (Core.mkCoin 1) source =<< getRandomAddress + expectConfirmation source resp + + -- Initial Selection: Final Selection: + -- inputs : [171906] inputs : [171906] + -- outputs: [1] outputs: [1] + -- changes: [171905] changes: [] + -- fee+ : 171905 fee+ : 167862 + -- + -- Actual fee: 167862 (+4043) + randomTest "fee calculation: empty a wallet" 1 $ run $ do + source <- fixtureWallet (Core.mkCoin <$> [171906]) + resp <- makePayment (Core.mkCoin 1) source =<< getRandomAddress + expectConfirmation source resp + + -- Initial Selection: Final Selection: + -- inputs : [100000] inputs : [100000, 100000] + -- outputs: [1] outputs: [1] + -- changes: [99999] changes: [19964] + -- fee+ : 171905 fee+ : 179947 + -- + -- Actual fee: 180035 (+88) + randomTest "fee calculation: needs extra input, no extra change" 1 $ run $ do + source <- fixtureWallet (Core.mkCoin <$> [100000, 100000]) + resp <- makePayment (Core.mkCoin 1) source =<< getRandomAddress + expectConfirmation source resp + + -- Initial Selection: Final Selection: + -- inputs : [30000] inputs : [30000, 30000, 30000, 30000, + -- 30000, 30000, 30000, 30000] + -- outputs: [42] outputs: [42] + -- changes: [29958] changes: [11055] + -- fee+ : 171905 fee+ : 228815 + -- + -- Actual fee: 228903 (+88) + randomTest "fee calculation: needs many extra inputs" 1 $ run $ do + source <- fixtureWallet (replicate 8 (Core.mkCoin 30000)) + resp <- makePayment (Core.mkCoin 42) source =<< getRandomAddress + expectConfirmation source resp where makePayment amount (sourceW, sourceA) destination = fmap (fmap wrData) $ Util.makePayment wc amount (sourceW, sourceA) destination @@ -234,18 +295,18 @@ transactionSpecs wRef wc = beforeAll_ (setupLogging "wallet-new_transactionSpecs return (unV1 $ addrId toAddr) fixtureWallet - :: Maybe Core.Coin + :: [Core.Coin] -> IO (Wallet, Account) - fixtureWallet mcoin = do + fixtureWallet coins = do genesis <- genesisWallet wc (genesisAccount, _) <- firstAccountAndId wc genesis wallet <- randomWallet CreateWallet >>= createWalletCheck wc - (account, address) <- firstAccountAndId wc wallet - case mcoin of - Nothing -> return () - Just coin -> do - txn <- makePayment coin (genesis, genesisAccount) (unV1 $ addrId address) >>= shouldPrismFlipped _Right - pollTransactions wc (walId wallet) (accIndex account) (txId txn) + (account, _) <- firstAccountAndId wc wallet + forM_ coins $ \coin -> do + -- Make transaction to different addresses to cope with input selection grouping. + addr <- createAddress wc (wallet, account) + txn <- makePayment coin (genesis, genesisAccount) (unV1 $ addrId addr) >>= shouldPrismFlipped _Right + pollTransactions wc (walId wallet) (accIndex account) (txId txn) return (wallet, account) expectFailure @@ -257,6 +318,16 @@ transactionSpecs wRef wc = beforeAll_ (setupLogging "wallet-new_transactionSpecs resp <- eresp `shouldPrism` _Left resp `shouldBe` want + expectConfirmation + :: (Wallet, Account) + -> Either ClientError Transaction + -> IO () + expectConfirmation (wallet, account) = \case + Left err -> + fail $ "Expected transcation confirmation, but got a ClientError: " <> show err + Right txn -> + pollTransactions wc (walId wallet) (accIndex account) (txId txn) + shouldBeConfirmed :: Transaction -> [Transaction] From 349de6048d589bfbb76a8e0537fdec311f635c17 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 20 Nov 2018 13:28:21 +0100 Subject: [PATCH 3/3] [RCD-46] Fix Prefiltering: take txs' ids into account Prefiltering seems to totally ignore txIds from Inputs while creating blockMeta. On the other hand it uses TxIns to see which utxos are used. This means that if an account has only inputs in a tx, the tx will be marked as failed (`WontApply`). This can happens when it creating a transction that consumes its utxo entirely (no change outputs). --- .../src/Cardano/Wallet/Kernel/PrefilterTx.hs | 63 +++++++++++-------- 1 file changed, 38 insertions(+), 25 deletions(-) diff --git a/wallet-new/src/Cardano/Wallet/Kernel/PrefilterTx.hs b/wallet-new/src/Cardano/Wallet/Kernel/PrefilterTx.hs index dbfaca9ad7d..0f7b5ed5909 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/PrefilterTx.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/PrefilterTx.hs @@ -43,7 +43,7 @@ import Cardano.Wallet.Kernel.DB.HdWallet import Cardano.Wallet.Kernel.DB.InDb (InDb (..), fromDb) import Cardano.Wallet.Kernel.DB.Resolved (ResolvedBlock, ResolvedInput, ResolvedTx, rbContext, rbTxs, - resolvedToTxMeta, rtxInputs, rtxOutputs) + resolvedToTxMeta, rtxInputs, rtxMeta, rtxOutputs) import Cardano.Wallet.Kernel.DB.Spec.Pending (Pending) import qualified Cardano.Wallet.Kernel.DB.Spec.Pending as Pending import Cardano.Wallet.Kernel.DB.TxMeta.Types @@ -140,7 +140,7 @@ type UtxoSummaryRaw = Map TxIn (TxOutAux,AddressSummary) -- Accounts. prefilterTx :: WalletKey -> ResolvedTx - -> ((Map HdAccountId (Set TxIn) + -> ((Map HdAccountId (Set (TxIn, TxId)) , Map HdAccountId UtxoSummaryRaw) , [TxMeta]) -- ^ prefiltered inputs, prefiltered output utxo, extended with address summary @@ -154,8 +154,9 @@ prefilterTx wKey tx = ((prefInps',prefOuts'),metas) prefOuts' = Map.map (extendWithSummary (onlyOurInps,onlyOurOuts)) prefOuts + txId = fst $ tx ^. rtxMeta . fromDb -- this Set.map does not change the number of elements because TxIn's are unique. - prefInps' = map (Set.map fst) prefInps + prefInps' = map (Set.map (\(txin, _) -> (txin, txId))) prefInps (prefInCoins :: (Map HdAccountId Coin)) = map (sumCoinsUnsafe . map snd . Set.toList) prefInps (prefOutCoins :: (Map HdAccountId Coin)) = map (\mp -> sumCoinsUnsafe $ map (toCoin . fst) mp) prefOuts' @@ -181,7 +182,7 @@ prefilterTxForWallets :: [WalletKey] -> Map TxIn HdAccountId -> ResolvedTx - -> ((Map HdAccountId (Set TxIn, Set TxIn) + -> ((Map HdAccountId (Set (TxIn, TxId), Set (TxIn, TxId)) , Map HdAccountId UtxoSummaryRaw) , [TxMeta]) prefilterTxForWallets wKeys foreignPendingByTransaction tx = @@ -189,22 +190,27 @@ prefilterTxForWallets wKeys foreignPendingByTransaction tx = where ((inputs,outputs),meta) = mconcat $ map ((flip prefilterTx) tx) wKeys + txId :: TxId + txId = fst $ tx ^. rtxMeta . fromDb + --NOTE: to find the foreign inputs in the transaction, we need to look at _all_ the inputs, since they will not be present in the prefiltered inputs - allInputs :: Set TxIn - allInputs = Set.fromList $ map fst $ toList (tx ^. rtxInputs . fromDb) + allInputs :: Set (TxIn, TxId) + allInputs = Set.fromList $ map ((, txId) . fst) $ toList (tx ^. rtxInputs . fromDb) - foreignInputs :: Map HdAccountId (Set TxIn) - foreignInputs = - reindexByAccount $ Map.filterWithKey (\txin _ -> Set.member txin allInputs) foreignPendingByTransaction + foreignInputs :: Map HdAccountId (Set (TxIn, TxId)) + foreignInputs = Map.map (Set.map (, txId)) $ reindexByAccount $ + Map.filterWithKey + (\txin _ -> Set.member (txin, txId) allInputs) + foreignPendingByTransaction - inputsE, foreignInputsE :: Map HdAccountId (Set TxIn, Set TxIn) + inputsE, foreignInputsE :: Map HdAccountId (Set (TxIn, TxId), Set (TxIn, TxId)) inputsE = Map.map (, Set.empty) inputs foreignInputsE = Map.map (Set.empty,) foreignInputs extend - :: Map HdAccountId (Set TxIn, Set TxIn) - -> Map HdAccountId (Set TxIn, Set TxIn) - -> Map HdAccountId (Set TxIn, Set TxIn) + :: Map HdAccountId (Set (TxIn, TxId), Set (TxIn, TxId)) + -> Map HdAccountId (Set (TxIn, TxId), Set (TxIn, TxId)) + -> Map HdAccountId (Set (TxIn, TxId), Set (TxIn, TxId)) extend inputs_ foreignInputs_ = Map.unionWith (\inp fInp -> (fst inp, snd fInp)) inputs_ foreignInputs_ @@ -345,13 +351,13 @@ prefilterBlock nm foreignPendingByAccount block rawKeys = foreignPendingByTransaction :: Map TxIn HdAccountId foreignPendingByTransaction = reindexByTransaction $ Map.map Pending.txIns foreignPendingByAccount - inps :: [Map HdAccountId (Set TxIn, Set TxIn)] + inps :: [Map HdAccountId (Set (TxIn, TxId), Set (TxIn, TxId))] outs :: [Map HdAccountId UtxoSummaryRaw] (ios, conMetas) = unzip $ map (prefilterTxForWallets wKeys foreignPendingByTransaction) (block ^. rbTxs) (inps, outs) = unzip ios metas = concat conMetas - inpAll :: Map HdAccountId (Set TxIn, Set TxIn) + inpAll :: Map HdAccountId (Set (TxIn, TxId), Set (TxIn, TxId)) outAll :: Map HdAccountId UtxoSummaryRaw inpAll = Map.unionsWith (\pair1 pair2 -> (Set.union (fst pair1) (fst pair2),Set.union (snd pair1) (fst pair2))) inps outAll = Map.unionsWith Map.union outs @@ -369,7 +375,7 @@ prefilterBlock nm foreignPendingByAccount block rawKeys = mkPrefBlock :: BlockContext - -> Map HdAccountId (Set TxIn, Set TxIn) + -> Map HdAccountId (Set (TxIn, TxId), Set (TxIn, TxId)) -> Map HdAccountId (Map TxIn (TxOutAux, AddressSummary)) -> HdAccountId -> (HdAccountId, PrefilteredBlock) @@ -377,7 +383,7 @@ mkPrefBlock context inps outs accId = (accId, PrefilteredBlock { pfbInputs = walletInps' , pfbForeignInputs = foreignInps' , pfbOutputs = outs' - , pfbAddrs = addrs'' + , pfbAddrs = addrs' , pfbMeta = blockMeta' , pfbContext = context }) @@ -391,17 +397,24 @@ mkPrefBlock context inps outs accId = (accId, PrefilteredBlock { Map.filter (not . Set.null . fst) inps foreignInps = Map.map snd $ Map.filter (not . Set.null . snd) inps - walletInps' = byAccountId accId Set.empty walletInps - foreignInps' = byAccountId accId Set.empty foreignInps - (outs', addrs') = fromUtxoSummary (byAccountId accId Map.empty outs) + walletInps' = Set.map fst $ byAccountId accId Set.empty walletInps + foreignInps' = Set.map fst $ byAccountId accId Set.empty foreignInps + + allInps = (Map.map fst inps) + inpsWithtxId = byAccountId accId Set.empty allInps + -- this Set.map may reduce the number of elements. But this is okey, since we + -- don't care about repetitions on txIds. + + txIdsFromInputs = Set.map snd inpsWithtxId + (outs' , addrsFromOutputs) = fromUtxoSummary (byAccountId accId Map.empty outs) - addrs'' = nub $ map fromAddrSummary addrs' - blockMeta' = mkBlockMeta (context ^. bcSlotId . fromDb) addrs' + addrs' = nub $ map fromAddrSummary addrsFromOutputs + blockMeta' = mkBlockMeta (context ^. bcSlotId . fromDb) addrsFromOutputs txIdsFromInputs -mkBlockMeta :: SlotId -> [AddressSummary] -> LocalBlockMeta -mkBlockMeta slotId addrs_ = LocalBlockMeta BlockMeta{..} +mkBlockMeta :: SlotId -> [AddressSummary] -> Set TxId -> LocalBlockMeta +mkBlockMeta slotId addrs_ txIds = LocalBlockMeta BlockMeta{..} where - txIds' = nub $ map addrSummaryTxId addrs_ + txIds' = (Set.toList txIds) <> (nub $ map addrSummaryTxId addrs_) indexedAddrs = indexByAddr addrs_