Implement funcitonality for handling delegation deposits

cardano-api/ChangeLog.md

@@ -44,6 +44,9 @@
 
 - **Breaking change** - `calculateMinimumUTxO` no longer fails, it is a total computation.
 
+- **Breaking change** - `evaluateTransactionBalance`, `makeTransactionBodyAutoBalance` and
+  `constructBalancedTx` aquire a new argument: a map with staking delegation deposits.
+
 ### Bugs
 
 - Allow reading text envelopes from pipes ([PR 4384](https://github.com/input-output-hk/cardano-node/pull/4384))

cardano-api/src/Cardano/Api/Convenience/Construction.hs

@@ -29,6 +29,7 @@ import           Cardano.Api.Query
 import           Cardano.Api.Tx
 import           Cardano.Api.TxBody
 import           Cardano.Api.Utils
+import           Cardano.Api.Value
 
 -- | Construct a balanced transaction.
 -- See Cardano.Api.Convenience.Query.queryStateForBalancedTx for a
@@ -44,14 +45,16 @@ constructBalancedTx
   -> LedgerEpochInfo
   -> SystemStart
   -> Set PoolId       -- ^ The set of registered stake pools
+  -> Map.Map StakeCredential Lovelace
   -> [ShelleyWitnessSigningKey]
   -> Either TxBodyErrorAutoBalance (Tx era)
 constructBalancedTx txbodcontent changeAddr mOverrideWits utxo pparams
-                    ledgerEpochInfo systemStart stakePools shelleyWitSigningKeys = do
+                    ledgerEpochInfo systemStart stakePools
+                    stakeDelegDeposits shelleyWitSigningKeys = do
   BalancedTxBody _ txbody _txBalanceOutput _fee
     <- makeTransactionBodyAutoBalance
          systemStart ledgerEpochInfo
-         pparams stakePools utxo txbodcontent
+         pparams stakePools stakeDelegDeposits utxo txbodcontent
          changeAddr mOverrideWits
 
   let keyWits = map (makeShelleyKeyWitness txbody) shelleyWitSigningKeys

cardano-api/src/Cardano/Api/Convenience/Query.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -17,12 +18,15 @@ import           Control.Monad.Trans.Except (ExceptT (..), except, runExceptT)
 import           Control.Monad.Trans.Except.Extra (firstExceptT, hoistMaybe)
 import           Data.Bifunctor (first)
 import           Data.Function ((&))
+import           Data.Maybe (mapMaybe)
+import           Data.Map (Map)
 import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Text (Text)
 
 import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch (..))
 
+import           Cardano.Api.Address
 import           Cardano.Api.Certificate
 import           Cardano.Api.Convenience.Constraints
 import           Cardano.Api.Environment
@@ -34,6 +38,7 @@ import           Cardano.Api.ProtocolParameters
 import           Cardano.Api.Query
 import           Cardano.Api.TxBody
 import           Cardano.Api.Utils
+import           Cardano.Api.Value
 
 data QueryConvenienceError
   = AcqFailure AcquiringFailure
@@ -63,8 +68,16 @@ queryStateForBalancedTx
   :: CardanoEra era
   -> NetworkId
   -> [TxIn]
-  -> IO (Either QueryConvenienceError (UTxO era, ProtocolParameters, EraHistory CardanoMode, SystemStart, Set PoolId))
-queryStateForBalancedTx era networkId allTxIns = runExceptT $ do
+  -> [Certificate]
+  -> IO (Either QueryConvenienceError ( UTxO era
+                                      , ProtocolParameters
+                                      , EraHistory CardanoMode
+                                      , SystemStart
+                                      , Set PoolId
+                                      , Map StakeCredential Lovelace
+                                      )
+        )
+queryStateForBalancedTx era networkId allTxIns certs = runExceptT $ do
   SocketPath sockPath <- ExceptT $ first SockErr <$> readEnvSocketPath
 
   let cModeParams = CardanoModeParams $ EpochSlots 21600
@@ -86,15 +99,24 @@ queryStateForBalancedTx era networkId allTxIns = runExceptT $ do
       eraHistoryQuery = QueryEraHistory CardanoModeIsMultiEra
       systemStartQuery = QuerySystemStart
       stakePoolsQuery = QueryInEra qeInMode . QueryInShelleyBasedEra qSbe $ QueryStakePools
+      stakeCreds = Set.fromList $ flip mapMaybe certs $ \case
+        StakeAddressDeregistrationCertificate cred -> Just cred
+        _ -> Nothing
+      stakeDelegDepositsQuery =
+        QueryInEra qeInMode . QueryInShelleyBasedEra qSbe $ QueryStakeDelegDeposits stakeCreds
 
   -- Query execution
   utxo <- ExceptT $ executeQueryCardanoMode era networkId utxoQuery
   pparams <- ExceptT $ executeQueryCardanoMode era networkId pparamsQuery
   eraHistory <- firstExceptT AcqFailure $ ExceptT $ queryNodeLocalState localNodeConnInfo Nothing eraHistoryQuery
   systemStart <- firstExceptT AcqFailure $ ExceptT $ queryNodeLocalState localNodeConnInfo Nothing systemStartQuery
   stakePools <- ExceptT $ executeQueryCardanoMode era networkId stakePoolsQuery
+  stakeDelegDeposits <-
+    if null stakeCreds
+    then pure mempty
+    else ExceptT $ executeQueryCardanoMode era networkId stakeDelegDepositsQuery
 
-  return (utxo, pparams, eraHistory, systemStart, stakePools)
+  return (utxo, pparams, eraHistory, systemStart, stakePools, stakeDelegDeposits)
 
 -- | Query the node to determine which era it is in.
 determineEra

cardano-api/src/Cardano/Api/Fees.hs

@@ -638,14 +638,15 @@ evaluateTransactionBalance :: forall era.
                               IsShelleyBasedEra era
                            => BundledProtocolParameters era
                            -> Set PoolId
+                           -> Map StakeCredential Lovelace
                            -> UTxO era
                            -> TxBody era
                            -> TxOutValue era
-evaluateTransactionBalance _ _ _ (ByronTxBody _) =
+evaluateTransactionBalance _ _ _ _ (ByronTxBody _) =
     case shelleyBasedEra :: ShelleyBasedEra era of {}
     --TODO: we could actually support Byron here, it'd be different but simpler
 
-evaluateTransactionBalance bpp poolids utxo
+evaluateTransactionBalance bpp poolids stakeDelegDeposits utxo
                            (ShelleyTxBody era txbody _ _ _ _) =
     withLedgerConstraints
       era
@@ -667,9 +668,8 @@ evaluateTransactionBalance bpp poolids utxo
     isRegPool :: Ledger.KeyHash Ledger.StakePool Ledger.StandardCrypto -> Bool
     isRegPool kh = StakePoolKeyHash kh `Set.member` poolids
 
-    -- FIXME: Add deposit map as an argument and implement a depsit loookup query in
-    -- consensus and cardano-cli
-    lookupDelegDeposit _cred = Nothing
+    lookupDelegDeposit cred =
+      toShelleyLovelace <$> Map.lookup (fromShelleyStakeCredential cred) stakeDelegDeposits
 
     evalMultiAsset :: forall ledgerera.
                       ShelleyLedgerEra era ~ ledgerera
@@ -917,14 +917,18 @@ makeTransactionBodyAutoBalance
   => SystemStart
   -> LedgerEpochInfo
   -> ProtocolParameters
-  -> Set PoolId       -- ^ The set of registered stake pools
+  -> Set PoolId       -- ^ The set of registered stake pools, that are being
+                      --   unregistered in this transaction.
+  -> Map StakeCredential Lovelace
+                      -- ^ Map of all deposits for stake credentials that are being
+                      --   unregistered in this transaction
   -> UTxO era         -- ^ Just the transaction inputs, not the entire 'UTxO'.
   -> TxBodyContent BuildTx era
   -> AddressInEra era -- ^ Change address
   -> Maybe Word       -- ^ Override key witnesses
   -> Either TxBodyErrorAutoBalance (BalancedTxBody era)
-makeTransactionBodyAutoBalance systemstart history pparams
-                            poolids utxo txbodycontent changeaddr mnkeys = do
+makeTransactionBodyAutoBalance systemstart history pparams poolids stakeDelegDeposits
+                            utxo txbodycontent changeaddr mnkeys = do
 
     -- Our strategy is to:
     -- 1. evaluate all the scripts to get the exec units, update with ex units
@@ -999,7 +1003,7 @@ makeTransactionBodyAutoBalance systemstart history pparams
                  txReturnCollateral = retColl,
                  txTotalCollateral = reqCol
                }
-    let balance = evaluateTransactionBalance bpparams poolids utxo txbody2
+    let balance = evaluateTransactionBalance bpparams poolids stakeDelegDeposits utxo txbody2
 
     forM_ (txOuts txbodycontent1) $ \txout -> checkMinUTxOValue txout bpparams
 

cardano-api/src/Cardano/Api/Query.hs

@@ -124,6 +124,7 @@ import qualified Cardano.Chain.Update.Validation.Interface as Byron.Update
 
 import           Cardano.Ledger.Binary
 import qualified Cardano.Ledger.Binary.Plain as Plain
+import qualified Cardano.Ledger.Credential as Shelley
 import           Cardano.Ledger.Crypto (Crypto)
 import qualified Cardano.Ledger.Shelley.API as Shelley
 import qualified Cardano.Ledger.Shelley.Core as Core
@@ -140,8 +141,8 @@ import           Cardano.Api.Keys.Shelley
 import           Cardano.Api.Modes
 import           Cardano.Api.NetworkId
 import           Cardano.Api.ProtocolParameters
-import           Cardano.Api.TxBody
 import           Cardano.Api.Tx (eraProtVerLow)
+import           Cardano.Api.TxBody
 import           Cardano.Api.Value
 import           Data.Word (Word64)
 
@@ -289,6 +290,10 @@ data QueryInShelleyBasedEra era result where
     :: Maybe (Set PoolId)
     -> QueryInShelleyBasedEra era (SerialisedStakeSnapshots era)
 
+  QueryStakeDelegDeposits
+    :: Set StakeCredential
+    -> QueryInShelleyBasedEra era (Map StakeCredential Lovelace)
+
 instance NodeToClientVersionOf (QueryInShelleyBasedEra era result) where
   nodeToClientVersionOf QueryEpoch = NodeToClientV_9
   nodeToClientVersionOf QueryGenesisParameters = NodeToClientV_9
@@ -305,6 +310,7 @@ instance NodeToClientVersionOf (QueryInShelleyBasedEra era result) where
   nodeToClientVersionOf (QueryPoolState _) = NodeToClientV_14
   nodeToClientVersionOf (QueryPoolDistribution _) = NodeToClientV_14
   nodeToClientVersionOf (QueryStakeSnapshot _) = NodeToClientV_14
+  nodeToClientVersionOf (QueryStakeDelegDeposits _) = NodeToClientV_16
 
 deriving instance Show (QueryInShelleyBasedEra era result)
 
@@ -680,6 +686,11 @@ toConsensusQueryShelleyBased erainmode (QueryPoolDistribution poolIds) =
   where
     getPoolIds :: Set PoolId -> Set (Shelley.KeyHash Shelley.StakePool Consensus.StandardCrypto)
     getPoolIds = Set.map (\(StakePoolKeyHash kh) -> kh)
+toConsensusQueryShelleyBased erainmode (QueryStakeDelegDeposits stakeCreds) =
+    Some (consensusQueryInEraInMode erainmode (Consensus.GetStakeDelegDeposits stakeCreds'))
+  where
+    stakeCreds' :: Set (Shelley.StakeCredential Consensus.StandardCrypto)
+    stakeCreds' = Set.map toShelleyStakeCredential stakeCreds
 
 consensusQueryInEraInMode
   :: forall era mode erablock modeblock result result' xs.
@@ -937,6 +948,13 @@ fromConsensusQueryResultShelleyBased _ QueryStakeSnapshot{} q' r' =
     Consensus.GetCBOR Consensus.GetStakeSnapshots {} -> SerialisedStakeSnapshots r'
     _                                                -> fromConsensusQueryResultMismatch
 
+fromConsensusQueryResultShelleyBased _ QueryStakeDelegDeposits{} q' stakeCreds' =
+    case q' of
+      Consensus.GetStakeDelegDeposits{} -> Map.map fromShelleyLovelace
+                                         . Map.mapKeysMonotonic fromShelleyStakeCredential
+                                         $ stakeCreds'
+      _                                 -> fromConsensusQueryResultMismatch
+
 -- | This should /only/ happen if we messed up the mapping in 'toConsensusQuery'
 -- and 'fromConsensusQueryResult' so they are inconsistent with each other.
 --

cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs

@@ -421,8 +421,8 @@ runTxBuildCmd
 
       case consensusMode of
         CardanoMode -> do
-          (nodeEraUTxO, _, eraHistory, systemStart, _) <-
-            lift (queryStateForBalancedTx nodeEra nid allTxInputs)
+          (nodeEraUTxO, _, eraHistory, systemStart, _, _) <-
+            lift (queryStateForBalancedTx nodeEra nid allTxInputs [])
               & onLeft (left . ShelleyTxCmdQueryConvenienceError)
 
           -- Why do we cast the era? The user can specify an era prior to the era that the node is currently in.
@@ -707,9 +707,14 @@ runTxBuild era (AnyConsensusModeParams cModeParams) networkId mScriptValidity
       AnyCardanoEra nodeEra <- lift (determineEra cModeParams localNodeConnInfo)
         & onLeft (left . ShelleyTxCmdQueryConvenienceError . AcqFailure)
 
-      (nodeEraUTxO, pparams, eraHistory, systemStart, stakePools) <-
+      let certs =
+            case validatedTxCerts of
+              TxCertificates _ cs _ -> cs
+              _ -> []
+
+      (nodeEraUTxO, pparams, eraHistory, systemStart, stakePools, stakeDelegDeposits) <-
         firstExceptT ShelleyTxCmdQueryConvenienceError . newExceptT
-          $ queryStateForBalancedTx nodeEra networkId allTxInputs
+          $ queryStateForBalancedTx nodeEra networkId allTxInputs certs
 
       validatedPParams <- hoistEither $ first ShelleyTxCmdProtocolParametersValidationError
                                       $ validateProtocolParameters era (Just pparams)
@@ -750,8 +755,8 @@ runTxBuild era (AnyConsensusModeParams cModeParams) networkId mScriptValidity
         firstExceptT ShelleyTxCmdBalanceTxBody
           . hoistEither
           $ makeTransactionBodyAutoBalance systemStart (toLedgerEpochInfo eraHistory)
-                                           pparams stakePools txEraUtxo txBodyContent
-                                           cAddr mOverrideWits
+                                           pparams stakePools stakeDelegDeposits txEraUtxo
+                                           txBodyContent cAddr mOverrideWits
 
       liftIO $ putStrLn $ "Estimated transaction fee: " <> (show fee :: String)