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

Commit 2dbcd7a

Browse files
KtorZKtorZ
committed
[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 🙃 ... 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.
1 parent b49b9de commit 2dbcd7a

File tree

4 files changed

+151
-111
lines changed

4 files changed

+151
-111
lines changed

‎wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs‎

Lines changed: 10 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -70,6 +70,7 @@ instance IsValue Core.Coin where
7070
else a `Core.unsafeSubCoin` b
7171
valueRatio = \ a b -> coinToDouble a / coinToDouble b
7272
valueAdjust = \r d a -> coinFromDouble r (d * coinToDouble a)
73+
valueDiv = divCoin
7374

7475
instance CoinSelDom Cardano where
7576
type Input Cardano = Core.TxIn
@@ -234,43 +235,16 @@ runCoinSelT opts pickUtxo policy (NE.sortBy (flip (comparing outVal)) -> request
234235
-- Therefore, just always considering them in order from large to small
235236
-- is probably a good idea.
236237
mSelection <- unwrapCoinSelT policy' utxo
237-
case mSelection of
238-
Left err -> return (Left err)
239-
Right ((css, additionalUtxo, additionalChange), _utxo') -> do
240-
let inps = concatMap selectedEntries
241-
(additionalUtxo : map coinSelInputs css)
242-
outs = map coinSelOutput css
243-
changesWithDust = splitChange additionalChange $ concatMap coinSelChange css
244-
let allInps = case inps of
245-
[] -> error "runCoinSelT: empty list of inputs"
246-
i:is -> i :| is
247-
originalOuts = case outs of
248-
[] -> error "runCoinSelT: empty list of outputs"
249-
o:os -> o :| os
250-
changes = changesRemoveDust (csoDustThreshold opts) changesWithDust
251-
return . Right $ CoinSelFinalResult allInps
252-
originalOuts
253-
changes
238+
return $ case mSelection of
239+
Left err -> Left err
240+
Right ((inps, outs, chgs), _) -> Right $ CoinSelFinalResult inps outs chgs
254241
where
255-
-- we should have (x + (sum ls) = sum result), but this check could overflow.
256-
splitChange :: Value Cardano -> [Value Cardano] -> [Value Cardano]
257-
splitChange = go
258-
where
259-
go remaining [] = [remaining]
260-
-- we only create new change if for whatever reason there is none already
261-
-- or if is some overflow happens when we try to add.
262-
go remaining [a] = case valueAdd remaining a of
263-
Just newChange -> [newChange]
264-
Nothing -> [a, remaining]
265-
go remaining ls@(a : as) =
266-
let piece = divCoin remaining (length ls)
267-
newRemaining = unsafeValueSub remaining piece -- unsafe because of div.
268-
in case valueAdd piece a of
269-
Just newChange -> newChange : go newRemaining as
270-
Nothing -> a : go remaining as
271-
272-
policy' :: CoinSelT Core.Utxo CoinSelHardErr m
273-
([CoinSelResult Cardano], SelectedUtxo Cardano, Value Cardano)
242+
policy'
243+
:: CoinSelT Core.Utxo CoinSelHardErr m
244+
( NonEmpty (UtxoEntry Cardano)
245+
, NonEmpty (Output Cardano)
246+
, [Value Cardano]
247+
)
274248
policy' = do
275249
mapM_ validateOutput request
276250
css <- intInputGrouping (csoInputGrouping opts)

‎wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -91,6 +91,7 @@ class Ord v => IsValue v where
9191
valueDist :: v -> v -> v -- ^ @|a - b|@
9292
valueRatio :: v -> v -> Double -- ^ @a / b@
9393
valueAdjust :: Rounding -> Double -> v -> Maybe v -- ^ @a * b@
94+
valueDiv :: v -> Int -> v -- ^ @a / k@
9495

9596
class ( Ord (Input dom)
9697
, IsValue (Value dom)

‎wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/Generic/Fees.hs‎

Lines changed: 135 additions & 75 deletions
Original file line numberDiff line numberDiff line change
@@ -35,42 +35,68 @@ data FeeOptions dom = FeeOptions {
3535
, foExpenseRegulation :: ExpenseRegulation
3636
}
3737

38+
39+
type PickUtxo m utxo
40+
= Value (Dom utxo)
41+
-> CoinSelT utxo CoinSelHardErr m (Maybe (UtxoEntry (Dom utxo)))
42+
3843
-- | Given the coin selection result from a policy run, adjust the outputs
3944
-- for fees, potentially returning additional inputs that we need to cover
4045
-- all fees.
41-
adjustForFees :: forall utxo m. (CoinSelDom (Dom utxo), Monad m)
42-
=> FeeOptions (Dom utxo)
43-
-> (Value (Dom utxo) ->
44-
CoinSelT utxo CoinSelHardErr m (Maybe (UtxoEntry (Dom utxo))))
45-
-> [CoinSelResult (Dom utxo)]
46-
-> CoinSelT utxo CoinSelHardErr m
47-
([CoinSelResult (Dom utxo)], SelectedUtxo (Dom utxo), Value (Dom utxo))
46+
adjustForFees
47+
:: forall utxo m. (CoinSelDom (Dom utxo), Monad m)
48+
=> FeeOptions (Dom utxo)
49+
-> PickUtxo m utxo
50+
-> [CoinSelResult (Dom utxo)]
51+
-> CoinSelT utxo CoinSelHardErr m (NonEmpty (UtxoEntry (Dom utxo)), NonEmpty (Output (Dom utxo)), [Value (Dom utxo)])
4852
adjustForFees feeOptions pickUtxo css = do
49-
case foExpenseRegulation feeOptions of
50-
ReceiverPaysFee -> coinSelLiftExcept $
51-
(, emptySelection, valueZero) <$> receiverPaysFee upperBound css
52-
SenderPaysFee ->
53-
senderPaysFee pickUtxo upperBound css
54-
where
55-
upperBound = feeUpperBound feeOptions css
53+
(inps, outs, chgs) <-
54+
case foExpenseRegulation feeOptions of
55+
ReceiverPaysFee ->
56+
coinSelLiftExcept $ receiverPaysFee feeOptions css
57+
58+
SenderPaysFee ->
59+
senderPaysFee pickUtxo feeOptions css
60+
61+
62+
let neInps = case inps of
63+
[] -> error "adjustForFees: empty list of inputs"
64+
i:is -> i :| is
65+
66+
let neOuts = case outs of
67+
[] -> error "adjustForFees: empty list of outputs"
68+
o:os -> o :| os
69+
70+
return (neInps, neOuts, chgs)
71+
72+
5673

5774
{-------------------------------------------------------------------------------
5875
Receiver pays fee
5976
-------------------------------------------------------------------------------}
6077

61-
receiverPaysFee :: forall dom. CoinSelDom dom
62-
=> Fee dom
63-
-> [CoinSelResult dom]
64-
-> Except CoinSelHardErr [CoinSelResult dom]
65-
receiverPaysFee totalFee =
66-
mapM go . divvyFee (outVal . coinSelRequest) totalFee
78+
receiverPaysFee
79+
:: forall dom. CoinSelDom dom
80+
=> FeeOptions dom
81+
-> [CoinSelResult dom]
82+
-> Except CoinSelHardErr ([UtxoEntry dom], [Output dom], [Value dom])
83+
receiverPaysFee feeOptions css =
84+
let
85+
inps = concatMap selectedEntries $ map coinSelInputs css
86+
outs = map coinSelOutput css
87+
chgs = concatMap coinSelChange css
88+
totalFee = feeUpperBound feeOptions inps outs chgs
89+
in do
90+
outs' <- mapM go . divvyFee (outVal . coinSelRequest) totalFee $ css
91+
return (inps, outs', chgs)
6792
where
68-
go :: (Fee dom, CoinSelResult dom)
69-
-> Except CoinSelHardErr (CoinSelResult dom)
93+
go
94+
:: (Fee dom, CoinSelResult dom)
95+
-> Except CoinSelHardErr (Output dom)
7096
go (fee, cs) =
7197
case outSubFee fee (coinSelRequest cs) of
7298
Just newOut ->
73-
return $ cs { coinSelOutput = newOut }
99+
return newOut
74100
Nothing ->
75101
throwError $
76102
CoinSelHardErrOutputCannotCoverFee (pretty (coinSelRequest cs)) (pretty fee)
@@ -79,63 +105,91 @@ receiverPaysFee totalFee =
79105
Sender pays fee
80106
-------------------------------------------------------------------------------}
81107

82-
senderPaysFee :: (Monad m, CoinSelDom (Dom utxo))
83-
=> (Value (Dom utxo) ->
84-
CoinSelT utxo CoinSelHardErr m (Maybe (UtxoEntry (Dom utxo))))
85-
-> Fee (Dom utxo)
86-
-> [CoinSelResult (Dom utxo)]
87-
-> CoinSelT utxo CoinSelHardErr m
88-
([CoinSelResult (Dom utxo)], SelectedUtxo (Dom utxo), Value (Dom utxo))
89-
senderPaysFee pickUtxo totalFee css = do
90-
let (css', remainingFee) = feeFromChange totalFee css
91-
(additionalUtxo, additionalChange) <- coverRemainingFee pickUtxo remainingFee
92-
return (css', additionalUtxo, additionalChange)
93-
94-
coverRemainingFee :: forall utxo m. (Monad m, CoinSelDom (Dom utxo))
95-
=> (Value (Dom utxo) -> CoinSelT utxo CoinSelHardErr m (Maybe (UtxoEntry (Dom utxo))))
96-
-> Fee (Dom utxo)
97-
-> CoinSelT utxo CoinSelHardErr m (SelectedUtxo (Dom utxo), Value (Dom utxo))
108+
senderPaysFee
109+
:: (Monad m, CoinSelDom (Dom utxo))
110+
=> PickUtxo m utxo
111+
-> FeeOptions (Dom utxo)
112+
-> [CoinSelResult (Dom utxo)]
113+
-> CoinSelT utxo CoinSelHardErr m ([UtxoEntry (Dom utxo)], [Output (Dom utxo)], [Value (Dom utxo)])
114+
senderPaysFee pickUtxo feeOptions css = do
115+
let inps = concatMap selectedEntries $ map coinSelInputs css
116+
let outs = map coinSelOutput css
117+
let chgs = concatMap coinSelChange css
118+
go inps outs chgs
119+
where
120+
go inps outs chgs = do
121+
-- 1/
122+
-- We compute fees using all inputs, outputs and changes since
123+
-- all of them have an influence on the fee calculation.
124+
let fee = feeUpperBound feeOptions inps outs chgs
125+
126+
-- 2/
127+
-- We try to cover fee with the available change by substracting equally
128+
-- across all inputs. There's no fairness in that in the case of a
129+
-- multi-account transaction. Everyone pays the same part.
130+
let (chgs', remainingFee) = reduceChangeOutputs fee chgs
131+
if getFee remainingFee == valueZero then
132+
-- 3.1/
133+
-- Should the change cover the fee, we're done.
134+
return (inps, outs, chgs')
135+
136+
-- 3.2/
137+
-- Otherwise, we need an extra entries from the available utxo to
138+
-- cover what's left. Note that this entry may increase our change
139+
-- because we may not consume it entirely. So we will just split
140+
-- the extra change across all changes possibly increasing the
141+
-- number of change outputs (if there was none, or if increasing
142+
-- a change value causes an overflow).
143+
--
144+
-- Because selecting a new input increases the fee, we need to
145+
-- re-run the algorithm with this new elements and using the initial
146+
-- change plus the extra change brought up by this entry and see if
147+
-- we can now correctly cover fee.
148+
else do
149+
extraUtxo <- coverRemainingFee pickUtxo remainingFee
150+
let inps' = selectedEntries extraUtxo
151+
let extraChange = selectedBalance extraUtxo
152+
go (inps <> inps') outs (splitChange extraChange chgs)
153+
154+
155+
coverRemainingFee
156+
:: forall utxo m. (Monad m, CoinSelDom (Dom utxo))
157+
=> PickUtxo m utxo
158+
-> Fee (Dom utxo)
159+
-> CoinSelT utxo CoinSelHardErr m (SelectedUtxo (Dom utxo))
98160
coverRemainingFee pickUtxo fee = go emptySelection
99161
where
100162
go :: SelectedUtxo (Dom utxo)
101-
-> CoinSelT utxo CoinSelHardErr m (SelectedUtxo (Dom utxo), Value (Dom utxo))
163+
-> CoinSelT utxo CoinSelHardErr m (SelectedUtxo (Dom utxo))
102164
go !acc
103165
| selectedBalance acc >= getFee fee =
104-
return (acc, unsafeValueSub (selectedBalance acc) (getFee fee))
166+
return acc
105167
| otherwise = do
106168
mio <- (pickUtxo $ unsafeValueSub (getFee fee) (selectedBalance acc))
107169
io <- maybe (throwError CoinSelHardErrCannotCoverFee) return mio
108170
go (select io acc)
109171

110-
-- | Attempt to pay the fee from change outputs, returning any fee remaining
111-
--
112-
-- NOTE: For sender pays fees, distributing the fee proportionally over the
113-
-- outputs is not strictly necessary (fairness is not a concern): we could just
114-
-- use the change of the first output to cover the entire fee (if sufficiently
115-
-- large). Doing it proportionally however has the benefit that the fee
116-
-- adjustment doesn't change the payment:change ratio too much, which may be
117-
-- important for the correct operation of the coin selection policy.
118-
--
119-
-- NOTE: This does mean that /if/ the policy generates small outputs with
120-
-- very large corresponding change outputs, we may not make optional use of
121-
-- those change outputs and perhaps unnecessarily add additional UTxO entries.
122-
-- However, in most cases the policy cares about the output:change ratio,
123-
-- so we stick with this approach nonetheless.
124-
feeFromChange :: forall dom. CoinSelDom dom
125-
=> Fee dom
126-
-> [CoinSelResult dom]
127-
-> ([CoinSelResult dom], Fee dom)
128-
feeFromChange totalFee =
129-
bimap identity unsafeFeeSum
130-
. unzip
131-
. map go
132-
. divvyFee (outVal . coinSelRequest) totalFee
133-
where
134-
-- | Adjust the change output, returning any fee remaining
135-
go :: (Fee dom, CoinSelResult dom) -> (CoinSelResult dom, Fee dom)
136-
go (fee, cs) =
137-
let (change', fee') = reduceChangeOutputs fee (coinSelChange cs)
138-
in (cs { coinSelChange = change' }, fee')
172+
-- we should have (x + (sum ls) = sum result), but this check could overflow.
173+
splitChange
174+
:: forall dom. (CoinSelDom dom)
175+
=> Value dom
176+
-> [Value dom]
177+
-> [Value dom]
178+
splitChange = go
179+
where
180+
go remaining [] = [remaining]
181+
-- we only create new change if for whatever reason there is none already
182+
-- or if is some overflow happens when we try to add.
183+
go remaining [a] = case valueAdd remaining a of
184+
Just newChange -> [newChange]
185+
Nothing -> [a, remaining]
186+
go remaining ls@(a : as) =
187+
let piece = valueDiv remaining (length ls)
188+
newRemaining = unsafeValueSub remaining piece -- unsafe because of div.
189+
in case valueAdd piece a of
190+
Just newChange -> newChange : go newRemaining as
191+
Nothing -> a : go remaining as
192+
139193

140194
-- | Reduce the given change outputs by the total fee, returning the remainig
141195
-- change outputs if any are left, or the remaining fee otherwise
@@ -167,13 +221,19 @@ reduceChangeOutputs totalFee cs =
167221
Auxiliary
168222
-------------------------------------------------------------------------------}
169223

170-
feeUpperBound :: CoinSelDom dom
171-
=> FeeOptions dom -> [CoinSelResult dom] -> Fee dom
172-
feeUpperBound FeeOptions{..} css =
224+
feeUpperBound
225+
:: forall dom. (CoinSelDom dom)
226+
=> FeeOptions dom
227+
-> [UtxoEntry dom]
228+
-> [Output dom]
229+
-> [Value dom]
230+
-> Fee dom
231+
feeUpperBound FeeOptions{..} inps outs chgs =
173232
foEstimate numInputs outputs
174233
where
175-
numInputs = fromIntegral $ sum (map (sizeToWord . coinSelInputSize) css)
176-
outputs = concatMap coinSelOutputs css
234+
numInputs = fromIntegral $ sizeToWord $ selectedSize $ foldr' select emptySelection inps
235+
outputs = map outVal outs <> chgs
236+
177237

178238
-- | divvy fee across outputs, discarding zero-output if any. Returns `Nothing`
179239
-- when there's no more outputs after filtering, in which case, we just can't

‎wallet-new/test/unit/InputSelection/FromGeneric.hs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -46,6 +46,7 @@ instance IsValue (SafeValue h a) where
4646
valueDist = safeDist
4747
valueRatio = safeRatio
4848
valueAdjust = safeAdjust
49+
valueDiv = safeDiv
4950

5051
instance (DSL.Hash h a, Buildable a) => CoinSelDom (DSL h a) where
5152
type Input (DSL h a) = DSL.Input h a
@@ -109,6 +110,10 @@ safeRatio :: SafeValue h a -> SafeValue h a -> Double
109110
safeRatio (Value x) (Value y) =
110111
fromIntegral x / fromIntegral y
111112

113+
safeDiv :: SafeValue h a -> Int -> SafeValue h a
114+
safeDiv (Value x) k =
115+
Value (x `div` fromIntegral k)
116+
112117
-- TODO: check for underflow/overflow
113118
safeAdjust :: Rounding -> Double -> SafeValue h a -> Maybe (SafeValue h a)
114119
safeAdjust RoundUp d (Value x) = Just $ Value $ ceiling (d * fromIntegral x)

0 commit comments

Comments
 (0)