Add "query treasury" command

IntersectMBO · Jul 23, 2024 · e96f7d4 · e96f7d4
1 parent 403a01e
commit e96f7d4
Show file tree

Hide file tree

Showing 4 changed files with 79 additions and 21 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs
@@ -25,6 +25,7 @@ module Cardano.CLI.EraBased.Commands.Query
   , QueryNoArgCmdArgs (..)
   , QueryDRepStateCmdArgs (..)
   , QueryDRepStakeDistributionCmdArgs (..)
+  , QueryTreasuryValueCmdArgs (..)
   , renderQueryCmds
   , IncludeStake (..)
   )
@@ -63,6 +64,7 @@ data QueryCmds era
   | QueryDRepStateCmd !(QueryDRepStateCmdArgs era)
   | QueryDRepStakeDistributionCmd !(QueryDRepStakeDistributionCmdArgs era)
   | QueryCommitteeMembersStateCmd !(QueryCommitteeMembersStateCmdArgs era)
+  | QueryTreasuryValueCmd !(QueryTreasuryValueCmdArgs era)
   deriving (Generic, Show)
 
 data QueryLeadershipScheduleCmdArgs = QueryLeadershipScheduleCmdArgs
@@ -275,6 +277,16 @@ data QueryCommitteeMembersStateCmdArgs era = QueryCommitteeMembersStateCmdArgs
   }
   deriving Show
 
+data QueryTreasuryValueCmdArgs era = QueryTreasuryValueCmdArgs
+  { eon :: !(ConwayEraOnwards era)
+  , nodeSocketPath :: !SocketPath
+  , consensusModeParams :: !ConsensusModeParams
+  , networkId :: !NetworkId
+  , target :: !(Consensus.Target ChainPoint)
+  , mOutFile :: !(Maybe (File () Out))
+  }
+  deriving Show
+
 renderQueryCmds :: QueryCmds era -> Text
 renderQueryCmds = \case
   QueryLeadershipScheduleCmd{} ->
@@ -319,6 +331,8 @@ renderQueryCmds = \case
     "drep-stake-distribution"
   QueryCommitteeMembersStateCmd{} ->
     "committee-state"
+  QueryTreasuryValueCmd{} ->
+    "treasury"
 
 renderTxMempoolQuery :: TxMempoolQuery -> Text
 renderTxMempoolQuery = \case

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs
@@ -128,6 +128,7 @@ pQueryCmds era envCli =
     , pQueryDRepStateCmd era envCli
     , pQueryDRepStakeDistributionCmd era envCli
     , pQueryGetCommitteeStateCmd era envCli
+    , pQueryTreasuryValueCmd era envCli
     ]
 
 pQueryProtocolParametersCmd :: EnvCli -> Parser (QueryCmds era)
@@ -492,6 +493,28 @@ pQueryGetCommitteeStateCmd era envCli = do
             ]
       ]
 
+pQueryTreasuryValueCmd
+  :: ()
+  => CardanoEra era
+  -> EnvCli
+  -> Maybe (Parser (QueryCmds era))
+pQueryTreasuryValueCmd era envCli = do
+  w <- forEraMaybeEon era
+  pure $
+    subParser "treasury" $
+      Opt.info (QueryTreasuryValueCmd <$> pQueryTreasuryValueArgs w) $
+        Opt.progDesc "Get the treasury value"
+ where
+  pQueryTreasuryValueArgs
+    :: ConwayEraOnwards era -> Parser (QueryTreasuryValueCmdArgs era)
+  pQueryTreasuryValueArgs w =
+    QueryTreasuryValueCmdArgs w
+      <$> pSocketPath envCli
+      <*> pConsensusModeParams
+      <*> pNetworkId envCli
+      <*> pTarget era
+      <*> optional pOutputFile
+
 pQueryNoArgCmdArgs
   :: ()
   => ConwayEraOnwards era

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs
@@ -57,6 +57,7 @@ import           Cardano.CLI.Types.Key
 import qualified Cardano.CLI.Types.Output as O
 import           Cardano.Crypto.Hash (hashToBytesAsHex)
 import qualified Cardano.Crypto.Hash.Blake2b as Blake2b
+import qualified Cardano.Ledger.Shelley.LedgerState as L
 import           Cardano.Slotting.EpochInfo (EpochInfo (..), epochInfoSlotToUTCTime, hoistEpochInfo)
 import           Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime (..),
                    toRelativeTime)
@@ -125,6 +126,7 @@ runQueryCmds = \case
   Cmd.QueryDRepStateCmd args -> runQueryDRepState args
   Cmd.QueryDRepStakeDistributionCmd args -> runQueryDRepStakeDistribution args
   Cmd.QueryCommitteeMembersStateCmd args -> runQueryCommitteeMembersState args
+  Cmd.QueryTreasuryValueCmd args -> runQueryTreasuryValue args
 
 runQueryConstitutionHashCmd
   :: ()
@@ -1735,6 +1737,33 @@ runQueryCommitteeMembersState
         queryCommitteeMembersState eon coldKeys hotKeys (Set.fromList memberStatuses)
     writeOutput mOutFile $ A.toJSON committeeState
 
+runQueryTreasuryValue
+  :: Cmd.QueryTreasuryValueCmdArgs era
+  -> ExceptT QueryCmdError IO ()
+runQueryTreasuryValue
+  Cmd.QueryTreasuryValueCmdArgs
+    { Cmd.eon
+    , Cmd.nodeSocketPath
+    , Cmd.consensusModeParams
+    , Cmd.networkId
+    , Cmd.target
+    , Cmd.mOutFile
+    } = conwayEraOnwardsConstraints eon $ do
+    let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath
+
+    L.AccountState (L.Coin treasury) _reserves <-
+      runQuery localNodeConnInfo target $ queryAccountState eon
+    let treasuryString = show treasury
+    case mOutFile of
+      Nothing ->
+        liftIO $ putStrLn treasuryString
+      Just outFile ->
+        firstExceptT QueryCmdWriteFileError $
+          ExceptT $
+            writeLazyByteStringFile outFile $
+              LBS.pack $
+                treasuryString
+
 runQuery
   :: LocalNodeConnectInfo
   -> Consensus.Target ChainPoint

diff --git a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
 
 -- | User-friendly pretty-printing for textual user interfaces (TUI)
@@ -242,45 +243,40 @@ friendlyTxBodyImpl
                  , "validity range" .= friendlyValidityRange era (txValidityLowerBound, txValidityUpperBound)
                  , "withdrawals" .= friendlyWithdrawals txWithdrawals
                  ]
-              ++ ( caseByronToBabbageOrConwaysEraOnwards
+              ++ ( monoidForEraInEon @ConwayEraOnwards
+                    era
                     ( \cOnwards ->
                         case txProposalProcedures of
                           Nothing -> []
                           Just (Featured _ TxProposalProceduresNone) -> []
                           Just (Featured _ (TxProposalProcedures lProposals _witnesses)) ->
                             ["governance actions" .= (friendlyLedgerProposals cOnwards $ toList lProposals)]
                     )
-                    era
                  )
-              ++ ( caseByronToBabbageOrConwaysEraOnwards
+              ++ ( monoidForEraInEon @ConwayEraOnwards
+                    era
                     ( \cOnwards ->
                         case txVotingProcedures of
                           Nothing -> []
                           Just (Featured _ TxVotingProceduresNone) -> []
                           Just (Featured _ (TxVotingProcedures votes _witnesses)) ->
                             ["voters" .= friendlyVotingProcedures cOnwards votes]
                     )
-                    era
                  )
-              ++ ( caseByronToBabbageOrConwaysEraOnwards
-                    (const ["currentTreasuryValue" .= toJSON (unFeatured <$> txCurrentTreasuryValue)])
+              ++ ( monoidForEraInEon @ConwayEraOnwards
                     era
+                    (const ["currentTreasuryValue" .= toJSON (unFeatured <$> txCurrentTreasuryValue)])
                  )
-              ++ ( caseByronToBabbageOrConwaysEraOnwards
-                    (const ["treasuryDonation" .= toJSON (unFeatured <$> txTreasuryDonation)])
+              ++ ( monoidForEraInEon @ConwayEraOnwards
                     era
+                    (const ["treasuryDonation" .= toJSON (unFeatured <$> txTreasuryDonation)])
                  )
           )
    where
     friendlyLedgerProposals
       :: ConwayEraOnwards era -> [L.ProposalProcedure (ShelleyLedgerEra era)] -> Aeson.Value
     friendlyLedgerProposals cOnwards proposalProcedures =
       Array $ Vector.fromList $ map (friendlyLedgerProposal cOnwards) proposalProcedures
-    caseByronToBabbageOrConwaysEraOnwards :: (ConwayEraOnwards era -> [a]) -> CardanoEra era -> [a]
-    caseByronToBabbageOrConwaysEraOnwards f =
-      caseByronOrShelleyBasedEra
-        []
-        (caseShelleyToBabbageOrConwayEraOnwards (const []) f)
 
 friendlyLedgerProposal
   :: ConwayEraOnwards era -> L.ProposalProcedure (ShelleyLedgerEra era) -> Aeson.Value
@@ -291,14 +287,10 @@ friendlyVotingProcedures
 friendlyVotingProcedures cOnwards x = conwayEraOnwardsConstraints cOnwards $ toJSON x
 
 redeemerIfShelleyBased :: MonadWarning m => CardanoEra era -> TxBody era -> m [Aeson.Pair]
-redeemerIfShelleyBased era tb =
-  caseByronOrShelleyBasedEra
-    (return [])
-    ( \shEra -> do
-        redeemerInfo <- friendlyRedeemer shEra tb
-        return ["redeemers" .= redeemerInfo]
-    )
-    era
+redeemerIfShelleyBased era tb = monoidForEraInEonA @ShelleyBasedEra era $
+  \shEra -> do
+    redeemerInfo <- friendlyRedeemer shEra tb
+    return ["redeemers" .= redeemerInfo]
 
 friendlyRedeemer :: MonadWarning m => ShelleyBasedEra era -> TxBody era -> m Aeson.Value
 friendlyRedeemer _ (ShelleyTxBody _ _ _ TxBodyNoScriptData _ _) = return Aeson.Null