out of paranoia, add an invariant to make transactions never leave fe…

…es beyond a certain amount.

  This should _not_ be the case, but the contrary would be disastrous for the user. I was getting a little paranoid about this recently,
  so I think having the wallet crash loudly in such case is a good and sane idea.

lib/core/src/Cardano/Wallet.hs

@@ -1191,14 +1191,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
@@ -1268,7 +1275,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
@@ -1306,7 +1313,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
@@ -1385,10 +1392,15 @@ selectCoinsForMigrationFromUTxO
         , Quantity "lovelace" Natural
         )
 selectCoinsForMigrationFromUTxO ctx utxo txp minUtxo wid = do
-    let feePolicy@(LinearFee (Quantity a) _ _) = txp ^. #getFeePolicy
+    let (Quantity txMaxSz) = W.getTxMaxSize txp
+    let feePolicy@(LinearFee (Quantity a) (Quantity b) _) = txp ^. #getFeePolicy
     let feeOptions = FeeOptions
             { estimateFee = minimumFee tl feePolicy Nothing . worstCase
             , dustThreshold = max (Coin $ ceiling a) minUtxo
+            , feeUpperBound = Fee
+                $ ceiling a
+                + ceiling b * fromIntegral txMaxSz
+                + getCoin minUtxo
             , onDanglingChange = if allowUnbalancedTx tl
                 then SaveMoney
                 else PayAndBalance

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,13 @@ 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 invariant after balancing a transaction to make sure
+      -- that our algorithm isn't flawed and does not generate a transaction
+      -- that would inadvertendly leave too much fees.
     } deriving (Generic)
 
 -- | We call 'dangling' a change output that would be too expensive to add. This
@@ -140,15 +170,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 excessively large fees."
+            , 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)