diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs index ad0cedf4c3..98162fb2f0 100644 --- 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 index fbee7339fc..4c518fa284 100644 --- 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 index 7658cfd66d..11767d7a31 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs +++ b/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 diff --git a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs index fa3b0643df..d843eb8aa4 100644 --- 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,7 +243,8 @@ friendlyTxBodyImpl , "validity range" .= friendlyValidityRange era (txValidityLowerBound, txValidityUpperBound) , "withdrawals" .= friendlyWithdrawals txWithdrawals ] - ++ ( caseByronToBabbageOrConwaysEraOnwards + ++ ( monoidForEraInEon @ConwayEraOnwards + era ( \cOnwards -> case txProposalProcedures of Nothing -> [] @@ -250,9 +252,9 @@ friendlyTxBodyImpl Just (Featured _ (TxProposalProcedures lProposals _witnesses)) -> ["governance actions" .= (friendlyLedgerProposals cOnwards $ toList lProposals)] ) - era ) - ++ ( caseByronToBabbageOrConwaysEraOnwards + ++ ( monoidForEraInEon @ConwayEraOnwards + era ( \cOnwards -> case txVotingProcedures of Nothing -> [] @@ -260,15 +262,14 @@ friendlyTxBodyImpl 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 @@ -276,11 +277,6 @@ friendlyTxBodyImpl :: 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 diff --git a/cardano-cli/test/cardano-cli-golden/files/golden/help.cli b/cardano-cli/test/cardano-cli-golden/files/golden/help.cli index f604dd8172..3ebc59652c 100644 --- a/cardano-cli/test/cardano-cli-golden/files/golden/help.cli +++ b/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 diff --git a/cardano-cli/test/cardano-cli-golden/files/golden/help/conway_query.cli b/cardano-cli/test/cardano-cli-golden/files/golden/help/conway_query.cli index 824f8e72ea..5de9fcdea3 100644 --- a/cardano-cli/test/cardano-cli-golden/files/golden/help/conway_query.cli +++ b/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 diff --git a/cardano-cli/test/cardano-cli-golden/files/golden/help/conway_query_treasury.cli b/cardano-cli/test/cardano-cli-golden/files/golden/help/conway_query_treasury.cli new file mode 100644 index 0000000000..c17e9fd928 --- /dev/null +++ b/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