Fix underflow in fee estimation in the presence of withdrawal and max amount

lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Transactions.hs

@@ -102,6 +102,7 @@ import Test.Integration.Framework.DSL
     , utcIso8601ToText
     , verify
     , walletId
+    , (.<=)
     , (.>)
     , (.>=)
     )
@@ -555,14 +556,35 @@ spec = do
                 (Link.getTransactionFee @'Shelley w) Default payload
             expectResponseCode @IO HTTP.status400 r
 
-    it "TRANS_ESTIMATE_03 - we see result when we can't cover fee" $ \ctx -> do
+    it "TRANS_ESTIMATE_03a - we see result when we can't cover fee" $ \ctx -> do
         wSrc <- fixtureWallet ctx
         payload <- mkTxPayload ctx wSrc faucetAmt fixturePassphrase
         r <- request @ApiFee ctx
             (Link.getTransactionFee @'Shelley wSrc) Default payload
         verify r
             [ expectResponseCode HTTP.status202
             , expectField (#estimatedMin . #getQuantity) (.>= 0)
+            , expectField (#estimatedMax . #getQuantity) (.<= oneAda)
+            ]
+
+    it "TRANS_ESTIMATE_03b - we see result when we can't cover fee (with withdrawal)" $ \ctx -> do
+        (wSrc, _) <- rewardWallet ctx
+        addr:_ <- fmap (view #id) <$> listAddresses @n ctx wSrc
+        let totalBalance = wSrc ^. #balance . #getApiT . #total
+        let payload = Json [json|{
+                "withdrawal": "self",
+                "payments": [{
+                    "address": #{addr},
+                    "amount": #{totalBalance}
+                }],
+                "passphrase": #{fixturePassphrase}
+            }|]
+        r <- request @ApiFee ctx
+            (Link.getTransactionFee @'Shelley wSrc) Default payload
+        verify r
+            [ expectResponseCode HTTP.status202
+            , expectField (#estimatedMin . #getQuantity) (.>= 0)
+            , expectField (#estimatedMax . #getQuantity) (.<= oneAda)
             ]
 
     it "TRANS_ESTIMATE_04 - Not enough money" $ \ctx -> do

lib/core/src/Cardano/Wallet.hs

@@ -1192,14 +1192,21 @@ coinSelOpts tl txMaxSize = CoinSelectionOptions
 feeOpts
     :: TransactionLayer t k
     -> Maybe DelegationAction
-    -> FeePolicy
+    -> W.TxParameters
     -> W.Coin
     -> FeeOptions
-feeOpts tl action feePolicy minUtxo = FeeOptions
+feeOpts tl action txp minUtxo = FeeOptions
     { estimateFee = minimumFee tl feePolicy action
     , dustThreshold = minUtxo
     , onDanglingChange = if allowUnbalancedTx tl then SaveMoney else PayAndBalance
+    , feeUpperBound = Fee
+        $ ceiling a
+        + ceiling b * fromIntegral txMaxSize
+        + getCoin minUtxo
     }
+  where
+    feePolicy@(LinearFee (Quantity a) (Quantity b) _) = W.getFeePolicy txp
+    Quantity txMaxSize = W.getTxMaxSize txp
 
 -- | Prepare a transaction and automatically select inputs from the
 -- wallet to cover the requested outputs. Note that this only runs
@@ -1269,7 +1276,7 @@ selectCoinsForPaymentFromUTxO ctx utxo txp minUtxo recipients withdrawal = do
         let opts = coinSelOpts tl (txp ^. #getTxMaxSize)
         CoinSelection.random opts recipients withdrawal utxo
     lift . traceWith tr $ MsgPaymentCoinSelection sel
-    let feePolicy = feeOpts tl Nothing (txp ^. #getFeePolicy) minUtxo
+    let feePolicy = feeOpts tl Nothing txp minUtxo
     withExceptT ErrSelectForPaymentFee $ do
         balancedSel <- adjustForFee feePolicy utxo' sel
         lift . traceWith tr $ MsgPaymentCoinSelectionAdjusted balancedSel
@@ -1307,7 +1314,7 @@ selectCoinsForDelegationFromUTxO
     -> DelegationAction
     -> ExceptT ErrSelectForDelegation IO CoinSelection
 selectCoinsForDelegationFromUTxO ctx utxo txp minUtxo action = do
-    let feePolicy = feeOpts tl (Just action) (txp ^. #getFeePolicy) minUtxo
+    let feePolicy = feeOpts tl (Just action) txp minUtxo
     let sel = initDelegationSelection tl (txp ^. #getFeePolicy) action
     withExceptT ErrSelectForDelegationFee $ do
         balancedSel <- adjustForFee feePolicy utxo sel
@@ -1387,12 +1394,9 @@ selectCoinsForMigrationFromUTxO
         )
 selectCoinsForMigrationFromUTxO ctx utxo txp minUtxo wid = do
     let feePolicy@(LinearFee (Quantity a) _ _) = txp ^. #getFeePolicy
-    let feeOptions = FeeOptions
+    let feeOptions = (feeOpts tl Nothing txp minBound)
             { estimateFee = minimumFee tl feePolicy Nothing . worstCase
             , dustThreshold = max (Coin $ ceiling a) minUtxo
-            , onDanglingChange = if allowUnbalancedTx tl
-                then SaveMoney
-                else PayAndBalance
             }
     let selOptions = coinSelOpts tl (txp ^. #getTxMaxSize)
     let previousDistribution = W.computeUtxoStatistics W.log10 utxo
@@ -1460,7 +1464,7 @@ estimateFeeForPayment ctx wid recipients withdrawal = do
         guardCoinSelection minUtxo cs
 
     estimateFeeForCoinSelection $ (Fee . feeBalance <$> selectCoins)
-        `catchE` handleCannotCover utxo recipients
+        `catchE` handleCannotCover utxo withdrawal recipients
 
 -- | When estimating fee, it is rather cumbersome to return "cannot cover fee"
 -- whereas clients are just asking for an estimation. Therefore, we convert
@@ -1469,13 +1473,19 @@ estimateFeeForPayment ctx wid recipients withdrawal = do
 handleCannotCover
     :: Monad m
     => UTxO
+    -> Quantity "lovelace" Word64
     -> NonEmpty TxOut
     -> ErrSelectForPayment e
     -> ExceptT (ErrSelectForPayment e) m Fee
-handleCannotCover utxo outs = \case
+handleCannotCover utxo (Quantity withdrawal) outs = \case
     ErrSelectForPaymentFee (ErrCannotCoverFee missing) -> do
-        let available = fromIntegral (W.balance utxo) - sum (getCoin . coin <$> outs)
-        pure $ Fee $ available + missing
+        let available
+                = fromIntegral (W.balance utxo)
+                + fromIntegral withdrawal
+        let payment
+                = sum (getCoin . coin <$> outs)
+        pure $ Fee $
+            available + missing - payment
     e ->
         throwE e
 

lib/core/src/Cardano/Wallet/Primitive/Fee.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -36,7 +37,12 @@ module Cardano.Wallet.Primitive.Fee
 import Prelude
 
 import Cardano.Wallet.Primitive.CoinSelection
-    ( CoinSelection (..), changeBalance, inputBalance, outputBalance )
+    ( CoinSelection (..)
+    , changeBalance
+    , feeBalance
+    , inputBalance
+    , outputBalance
+    )
 import Cardano.Wallet.Primitive.Types
     ( Coin (..)
     , FeePolicy (..)
@@ -48,6 +54,8 @@ import Cardano.Wallet.Primitive.Types
     , isValidCoin
     , pickRandom
     )
+import Control.Monad
+    ( when )
 import Control.Monad.Trans.Class
     ( lift )
 import Control.Monad.Trans.Except
@@ -58,8 +66,12 @@ import Crypto.Random.Types
     ( MonadRandom )
 import Data.Word
     ( Word64 )
+import Fmt
+    ( Buildable (..), fixedF, nameF, pretty, unlinesF, (+|) )
 import GHC.Generics
     ( Generic )
+import GHC.Stack
+    ( HasCallStack )
 
 import qualified Data.List as L
 
@@ -71,6 +83,16 @@ import qualified Data.List as L
 newtype Fee = Fee { getFee :: Word64 }
     deriving (Eq, Ord, Show)
 
+instance Buildable Fee where
+    build (Fee fee)
+        | fee > oneAda = fixedF 3 (double fee / double oneAda) +| " Ada"
+        | otherwise    = build fee +| " Lovelace"
+      where
+        oneAda = 1_000_000
+
+        double :: Integral a => a -> Double
+        double = fromIntegral
+
 {-------------------------------------------------------------------------------
                                 Fee Adjustment
 -------------------------------------------------------------------------------}
@@ -82,6 +104,7 @@ data FeeOptions = FeeOptions
       -- Some pointers / order of magnitude from the current configuration:
       --     a: 155381 # absolute minimal fees per transaction
       --     b: 43.946 # additional minimal fees per byte of transaction size
+
     , dustThreshold
       :: Coin
       -- ^ Change addresses below the given threshold will be evicted
@@ -92,6 +115,12 @@ data FeeOptions = FeeOptions
       :: OnDanglingChange
       -- ^ What do to when we encouter a dangling change output.
       -- See 'OnDanglingChange'
+
+    , feeUpperBound
+      :: Fee
+      -- ^ An extra upper-bound computed from the transaction max size. This is
+      -- used to construct an invariant after balancing a transaction to
+      -- make sure that the resultant fee is not unexpectedly high.
     } deriving (Generic)
 
 -- | We call 'dangling' a change output that would be too expensive to add. This
@@ -140,15 +169,22 @@ newtype ErrAdjustForFee
 -- percentage of the fee (depending on how many change outputs the
 -- algorithm happened to choose).
 adjustForFee
-    :: MonadRandom m
+    :: (HasCallStack, MonadRandom m)
     => FeeOptions
     -> UTxO
     -> CoinSelection
     -> ExceptT ErrAdjustForFee m CoinSelection
 adjustForFee unsafeOpt utxo coinSel = do
-    let opt = invariant
-            "adjustForFee: fee must be non-null" unsafeOpt (not . nullFee)
-    senderPaysFee opt utxo coinSel
+    let opt = invariant "fee must be non-null" unsafeOpt (not . nullFee)
+    cs <- senderPaysFee opt utxo coinSel
+    let actualFee = Fee (feeBalance cs)
+    when (actualFee > feeUpperBound opt) $
+        error $ pretty $ unlinesF
+            [ "generated a coin selection with an excessively large fee."
+            , nameF "actual fee" (build actualFee)
+            , nameF "coin selection" (build cs)
+            ]
+    pure cs
   where
     nullFee opt = estimateFee opt coinSel == Fee 0
 

lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/MigrationSpec.hs

@@ -122,6 +122,7 @@ spec = do
                         $ fromIntegral
                         $ 5 * (length (inputs s) + length (outputs s))
                     , onDanglingChange = PayAndBalance
+                    , feeUpperBound = Fee maxBound
                     }
             let batchSize = 1
             let utxo = UTxO $ Map.fromList
@@ -243,6 +244,7 @@ genFeeOptions (Coin dust) = do
             in Fee $ (dust `div` 100) * x + dust
         , dustThreshold = Coin dust
         , onDanglingChange = PayAndBalance
+        , feeUpperBound = Fee maxBound
         }
 
 -- | Generate a given UTxO with a particular percentage of dust

lib/core/test/unit/Cardano/Wallet/Primitive/FeeSpec.hs

@@ -598,6 +598,7 @@ prop_rebalanceSelection sel onDangling threshold = do
 
         , dustThreshold = threshold'
         , onDanglingChange = onDangling
+        , feeUpperBound = Fee maxBound
         }
 
     reserveNonNull =
@@ -622,6 +623,8 @@ feeOptions fee dust = FeeOptions
         Coin dust
     , onDanglingChange =
         PayAndBalance
+    , feeUpperBound =
+        Fee maxBound
     }
 
 feeUnitTest
@@ -847,7 +850,8 @@ instance Arbitrary FeeOptions where
                     $ c + a * (length (inputs s) + length (outputs s))
             , dustThreshold = Coin t
             , onDanglingChange = PayAndBalance
+            , feeUpperBound = Fee maxBound
             }
 
 instance Show FeeOptions where
-    show (FeeOptions _ dust onDangling) = show (dust, onDangling)
+    show (FeeOptions _ dust onDangling maxFee) = show (dust, onDangling, maxFee)

lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs

@@ -45,6 +45,7 @@ import Cardano.Wallet.Primitive.Types
     , TxIn (..)
     , TxMetadata (..)
     , TxOut (..)
+    , TxParameters (..)
     , UTxO (..)
     )
 import Cardano.Wallet.Shelley.Compatibility
@@ -149,9 +150,11 @@ spec = do
                 [ TxOut dummyAddress (Coin 4834720)
                 ]
 
-        let selectCoins = flip catchE (handleCannotCover utxo recipients) $ do
+        let wdrl = Quantity 0
+
+        let selectCoins = flip catchE (handleCannotCover utxo wdrl recipients) $ do
                 (sel, utxo') <- withExceptT ErrSelectForPaymentCoinSelection $ do
-                    CS.random testCoinSelOpts recipients (Quantity 0) utxo
+                    CS.random testCoinSelOpts recipients wdrl utxo
                 withExceptT ErrSelectForPaymentFee $
                     (Fee . CS.feeBalance) <$> adjustForFee testFeeOpts utxo' sel
         res <- runExceptT $ estimateFeeForCoinSelection selectCoins
@@ -246,9 +249,11 @@ testCoinSelOpts :: CoinSelectionOptions ()
 testCoinSelOpts = coinSelOpts testTxLayer (Quantity 4096)
 
 testFeeOpts :: FeeOptions
-testFeeOpts = feeOpts testTxLayer Nothing feePolicy (Coin 0)
+testFeeOpts = feeOpts testTxLayer Nothing txParams (Coin 0)
   where
+    txParams  = TxParameters feePolicy txMaxSize
     feePolicy = LinearFee (Quantity 155381) (Quantity 44) (Quantity 0)
+    txMaxSize = Quantity maxBound
 
 testTxLayer :: TransactionLayer (IO Shelley) ShelleyKey
 testTxLayer = newTransactionLayer @ShelleyKey Cardano.Mainnet