extend 'CoinSelection' type to carry an extra reserve amount that can…

… be used as input

For now, the reserve is always 'Nothing', which should not alter any of the existing behavior. Then, it can be
set to a specific value (e.g. the reward balance) to be used on the left side of the balance (i.e. the input side).

lib/byron/src/Cardano/Wallet/Byron/Transaction.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
@@ -53,7 +54,6 @@ import Cardano.Wallet.Transaction
     ( Certificate (..)
     , ErrDecodeSignedTx (..)
     , ErrMkTx (..)
-    , ErrValidateSelection
     , TransactionLayer (..)
     )
 import Control.Arrow
@@ -68,6 +68,8 @@ import Data.Coerce
     ( coerce )
 import Data.Either.Combinators
     ( maybeToRight )
+import Data.Maybe
+    ( isJust )
 import Data.Proxy
     ( Proxy )
 import Data.Quantity
@@ -81,6 +83,7 @@ import GHC.Stack
 
 import qualified Cardano.Byron.Codec.Cbor as CBOR
 import qualified Cardano.Crypto.Wallet as CC
+import qualified Cardano.Wallet.Transaction as W
 import qualified Codec.CBOR.Encoding as CBOR
 import qualified Codec.CBOR.Read as CBOR
 import qualified Codec.CBOR.Write as CBOR
@@ -136,7 +139,7 @@ newTransactionLayer _proxy protocolMagic = TransactionLayer
         -> [Certificate]
         -> CoinSelection
         -> Fee
-    _minimumFee policy _ (CoinSelection inps outs chngs) =
+    _minimumFee policy _ (CoinSelection inps outs chngs _) =
         computeFee $ sizeOfSignedTx (fst <$> inps) (outs <> map dummyOutput chngs)
       where
         dummyOutput :: Coin -> TxOut
@@ -160,10 +163,12 @@ newTransactionLayer _proxy protocolMagic = TransactionLayer
 
     _validateSelection
         :: CoinSelection
-        -> Either (ErrValidateSelection t) ()
-    _validateSelection (CoinSelection _ outs _) =
+        -> Either ErrValidateSelection ()
+    _validateSelection (CoinSelection _ outs _ rsv) = do
         when (any (\ (TxOut _ c) -> c == Coin 0) outs) $
             Left ErrInvalidTxOutAmount
+        when (isJust rsv) $
+            Left ErrReserveNotAllowed
 
     _decodeSignedTx
         :: ByteString
@@ -195,13 +200,22 @@ newTransactionLayer _proxy protocolMagic = TransactionLayer
 -- Extra validations on coin selection
 --
 
--- | Transaction with 0 output amount is tried
-data ErrInvalidTxOutAmount = ErrInvalidTxOutAmount
+data ErrValidateSelection
+    = ErrInvalidTxOutAmount
+    -- ^ Transaction with 0 output amount is tried
+    | ErrReserveNotAllowed
+    -- ^ Transaction has a reserve input amount, not allowed for this backend
 
-instance Buildable ErrInvalidTxOutAmount where
-    build _ = "Invalid coin selection: at least one output is null."
+instance Buildable ErrValidateSelection where
+    build = \case
+        ErrInvalidTxOutAmount ->
+            "Invalid coin selection: at least one output is null."
+        ErrReserveNotAllowed -> build $ T.unwords
+            [ "The given coin selection was given a reserve amount and this is"
+            , "not allowed for this backend / era."
+            ]
 
-type instance ErrValidateSelection (IO Byron) = ErrInvalidTxOutAmount
+type instance W.ErrValidateSelection (IO Byron) = ErrValidateSelection
 
 --------------------------------------------------------------------------------
 -- Internal

lib/byron/test/unit/Cardano/Wallet/Byron/TransactionSpec.hs

@@ -157,6 +157,8 @@ spec = do
                         ]
                     , change =
                         [Coin 30_556]
+                    , reserve =
+                        Nothing
                     }
 
             runExceptT (adjustForFee opts utxo csel) >>= \case
@@ -365,7 +367,7 @@ propSizeEstimation pm genSel genChngAddrs =
         idPolicy = LinearFee (Quantity 0) (Quantity 1) (Quantity 0)
 
     fromCoinSelection :: CoinSelection -> [Address] -> CBOR.Encoding
-    fromCoinSelection (CoinSelection inps outs chngs) chngAddrs =
+    fromCoinSelection (CoinSelection inps outs chngs _) chngAddrs =
         CBOR.encodeSignedTx (fst <$> inps, outs <> outs') wits
       where
         dummySig =
@@ -444,7 +446,7 @@ genSelection = do
         }
 
 shrinkSelection :: CoinSelection -> [CoinSelection]
-shrinkSelection sel@(CoinSelection inps outs chgs) = case (inps, outs, chgs) of
+shrinkSelection sel@(CoinSelection inps outs chgs rsv) = case (inps, outs, chgs) of
     ([_], [_], []) ->
         []
     _ ->
@@ -457,24 +459,25 @@ shrinkSelection sel@(CoinSelection inps outs chgs) = case (inps, outs, chgs) of
             chgs'' = drop 1 chgs
         in
             filter (\s -> s /= sel && isValidSelection s)
-                [ CoinSelection inps' outs' chgs'
-                , CoinSelection inps' outs chgs
-                , CoinSelection inps outs chgs'
-                , CoinSelection inps outs' chgs
-                , CoinSelection inps'' outs'' chgs''
-                , CoinSelection inps'' outs chgs
-                , CoinSelection inps outs'' chgs
-                , CoinSelection inps outs chgs''
+                [ CoinSelection inps' outs' chgs' rsv
+                , CoinSelection inps' outs chgs rsv
+                , CoinSelection inps outs chgs' rsv
+                , CoinSelection inps outs' chgs rsv
+                , CoinSelection inps'' outs'' chgs'' rsv
+                , CoinSelection inps'' outs chgs rsv
+                , CoinSelection inps outs'' chgs rsv
+                , CoinSelection inps outs chgs'' rsv
                 ]
 
 isValidSelection :: CoinSelection -> Bool
-isValidSelection (CoinSelection i o c) =
+isValidSelection (CoinSelection i o c r) =
     let
         oAmt = sum $ map (fromIntegral . getCoin . coin) o
         cAmt = sum $ map (fromIntegral . getCoin) c
         iAmt = sum $ map (fromIntegral . getCoin . coin . snd) i
+        rAmt = maybe (0 :: Integer) (fromIntegral . getCoin) r
     in
-        (iAmt :: Integer) >= (oAmt + cAmt)
+        iAmt + rAmt >= oAmt + cAmt
 
 genTxIn :: Gen TxIn
 genTxIn = TxIn

lib/core/src/Cardano/Wallet.hs

@@ -1177,7 +1177,7 @@ selectCoinsForDelegationFromUTxO
     -> [Certificate]
     -> ExceptT ErrSelectForDelegation IO CoinSelection
 selectCoinsForDelegationFromUTxO ctx utxo txp certs = do
-    let sel = CoinSelection [] [] []
+    let sel = CoinSelection [] [] [] Nothing
     let feePolicy = feeOpts tl certs (txp ^. #getFeePolicy)
     withExceptT ErrSelectForDelegationFee $ do
         balancedSel <- adjustForFee feePolicy utxo sel
@@ -1321,7 +1321,7 @@ signPayment
     -> Passphrase "raw"
     -> CoinSelection
     -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx)
-signPayment ctx wid argGenChange pwd (CoinSelection ins outs chgs) = db & \DBLayer{..} -> do
+signPayment ctx wid argGenChange pwd (CoinSelection ins outs chgs _rsv) = db & \DBLayer{..} -> do
     withRootKey @_ @s ctx wid pwd ErrSignPaymentWithRootKey $ \xprv scheme -> do
         nodeTip <- withExceptT ErrSignPaymentNetwork $ currentNodeTip nl
         mapExceptT atomically $ do
@@ -1393,7 +1393,7 @@ selectCoinsExternal
     -> NonEmpty TxOut
     -> ExceptT (ErrSelectCoinsExternal e) IO UnsignedTx
 selectCoinsExternal ctx wid argGenChange payments = do
-    CoinSelection mInputs mPayments mChange <-
+    CoinSelection mInputs mPayments mChange _mReserve <-
         withExceptT ErrSelectCoinsExternalUnableToMakeSelection $
             selectCoinsForPayment @ctx @s @t @k @e ctx wid payments
     mOutputs <- db & \DBLayer{..} ->
@@ -1442,7 +1442,7 @@ signDelegation
     -> DelegationAction
     -> ExceptT ErrSignDelegation IO (Tx, TxMeta, UTCTime, SealedTx)
 signDelegation ctx wid argGenChange pwd coinSel action = db & \DBLayer{..} -> do
-    let (CoinSelection ins outs chgs) = coinSel
+    let (CoinSelection ins outs chgs _rsv) = coinSel
     nodeTip <- withExceptT ErrSignDelegationNetwork $ currentNodeTip nl
     withRootKey @_ @s ctx wid pwd ErrSignDelegationWithRootKey $ \xprv scheme -> do
         let pwdP = preparePassphrase scheme pwd

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

@@ -48,6 +48,8 @@ data CoinSelection = CoinSelection
       -- ^ Picked outputs
     , change  :: [Coin]
       -- ^ Resulting changes
+    , reserve :: Maybe Coin
+      -- ^ A coin reserve, from a reward balance or a deposit.
     } deriving (Generic, Show, Eq)
 
 -- NOTE
@@ -59,16 +61,22 @@ instance Semigroup CoinSelection where
         { inputs = inputs a <> inputs b
         , outputs = outputs a <> outputs b
         , change = change a <> change b
+        , reserve = case (reserve a, reserve b) of
+            (Nothing, Nothing) -> Nothing
+            (Just (Coin ca), Nothing) -> Just (Coin ca)
+            (Nothing, Just (Coin cb)) -> Just (Coin cb)
+            (Just (Coin ca), Just (Coin cb)) -> Just (Coin (ca + cb))
         }
 
 instance Monoid CoinSelection where
-    mempty = CoinSelection [] [] []
+    mempty = CoinSelection [] [] [] Nothing
 
 instance Buildable CoinSelection where
-    build (CoinSelection inps outs chngs) = mempty
+    build (CoinSelection inps outs chngs rsv) = mempty
         <> nameF "inputs" (blockListF' "-" inpsF inps)
         <> nameF "outputs" (blockListF outs)
         <> nameF "change" (listF chngs)
+        <> nameF "reserve" (maybe "ø" build rsv)
       where
         inpsF (txin, txout) = build txin <> " (~ " <> build txout <> ")"
 
@@ -83,7 +91,10 @@ data CoinSelectionOptions e = CoinSelectionOptions
 
 -- | Calculate the sum of all input values
 inputBalance :: CoinSelection -> Word64
-inputBalance =  foldl' (\total -> addTxOut total . snd) 0 . inputs
+inputBalance cs =
+    maybe 0 getCoin (reserve cs)
+    +
+    foldl' (\total -> addTxOut total . snd) 0 (inputs cs)
 
 -- | Calculate the sum of all output values
 outputBalance :: CoinSelection -> Word64

lib/core/src/Cardano/Wallet/Primitive/CoinSelection/LargestFirst.hs

@@ -105,9 +105,10 @@ atLeast (utxo0, selection) txout =
         | target <= 0 = Just
             ( utxo
             , selection <> CoinSelection
-                { inputs = ins
+                { inputs  = ins
                 , outputs = [txout]
-                , change = filter (/= (Coin 0)) [Coin (fromIntegral $ abs target)]
+                , change  = filter (/= (Coin 0)) [Coin (fromIntegral $ abs target)]
+                , reserve = Nothing
                 }
             )
         | null utxo =

lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Migration.hs

@@ -103,6 +103,7 @@ depleteUTxO feeOpts batchSize utxo =
         , change =
             let chgs = mapMaybe (noDust . snd) inps
             in if null chgs then [dustThreshold feeOpts] else chgs
+        , reserve = Nothing
         }
       where
         noDust :: TxOut -> Maybe Coin

lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Random.hs

@@ -170,6 +170,7 @@ improveTxOut (maxN0, selection, utxo0) (inps0, txout) = do
             { inputs = inps
             , outputs = [txout]
             , change = mkChange txout inps
+            , reserve = Nothing
             }
         , utxo
         )

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

@@ -164,7 +164,7 @@ senderPaysFee opt utxo sel = evalStateT (go sel) utxo where
         :: MonadRandom m
         => CoinSelection
         -> StateT UTxO (ExceptT ErrAdjustForFee m) CoinSelection
-    go coinSel@(CoinSelection inps outs chgs) = do
+    go coinSel@(CoinSelection inps outs chgs rsv) = do
         -- Substract fee from change outputs, proportionally to their value.
         let (coinSel', remFee) = rebalanceChangeOutputs opt coinSel
 
@@ -189,7 +189,7 @@ senderPaysFee opt utxo sel = evalStateT (go sel) utxo where
             -- we can now correctly cover fee.
             inps' <- coverRemainingFee remFee
             let extraChange = splitChange (Coin $ balance' inps') chgs
-            go $ CoinSelection (inps <> inps') outs extraChange
+            go $ CoinSelection (inps <> inps') outs extraChange rsv
 
 -- | A short / simple version of the 'random' fee policy to cover for fee in
 -- case where existing change were not enough.

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

@@ -51,6 +51,7 @@ spec = do
                 { rsInputs = [17]
                 , rsChange = []
                 , rsOutputs = [17]
+                , rsReserve = Nothing
                 })
             (CoinSelectionFixture
                 { maxNumOfInputs = 100
@@ -64,6 +65,7 @@ spec = do
                 { rsInputs = [17]
                 , rsChange = [16]
                 , rsOutputs = [1]
+                , rsReserve = Nothing
                 })
             (CoinSelectionFixture
                 { maxNumOfInputs = 100
@@ -77,6 +79,7 @@ spec = do
                 { rsInputs = [12, 17]
                 , rsChange = [11]
                 , rsOutputs = [18]
+                , rsReserve = Nothing
                 })
             (CoinSelectionFixture
                 { maxNumOfInputs = 100
@@ -90,6 +93,7 @@ spec = do
                 { rsInputs = [10, 12, 17]
                 , rsChange = [9]
                 , rsOutputs = [30]
+                , rsReserve = Nothing
                 })
             (CoinSelectionFixture
                 { maxNumOfInputs = 100
@@ -103,6 +107,7 @@ spec = do
                 { rsInputs = [6,10,5]
                 , rsChange = [5,4]
                 , rsOutputs = [11,1]
+                , rsReserve = Nothing
                 })
             (CoinSelectionFixture
                 { maxNumOfInputs = 3
@@ -226,7 +231,7 @@ propAtLeast
 propAtLeast (CoinSelProp utxo txOuts) =
     isRight selection ==> let Right (s,_) = selection in prop s
   where
-    prop (CoinSelection inps _ _) =
+    prop (CoinSelection inps _ _ _) =
         L.length inps `shouldSatisfy` (>= NE.length txOuts)
     selection = runIdentity $ runExceptT $
         largestFirst (CoinSelectionOptions (const 100) noValidation) txOuts utxo
@@ -237,7 +242,7 @@ propInputDecreasingOrder
 propInputDecreasingOrder (CoinSelProp utxo txOuts) =
     isRight selection ==> let Right (s,_) = selection in prop s
   where
-    prop (CoinSelection inps _ _) =
+    prop (CoinSelection inps _ _ _) =
         let
             utxo' = (Map.toList . getUTxO) $
                 utxo `excluding` (Set.fromList . map fst $ inps)