Skip to content
This repository has been archived by the owner on Aug 18, 2020. It is now read-only.

Commit

Permalink
Merge pull request #3875 from input-output-hk/KtorZ/RCD-45-RCD-44/rev…
Browse files Browse the repository at this point in the history 
…iew-fee-calculation

[RCD-44] & [RCD-45] &  [RCD-46] - Review fee calculation and Fix prefiltering not ignoring inputs' ids [develop]
  • Loading branch information
@KtorZ
KtorZ authored Nov 21, 2018
2 parents 385c6b7 + 349de60 commit 0bd5d15
Show file tree
Hide file tree
Showing 7 changed files with 349 additions and 183 deletions.
93 changes: 82 additions & 11 deletions wallet-new/integration/TransactionSpecs.hs
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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]
Expand Down
65 changes: 12 additions & 53 deletions wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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"
Expand All @@ -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
Expand All @@ -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:
--
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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 =
Expand Down
6 changes: 6 additions & 0 deletions wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -28,6 +28,7 @@ module Cardano.Wallet.Kernel.CoinSelection.Generic (
, mapCoinSelErr
, mapCoinSelUtxo
, unwrapCoinSelT
, evalCoinSelT
, wrapCoinSelT
-- * Errors
, CoinSelHardErr(..)
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down
Loading

0 comments on commit 0bd5d15

Please sign in to comment.