[CSL-2526] update changes after covering remaining fees

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

@@ -42,7 +42,7 @@ import           Pos.Chain.Txp as Core (TxIn, TxOutAux, Utxo, toaOut,
                      txOutAddress, txOutValue)
 import           Pos.Core as Core (AddrAttributes, Address, Coin (..),
                      TxSizeLinear, addCoin, calculateTxSizeLinear, checkCoin,
-                     isRedeemAddress, maxCoinVal, mkCoin, subCoin,
+                     divCoin, isRedeemAddress, maxCoinVal, mkCoin, subCoin,
                      unsafeSubCoin)
 
 import           Pos.Core.Attributes (Attributes)
@@ -232,23 +232,40 @@ runCoinSelT opts pickUtxo policy (NE.sortBy (flip (comparing outVal)) -> request
     mSelection <- unwrapCoinSelT policy' utxo
     case mSelection of
       Left err -> return (Left err)
-      Right ((cssWithDust, additionalUtxo), _utxo') -> do
-        let css  = map (coinSelRemoveDust (csoDustThreshold opts)) cssWithDust
-            inps = concatMap selectedEntries
+      Right ((css, additionalUtxo, additionalChanges), _utxo') -> do
+        let inps = concatMap selectedEntries
                      (additionalUtxo : map coinSelInputs css)
             outs = map coinSelOutput css
+            changesWithDust = splitChange additionalChanges $ 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
-                                            (concatMap coinSelChange css)
+                                            changes
   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.
+          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)
+                 ([CoinSelResult Cardano], SelectedUtxo Cardano, Value Cardano)
     policy' = do
         mapM_ validateOutput request
         css <- intInputGrouping (csoInputGrouping opts)

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

@@ -44,6 +44,7 @@ module Cardano.Wallet.Kernel.CoinSelection.Generic (
   , coinSelOutputs
   , coinSelRemoveDust
   , coinSelPerGoal
+  , changesRemoveDust
     -- * Generalization over UTxO representations
   , StandardUtxo
   , PickFromUtxo(..)
@@ -384,9 +385,13 @@ coinSelOutputs cs = outVal (coinSelOutput cs) : coinSelChange cs
 coinSelRemoveDust :: CoinSelDom dom
                   => Value dom -> CoinSelResult dom -> CoinSelResult dom
 coinSelRemoveDust dust cs = cs {
-      coinSelChange = filter (> dust) (coinSelChange cs)
+      coinSelChange = changesRemoveDust dust (coinSelChange cs)
     }
 
+changesRemoveDust :: CoinSelDom dom
+                  => Value dom -> [Value dom] -> [Value dom]
+changesRemoveDust dust = filter (> dust)
+
 -- | Do coin selection per goal
 --
 -- Coin selection per goal simplifies the algorithm, but is not without loss

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

@@ -44,11 +44,11 @@ adjustForFees :: forall utxo m. (CoinSelDom (Dom utxo), Monad m)
                    CoinSelT utxo CoinSelHardErr m (Maybe (UtxoEntry (Dom utxo))))
               -> [CoinSelResult (Dom utxo)]
               -> CoinSelT utxo CoinSelHardErr m
-                   ([CoinSelResult (Dom utxo)], SelectedUtxo (Dom utxo))
+                   ([CoinSelResult (Dom utxo)], SelectedUtxo (Dom utxo), Value (Dom utxo))
 adjustForFees feeOptions pickUtxo css = do
     case foExpenseRegulation feeOptions of
       ReceiverPaysFee -> coinSelLiftExcept $
-        (, emptySelection) <$> receiverPaysFee upperBound css
+        (, emptySelection, valueZero) <$> receiverPaysFee upperBound css
       SenderPaysFee ->
         senderPaysFee pickUtxo upperBound css
   where
@@ -85,21 +85,23 @@ senderPaysFee :: (Monad m, CoinSelDom (Dom utxo))
               -> Fee (Dom utxo)
               -> [CoinSelResult (Dom utxo)]
               -> CoinSelT utxo CoinSelHardErr m
-                   ([CoinSelResult (Dom utxo)], SelectedUtxo (Dom utxo))
+                   ([CoinSelResult (Dom utxo)], SelectedUtxo (Dom utxo), Value (Dom utxo))
 senderPaysFee pickUtxo totalFee css = do
     let (css', remainingFee) = feeFromChange totalFee css
-    (css', ) <$> coverRemainingFee pickUtxo remainingFee
+    (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))
+                  -> CoinSelT utxo CoinSelHardErr m (SelectedUtxo (Dom utxo), Value (Dom utxo))
 coverRemainingFee pickUtxo fee = go emptySelection
   where
     go :: SelectedUtxo (Dom utxo)
-       -> CoinSelT utxo CoinSelHardErr m (SelectedUtxo (Dom utxo))
+       -> CoinSelT utxo CoinSelHardErr m (SelectedUtxo (Dom utxo), Value (Dom utxo))
     go !acc
-      | selectedBalance acc >= getFee fee = return acc
+      | selectedBalance acc >= getFee fee =
+          return (acc, unsafeValueSub (selectedBalance acc) (getFee fee))
       | otherwise = do
           mio <- (pickUtxo $ unsafeValueSub (getFee fee) (selectedBalance acc))
           io  <- maybe (throwError CoinSelHardErrCannotCoverFee) return mio

wallet-new/src/Cardano/Wallet/Kernel/Transactions.hs

@@ -199,7 +199,7 @@ newUnsignedTransaction
     -- ^ The source HD account from where the payment should originate
     -> NonEmpty (Address, Coin)
     -- ^ The payees
-    -> IO (Either NewTransactionError (DB, UnsignedTx, Utxo))
+    -> IO (Either NewTransactionError (DB, UnsignedTx, Coin, Utxo))
     -- ^ Returns the state of the world (i.e. the DB snapshot)
     -- at the time of the coin selection, so that it can later
     -- on be used to sign the addresses.
@@ -229,7 +229,12 @@ newUnsignedTransaction ActiveWallet{..} options accountId payees = runExceptT $
     -- that it may change in the future.
     let attributes = def :: TxAttributes
     let tx = UnsignedTx inputs outputs attributes coins
-    return (snapshot, tx, availableUtxo)
+
+    -- STEP 3: sanity test.
+    let fees = computeFeesOfUnsignedTx tx
+    if isSane options fees
+    then return (snapshot, tx, fees, availableUtxo)
+    else throwError $ NewTransactionErrorCoinSelectionFailed CoinSelHardErrCannotCoverFee
   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)
@@ -266,7 +271,7 @@ prepareUnsignedTxWithSources
              (Tx, NonEmpty (Address, [DerivationIndex]))
           )
 prepareUnsignedTxWithSources activeWallet opts srcAccountId payees spendingPassword = runExceptT $ do
-    (db, unsignedTx, _availableUtxo) <- ExceptT $
+    (db, unsignedTx, _fees, _availableUtxo) <- ExceptT $
         newUnsignedTransaction activeWallet opts srcAccountId payees
 
     -- Now we have to generate the change addresses needed,
@@ -405,8 +410,7 @@ newTransaction aw@ActiveWallet{..} spendingPassword options accountId payees = d
     tx <- newUnsignedTransaction aw options accountId payees
     case tx of
          Left e   -> return (Left e)
-         Right (db, unsignedTx, availableUtxo) -> runExceptT $ do
-
+         Right (db, unsignedTx, _fees, availableUtxo) -> runExceptT $ do
              -- STEP 1: Perform the signing and forge the final TxAux.
              mbEsk <- liftIO $ Keystore.lookup
                         nm
@@ -531,36 +535,42 @@ estimateFees activeWallet@ActiveWallet{..} options accountId payees = do
     res <- newUnsignedTransaction activeWallet options accountId payees
     case res of
          Left e  -> return . Left . EstFeesTxCreationFailed $ e
-         Right (_db, tx, _originalUtxo) -> do
-             let change = unsignedTxChange tx
-             -- calculate the fee as the difference between inputs and outputs. The
-             -- final 'sumOfOutputs' must be augmented by the change, which we have
-             -- available in the 'UnsignedTx' as a '[Coin]'.
-             --
-             -- NOTE(adn) In case of 'SenderPaysFee' is practice there might be a slightly
-             -- increase of the projected fee in the case we are forced to pick "yet another input"
-             -- to be able to pay the fee, which would, in turn, also increase the fee due to
-             -- the extra input being picked.
-             return $ Right
-                    $ sumOfInputs tx
-                    `unsafeSubCoin`
-                    (repeatedly Core.unsafeAddCoin change (sumOfOutputs tx))
-  where
-    -- Tribute to @edsko
-    repeatedly :: (a -> b -> b) -> ([a] -> b -> b)
-    repeatedly = flip . foldl' . flip
-
-    -- Unlike a block, a /single transaction/ cannot have inputs that sum to
-    -- more than maxCoinVal
-    sumOfInputs :: UnsignedTx -> Coin
-    sumOfInputs tx =
-        let inputs = fmap (toaOut . snd) . unsignedTxInputs $ tx
-        in paymentAmount inputs
-
-    sumOfOutputs :: UnsignedTx -> Coin
-    sumOfOutputs tx =
-        let outputs = map toaOut $ unsignedTxOutputs tx
-        in paymentAmount outputs
+         Right (_db, _tx, fees, _originalUtxo) -> do
+             -- sanity check of fees is done.
+             return $ Right fees
+
+isSane :: CoinSelectionOptions -> Coin -> Bool
+isSane _options fees =
+    -- this is a bit ad-hoc, but the policy is taken from the node.
+    -- another solution is to use the policy from CoinSelectionOptions
+    -- and call it with 0 ins and outs, which should give the same number.
+    let minFees = Core.mkCoin 155381
+        maxCoeff :: Int = 2
+    in
+        (fees >= minFees) && (fees <= Core.unsafeMulCoin minFees maxCoeff)
+
+computeFeesOfUnsignedTx :: UnsignedTx -> Coin
+computeFeesOfUnsignedTx unsginedTx =
+    sumOfInputs unsginedTx
+        `unsafeSubCoin`
+                    (repeatedly Core.unsafeAddCoin (unsignedTxChange unsginedTx)
+                                                   (sumOfOutputs unsginedTx))
+    where
+        -- Tribute to @edsko
+        repeatedly :: (a -> b -> b) -> ([a] -> b -> b)
+        repeatedly = flip . foldl' . flip
+
+        -- Unlike a block, a /single transaction/ cannot have inputs that sum to
+        -- more than maxCoinVal
+        sumOfInputs :: UnsignedTx -> Coin
+        sumOfInputs tx =
+            let inputs = fmap (toaOut . snd) . unsignedTxInputs $ tx
+            in paymentAmount inputs
+
+        sumOfOutputs :: UnsignedTx -> Coin
+        sumOfOutputs tx =
+            let outputs = map toaOut $ unsignedTxOutputs tx
+            in paymentAmount outputs
 
 -- | Errors during transaction signing
 --