[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.

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
@@ -234,43 +235,16 @@ 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
+    return $ case mSelection of
+      Left err                      -> Left err
+      Right ((inps, outs, chgs), _) -> Right $ CoinSelFinalResult inps outs chgs
   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
+            ( NonEmpty (UtxoEntry Cardano)
+            , NonEmpty (Output Cardano)
+            , [Value Cardano]
+            )
     policy' = do
         mapM_ validateOutput request
         css <- intInputGrouping (csoInputGrouping opts)

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

@@ -91,6 +91,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)

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

@@ -35,42 +35,68 @@ data FeeOptions dom = FeeOptions {
     , foExpenseRegulation :: ExpenseRegulation
     }
 
+
+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 (NonEmpty (UtxoEntry (Dom utxo)), NonEmpty (Output (Dom utxo)), [Value (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
+    (inps, outs, chgs) <-
+        case foExpenseRegulation feeOptions of
+          ReceiverPaysFee ->
+            coinSelLiftExcept $ receiverPaysFee feeOptions css
+
+          SenderPaysFee ->
+            senderPaysFee pickUtxo feeOptions css
+
+
+    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 (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
+    -> [CoinSelResult dom]
+    -> Except CoinSelHardErr ([UtxoEntry dom], [Output dom], [Value dom])
+receiverPaysFee feeOptions css =
+    let
+        inps = concatMap selectedEntries $ map coinSelInputs css
+        outs = map coinSelOutput css
+        chgs = concatMap coinSelChange css
+        totalFee = feeUpperBound feeOptions inps outs chgs
+    in do
+        outs' <- mapM go . divvyFee (outVal . coinSelRequest) totalFee $ css
+        return (inps, outs', chgs)
   where
-    go :: (Fee dom, CoinSelResult dom)
-       -> Except CoinSelHardErr (CoinSelResult dom)
+    go
+        :: (Fee dom, CoinSelResult dom)
+        -> Except CoinSelHardErr (Output dom)
     go (fee, cs) =
         case outSubFee fee (coinSelRequest cs) of
           Just newOut ->
-            return $ cs { coinSelOutput = newOut }
+            return newOut
           Nothing ->
             throwError $
               CoinSelHardErrOutputCannotCoverFee (pretty (coinSelRequest cs)) (pretty fee)
@@ -79,63 +105,91 @@ receiverPaysFee totalFee =
   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)
+    -> [CoinSelResult (Dom utxo)]
+    -> CoinSelT utxo CoinSelHardErr m ([UtxoEntry (Dom utxo)], [Output (Dom utxo)], [Value (Dom utxo)])
+senderPaysFee pickUtxo feeOptions css = do
+    let inps = concatMap selectedEntries $ map coinSelInputs css
+    let outs = map coinSelOutput css
+    let chgs = concatMap coinSelChange css
+    go inps outs chgs
+  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 extraChange = unsafeValueSub (selectedBalance extraUtxo) (getFee remainingFee)
+            let inps' = selectedEntries 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 +221,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

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)