queryStateForBalancedTx: return currentTreasuryValue

IntersectMBO · Jun 27, 2024 · f339cfc · f339cfc
1 parent c19d045
commit f339cfc
Show file tree

Hide file tree

Showing 3 changed files with 36 additions and 3 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs
@@ -1,11 +1,16 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 
 -- | Convenience query functions
 --
 module Cardano.Api.Convenience.Query (
     QueryConvenienceError(..),
+    TxCurrentTreasuryValue(..),
     determineEra,
     -- * Simplest query related
     executeQueryCardanoMode,
@@ -17,8 +22,10 @@ module Cardano.Api.Convenience.Query (
 
 import           Cardano.Api.Address
 import           Cardano.Api.Certificate
+import           Cardano.Api.Eon.ConwayEraOnwards
 import           Cardano.Api.Eon.ShelleyBasedEra
 import           Cardano.Api.Eras
+import           Cardano.Api.Feature (Featured (..))
 import           Cardano.Api.IO
 import           Cardano.Api.IPC
 import           Cardano.Api.IPC.Monad
@@ -34,6 +41,7 @@ import           Cardano.Ledger.CertState (DRepState (..))
 import qualified Cardano.Ledger.Coin as L
 import qualified Cardano.Ledger.Credential as L
 import qualified Cardano.Ledger.Keys as L
+import qualified Cardano.Ledger.Shelley.LedgerState as L
 import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch (..))
 import           Ouroboros.Network.Protocol.LocalStateQuery.Type (Target (..))
 
@@ -69,6 +77,9 @@ renderQueryConvenienceError (QceUnsupportedNtcVersion (UnsupportedNtcVersionErro
   "This query requires at least " <> textShow minNtcVersion <> " but the node negotiated " <> textShow ntcVersion <> ".\n" <>
   "Later node versions support later protocol versions (but development protocol versions are not enabled in the node by default)."
 
+newtype TxCurrentTreasuryValue = TxCurrentTreasuryValue { unTxCurrentTreasuryValue :: L.Coin }
+  deriving newtype Show
+
 -- | A convenience function to query the relevant information, from
 -- the local node, for Cardano.Api.Convenience.Construction.constructBalancedTx
 queryStateForBalancedTx :: ()
@@ -84,7 +95,8 @@ queryStateForBalancedTx :: ()
           , SystemStart
           , Set PoolId
           , Map StakeCredential L.Coin
-          , Map (L.Credential L.DRepRole L.StandardCrypto) L.Coin))
+          , Map (L.Credential L.DRepRole L.StandardCrypto) L.Coin
+          , Maybe (Featured ConwayEraOnwards era TxCurrentTreasuryValue)) )
 queryStateForBalancedTx era allTxIns certs = runExceptT $ do
   sbe <- requireShelleyBasedEra era
     & onNothing (left ByronEraNotSupported)
@@ -124,7 +136,19 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do
           & onLeft (left . QceUnsupportedNtcVersion)
           & onLeft (left . QueryEraMismatch))
 
-  pure (utxo, LedgerProtocolParameters pparams, eraHistory, systemStart, stakePools, stakeDelegDeposits, drepDelegDeposits)
+  featuredTxTreasuryValueM <-
+    caseShelleyToBabbageOrConwayEraOnwards
+      (const $ pure Nothing)
+      (\cOnwards -> do
+        L.AccountState { L.asTreasury } <-
+          lift (queryAccountState cOnwards)
+            & onLeft (left . QceUnsupportedNtcVersion)
+            & onLeft (left . QueryEraMismatch)
+        let txCurrentTreasuryValue = TxCurrentTreasuryValue asTreasury
+        return $ Just $ Featured cOnwards txCurrentTreasuryValue)
+      sbe
+
+  pure (utxo, LedgerProtocolParameters pparams, eraHistory, systemStart, stakePools, stakeDelegDeposits, drepDelegDeposits, featuredTxTreasuryValueM)
 
 -- | Query the node to determine which era it is in.
 determineEra :: ()

diff --git a/cardano-api/internal/Cardano/Api/Query/Expr.hs b/cardano-api/internal/Cardano/Api/Query/Expr.hs
@@ -2,7 +2,8 @@
 {-# LANGUAGE GADTs #-}
 
 module Cardano.Api.Query.Expr
-  ( queryChainBlockNo
+  ( queryAccountState
+  , queryChainBlockNo
   , queryChainPoint
   , queryConstitution
   , queryCurrentEpochState
@@ -58,6 +59,7 @@ import           Cardano.Ledger.Core (EraCrypto)
 import qualified Cardano.Ledger.Credential as L
 import qualified Cardano.Ledger.Keys as L
 import           Cardano.Ledger.SafeHash
+import qualified Cardano.Ledger.Shelley.LedgerState as L
 import           Cardano.Slotting.Slot
 import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras as Consensus
 
@@ -259,3 +261,9 @@ queryStakeVoteDelegatees :: ()
 queryStakeVoteDelegatees era stakeCredentials = do
   let sbe = conwayEraOnwardsToShelleyBasedEra era
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeVoteDelegatees stakeCredentials
+
+queryAccountState :: ()
+  => ConwayEraOnwards era
+  -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch L.AccountState))
+queryAccountState cOnwards =
+  queryExpr $ QueryInEra . QueryInShelleyBasedEra (conwayEraOnwardsToShelleyBasedEra cOnwards) $ QueryAccountState
diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -926,6 +926,7 @@ module Cardano.Api (
 
     -- ** Queries
     QueryConvenienceError(..),
+    TxCurrentTreasuryValue(..),
     queryStateForBalancedTx,
     renderQueryConvenienceError,