Merge pull request #845 from IntersectMBO/smelc/add-treasury-value-query

Add "query treasury" command

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

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

cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs

@@ -38,8 +38,6 @@ module Cardano.CLI.EraBased.Run.Query
   )
 where
 
-{- HLINT ignore "Use list comprehension" -}
-
 import           Cardano.Api hiding (QueryInShelleyBasedEra (..))
 import qualified Cardano.Api as Api
 import           Cardano.Api.Byron hiding (QueryInShelleyBasedEra (..))
@@ -57,6 +55,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)
@@ -99,9 +98,6 @@ import           Prettyprinter.Render.Terminal (AnsiStyle)
 import qualified System.IO as IO
 import           Text.Printf (printf)
 
-{- HLINT ignore "Move brackets to avoid $" -}
-{- HLINT ignore "Redundant flip" -}
-
 runQueryCmds :: Cmd.QueryCmds era -> ExceptT QueryCmdError IO ()
 runQueryCmds = \case
   Cmd.QueryLeadershipScheduleCmd args -> runQueryLeadershipScheduleCmd args
@@ -125,6 +121,7 @@ runQueryCmds = \case
   Cmd.QueryDRepStateCmd args -> runQueryDRepState args
   Cmd.QueryDRepStakeDistributionCmd args -> runQueryDRepStakeDistribution args
   Cmd.QueryCommitteeMembersStateCmd args -> runQueryCommitteeMembersState args
+  Cmd.QueryTreasuryValueCmd args -> runQueryTreasuryValue args
 
 runQueryConstitutionHashCmd
   :: ()
@@ -302,7 +299,7 @@ runQueryTipCmd
 
             let tolerance = RelativeTime (secondsToNominalDiffTime 600)
 
-            return $ flip (percentage tolerance) nowSeconds tipTimeResult
+            return $ percentage tolerance nowSeconds tipTimeResult
 
           mSyncProgress <- hushM syncProgressResult $ \e -> do
             liftIO . LT.hPutStrLn IO.stderr $
@@ -1735,6 +1732,31 @@ 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

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

cardano-cli/test/cardano-cli-golden/files/golden/help.cli

@@ -7150,6 +7150,7 @@ Usage: cardano-cli conway query
                                   | drep-state
                                   | drep-stake-distribution
                                   | committee-state
+                                  | treasury
                                   )
 
   Node query commands. Will query the local node whose Unix domain socket is
@@ -7486,6 +7487,15 @@ Usage: cardano-cli conway query committee-state --socket-path SOCKET_PATH
 
   Get the committee state
 
+Usage: cardano-cli conway query treasury --socket-path SOCKET_PATH
+                                           [--cardano-mode
+                                             [--epoch-slots SLOTS]]
+                                           (--mainnet | --testnet-magic NATURAL)
+                                           [--volatile-tip | --immutable-tip]
+                                           [--out-file FILE]
+
+  Get the treasury value
+
 Usage: cardano-cli conway stake-address 
                                           ( key-gen
                                           | key-hash

cardano-cli/test/cardano-cli-golden/files/golden/help/conway_query.cli

@@ -19,6 +19,7 @@ Usage: cardano-cli conway query
                                   | drep-state
                                   | drep-stake-distribution
                                   | committee-state
+                                  | treasury
                                   )
 
   Node query commands. Will query the local node whose Unix domain socket is
@@ -60,3 +61,4 @@ Available commands:
   drep-state               Get the DRep state.
   drep-stake-distribution  Get the DRep stake distribution.
   committee-state          Get the committee state
+  treasury                 Get the treasury value

cardano-cli/test/cardano-cli-golden/files/golden/help/conway_query_treasury.cli

@@ -0,0 +1,28 @@
+Usage: cardano-cli conway query treasury --socket-path SOCKET_PATH
+                                           [--cardano-mode
+                                             [--epoch-slots SLOTS]]
+                                           (--mainnet | --testnet-magic NATURAL)
+                                           [--volatile-tip | --immutable-tip]
+                                           [--out-file FILE]
+
+  Get the treasury value
+
+Available options:
+  --socket-path SOCKET_PATH
+                           Path to the node socket. This overrides the
+                           CARDANO_NODE_SOCKET_PATH environment variable. The
+                           argument is optional if CARDANO_NODE_SOCKET_PATH is
+                           defined and mandatory otherwise.
+  --cardano-mode           For talking to a node running in full Cardano mode
+                           (default).
+  --epoch-slots SLOTS      The number of slots per epoch for the Byron era.
+                           (default: 21600)
+  --mainnet                Use the mainnet magic id. This overrides the
+                           CARDANO_NODE_NETWORK_ID environment variable
+  --testnet-magic NATURAL  Specify a testnet magic id. This overrides the
+                           CARDANO_NODE_NETWORK_ID environment variable
+  --volatile-tip           Use the volatile tip as a target. (This is the
+                           default)
+  --immutable-tip          Use the immutable tip as a target.
+  --out-file FILE          The output file.
+  -h,--help                Show this help text