Review Fee Sanity Check

src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs

@@ -18,7 +18,6 @@ module Cardano.Wallet.Kernel.CoinSelection.FromGeneric (
   , largestFirst
     -- * Estimating fees
   , estimateCardanoFee
-  , checkCardanoFeeSanity
   , boundAddrAttrSize
   , boundTxAttrSize
     -- * Estimating transaction limits
@@ -44,7 +43,7 @@ import           Pos.Chain.Txp as Core (TxIn, TxOutAux, Utxo, toaOut,
 import           Pos.Core as Core (AddrAttributes, Address, Coin (..),
                      TxSizeLinear, addCoin, calculateTxSizeLinear, checkCoin,
                      divCoin, isRedeemAddress, maxCoinVal, mkCoin, subCoin,
-                     txSizeLinearMinValue, unsafeMulCoin, unsafeSubCoin)
+                     unsafeSubCoin)
 
 import           Pos.Core.Attributes (Attributes)
 import           Pos.Crypto (Signature)
@@ -147,8 +146,6 @@ data InputGrouping =
 data CoinSelectionOptions = CoinSelectionOptions {
       csoEstimateFee       :: Int -> NonEmpty Core.Coin -> Core.Coin
     -- ^ A function to estimate the fees.
-    , csoFeesSanityCheck   :: Core.Coin -> Bool
-    -- ^ A function we can use to check if fees are not too big or too small.
     , csoInputGrouping     :: InputGrouping
     -- ^ A preference regarding input grouping.
     , csoExpenseRegulation :: ExpenseRegulation
@@ -162,10 +159,9 @@ data CoinSelectionOptions = CoinSelectionOptions {
 -- | Creates new 'CoinSelectionOptions' using 'NoGrouping' as default
 -- 'InputGrouping' and 'SenderPaysFee' as default 'ExpenseRegulation'.
 newOptions :: (Int -> NonEmpty Core.Coin -> Core.Coin)
-           -> (Core.Coin -> Bool) -> CoinSelectionOptions
-newOptions estimateFee check = CoinSelectionOptions {
+           -> CoinSelectionOptions
+newOptions estimateFee = CoinSelectionOptions {
       csoEstimateFee       = estimateFee
-    , csoFeesSanityCheck   = check
     , csoInputGrouping     = IgnoreGrouping
     , csoExpenseRegulation = SenderPaysFee
     , csoDustThreshold     = Core.mkCoin 0
@@ -396,15 +392,6 @@ estimateCardanoFee linearFeePolicy ins outs
     = ceiling $ calculateTxSizeLinear linearFeePolicy
               $ hi $ estimateSize boundAddrAttrSize boundTxAttrSize ins outs
 
-checkCardanoFeeSanity :: TxSizeLinear -> Coin -> Bool
-checkCardanoFeeSanity linearFeePolicy fees =
-    let
-        maxCoeff :: Int = 2
-        minFees = Core.mkCoin $ floor $ txSizeLinearMinValue linearFeePolicy
-    in
-        (fees >= minFees) && (fees <= Core.unsafeMulCoin minFees maxCoeff)
-
-
 -- | Size to use for a value of type @Attributes AddrAttributes@ when estimating
 --   encoded transaction sizes. The minimum possible value is 2.
 --

src/Cardano/Wallet/Kernel/CoinSelection/Generic.hs

@@ -12,6 +12,7 @@ module Cardano.Wallet.Kernel.CoinSelection.Generic (
   , Rounding(..)
   , Fee(..)
   , adjustFee
+  , valueSum
   , unsafeFeeSum
   , utxoEntryVal
   , sizeOfEntries
@@ -156,6 +157,9 @@ newtype Fee dom = Fee { getFee :: Value dom }
 adjustFee :: (Value dom -> Value dom) -> Fee dom -> Fee dom
 adjustFee f = Fee . f . getFee
 
+valueSum :: CoinSelDom dom => [Value dom] -> Maybe (Value dom)
+valueSum = foldM valueAdd valueZero
+
 unsafeFeeSum :: CoinSelDom dom => [Fee dom] -> Fee dom
 unsafeFeeSum = Fee . unsafeValueSum . map getFee
 

src/Cardano/Wallet/Kernel/CoinSelection/Generic/Fees.hs

@@ -97,15 +97,33 @@ adjustForFees feeOptions pickUtxo css = do
           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'
+    let estimatedFee = getFee $ feeUpperBound feeOptions inps outs chgs
+    let actualFee = getFee $ computeFee inps' outs' chgs'
+    -- NOTE
+    -- We enforce the following invariant:
+    --
+    --   estimatedFee < actualFee < 2 * estimatedFee
+    --
+    -- This coefficient (2*...) is mostly taken out of nowhere, but if anything
+    -- go beyond that upper bound, we would know that our algorithm for fee
+    -- reconciliation below is messed up.
+    -- Similarly, the algorithm tries to take money from inputs until it reaches
+    -- the goal fixed by 'estimatedFee'. So, the actualFee just can't be lower
+    -- than the goal.
+    --
+    -- (PS: using `valueDiv` instead of `valueMul` to avoid overflow)
+    if (actualFee < estimatedFee || actualFee `valueDiv` 2 > estimatedFee) then
+        error $ "adjustForFees: fee out of bounds: " <> pretty actualFee <> " while expecting ~" <> pretty estimatedFee
+    else do
+        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'
 
 
 {-------------------------------------------------------------------------------
@@ -287,6 +305,47 @@ feeUpperBound FeeOptions{..} inps outs chgs =
     numInputs = fromIntegral $ sizeToWord $ selectedSize $ foldl' (flip select) emptySelection inps
     outputs = map outVal outs <> chgs
 
+-- Computing actual fee is a bit tricky in the generic realm because we don't
+-- know what type representation is used by the underlying implementation. So,
+-- we can't just sum up all the input and substract the sub of all outputs
+-- (incl. change) because we'll risk an overflow with each sum. Instead, we
+-- reduce the input value iteratively, coin by coin using a safe distance
+-- between coins that are known to be within bounds.
+-- The algorithm converge because we know that by construction, there are less
+-- outputs than inputs. In essence, this computes:
+--
+--     fees = ∑ inputs - (∑ outputs + ∑ changes)
+computeFee
+    :: forall dom. (CoinSelDom dom)
+    => [UtxoEntry dom]
+    -> [Output dom]
+    -> [Value dom]
+    -> Fee dom
+computeFee inps outs chgs =
+    Fee $ collapse (map utxoEntryVal inps) (map outVal outs <> chgs)
+  where
+    -- Some remaining inputs together. At this point, we've removed
+    -- all outputs and changes, so what's left are simply the actual fees.
+    -- It's unrealistic to imagine them being bigger than the max coin value.
+    collapse plus [] = case valueSum plus of
+        Nothing -> error "fees are bigger than max coin value"
+        Just a  -> a
+
+    -- In order to safely compute fees at this level, we need make sure we don't
+    -- overflow. Therefore, we remove outputs to inputs until there's no outputs
+    -- left to remove.
+    collapse (p:ps) (m:ms)
+        | p > m     = let p' = valueDist p m in collapse (p':ps) ms
+        | p < m     = let m' = valueDist p m in collapse ps (m':ms)
+        | otherwise = collapse ps ms
+
+    -- This branch can only happens if we've depleted all our inputs and there
+    -- are still some outputs left to remove from them. If means the total value
+    -- of outputs (incl. change) was bigger than the total input value which is
+    -- by definition, impossible; unless we messed up real hard.
+    collapse []  _   =
+        error "invariant violation: outputs are bigger than inputs"
+
 
 -- | 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

src/Cardano/Wallet/Kernel/Transactions.hs

@@ -11,7 +11,6 @@ module Cardano.Wallet.Kernel.Transactions (
     , EstimateFeesError(..)
     , RedeemAdaError(..)
     , cardanoFee
-    , cardanoFeeSanity
     , mkStdTx
     , prepareUnsignedTxWithSources
     , submitSignedTx
@@ -44,8 +43,7 @@ import           Cardano.Crypto.Wallet (DerivationIndex)
 import qualified Cardano.Wallet.Kernel.Addresses as Kernel
 import           Cardano.Wallet.Kernel.CoinSelection.FromGeneric
                      (CoinSelFinalResult (..), CoinSelectionOptions (..),
-                     checkCardanoFeeSanity, estimateCardanoFee,
-                     estimateMaxTxInputs)
+                     estimateCardanoFee, estimateMaxTxInputs)
 import qualified Cardano.Wallet.Kernel.CoinSelection.FromGeneric as CoinSelection
 import           Cardano.Wallet.Kernel.CoinSelection.Generic
                      (CoinSelHardErr (..))
@@ -230,13 +228,8 @@ newUnsignedTransaction ActiveWallet{..} options accountId payees = runExceptT $
     -- that it may change in the future.
     let attributes = def :: TxAttributes
     let tx = UnsignedTx inputs outputs attributes coins
-
-    -- STEP 3: Sanity test. Here we check whether our fees are within a reasonable
-    -- range.
     let fees = computeFeesOfUnsignedTx tx
-    if csoFeesSanityCheck options fees
-    then return (snapshot, tx, fees, availableUtxo)
-    else error $ "fees out of bound " <> show fees
+    return (snapshot, tx, fees, availableUtxo)
   where
     -- Generate an initial seed for the random generator using the hash of
     -- the payees, which ensure that the coin selection (and the fee estimation)
@@ -640,12 +633,6 @@ cardanoFee (TxFeePolicyTxSizeLinear policy) inputs outputs =
 cardanoFee TxFeePolicyUnknown{} _ _ =
     error "cardanoFee: unknown policy"
 
-cardanoFeeSanity :: TxFeePolicy -> Coin -> Bool
-cardanoFeeSanity (TxFeePolicyTxSizeLinear policy) fees =
-    checkCardanoFeeSanity policy fees
-cardanoFeeSanity TxFeePolicyUnknown{} _ =
-    error "cardanoFeeSanity: unknown policy"
-
 {-------------------------------------------------------------------------------
   Ada redemption
 

src/Cardano/Wallet/WalletLayer/Kernel/Active.hs

@@ -222,7 +222,7 @@ setupPayment :: Monad m
                                )
 setupPayment policy grouping regulation payment = do
     rootId <- fromRootId wId
-    let opts   = (newOptions (Kernel.cardanoFee policy) (Kernel.cardanoFeeSanity policy)) {
+    let opts   = (newOptions (Kernel.cardanoFee policy)) {
                      csoExpenseRegulation = regulation
                    , csoInputGrouping     = grouping
                    }