Add query leios-committee and base query pool-state

.changes/20261017_090000_cardano-cli_ch1bo_stake_pool_state_leios_committee_queries.yml

@@ -0,0 +1,8 @@
+project: cardano-cli
+pr: 0
+kind:
+  - feature
+  - breaking
+description: |
+  Add `query leios-committee`, printing the Leios voting committees of the current and the next epoch.
+  `query pool-state` now reports each pool's state from the ledger's stake pool state query, including the epoch its voting key was registered in, its future parameters and retirement epoch.

cabal.project

@@ -127,3 +127,57 @@ if impl(ghc >= 9.14)
     , time-locale-compat:time
     , with-utf8:base
 -- cabal-allow-newer end
+
+-- TODO: drop once the ledger and consensus queries are released to CHaP.
+-- cardano-ledger master after https://github.com/IntersectMBO/cardano-ledger/pull/6162
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/cardano-ledger
+  tag: 6654c3e5e348aaa735d428fba0973dd17703d9d3
+  --sha256: sha256-e1e3GwjKaFVtWxcJPfGlCKb1WJ8WV30qc//1eCki7BU=
+  subdir:
+    libs/cardano-data
+    libs/cardano-ledger-api
+    libs/small-steps
+    libs/cardano-ledger-binary
+    libs/cardano-ledger-core
+    libs/cardano-protocol
+    libs/cardano-protocol-tpraos
+    eras/byron/chain/executable-spec
+    eras/byron/ledger/executable-spec
+    eras/byron/ledger/impl
+    eras/shelley/impl
+    eras/mary/impl
+    eras/allegra/impl
+    eras/alonzo/impl
+    eras/babbage/impl
+    eras/conway/impl
+    eras/dijkstra/impl
+
+-- Points to ouroboros-consensus/main
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/ouroboros-consensus
+  tag: a0e8f68afeac411fcc8262f9271438314a87ed02
+  --sha256: sha256-0lt7zXaR+0v/iDYQQQULCxxfXJFGldAgDIEE719+vrk=
+
+-- Points to https://github.com/IntersectMBO/cardano-api/pull/1383
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/cardano-api
+  tag: 4f33f7d2c44c302a6e7e541f231610d60eb9d9b4
+  --sha256: sha256-1pJxkS2koc5vyndG4dRNUlAkD4ec7M/QSVxcDoQB44c=
+  subdir:
+    cardano-api
+
+allow-newer:
+    , cardano-keys:cardano-ledger-core
+    , cardano-keys:cardano-ledger-shelley
+    , cardano-keys:cardano-protocol
+    , cardano-config:cardano-ledger-conway
+    , cardano-config:cardano-ledger-core
+    , cardano-config:cardano-ledger-dijkstra
+    , cardano-config:cardano-ledger-shelley
+
+-- consensus main still carries version 5.0
+allow-older: *:ouroboros-consensus

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

@@ -72,6 +72,7 @@ data QueryCmds era
   | QueryGovStateCmd !(QueryNoArgCmdArgs era)
   | QueryRatifyStateCmd !(QueryNoArgCmdArgs era)
   | QueryFuturePParamsCmd !(QueryNoArgCmdArgs era)
+  | QueryLeiosCommitteeCmd !(QueryNoArgCmdArgs era)
   | QueryDRepStateCmd !(QueryDRepStateCmdArgs era)
   | QueryDRepStakeDistributionCmd !(QueryDRepStakeDistributionCmdArgs era)
   | QuerySPOStakeDistributionCmd !(QuerySPOStakeDistributionCmdArgs era)
@@ -340,6 +341,8 @@ renderQueryCmds = \case
     "ratify-state"
   QueryFuturePParamsCmd{} ->
     "future-pparams"
+  QueryLeiosCommitteeCmd{} ->
+    "leios-committee"
   QueryDRepStateCmd{} ->
     "drep-state"
   QueryDRepStakeDistributionCmd{} ->
@@ -383,6 +386,7 @@ queryCmdNodeConnInfo = \case
   QueryGovStateCmd QueryNoArgCmdArgs{commons} -> fromCommons commons
   QueryRatifyStateCmd QueryNoArgCmdArgs{commons} -> fromCommons commons
   QueryFuturePParamsCmd QueryNoArgCmdArgs{commons} -> fromCommons commons
+  QueryLeiosCommitteeCmd QueryNoArgCmdArgs{commons} -> fromCommons commons
   QueryDRepStateCmd QueryDRepStateCmdArgs{commons} -> fromCommons commons
   QueryDRepStakeDistributionCmd QueryDRepStakeDistributionCmdArgs{commons} -> fromCommons commons
   QuerySPOStakeDistributionCmd QuerySPOStakeDistributionCmdArgs{commons} -> fromCommons commons

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

@@ -268,6 +268,7 @@ pQueryCmds envCli =
         $ mconcat
           [ "Dump the current ledger state of the node (Ledger.NewEpochState -- advanced command)"
           ]
+    , pQueryLeiosCommitteeCmd envCli
     , Just
         . Opt.hsubparser
         $ mconcat
@@ -676,6 +677,17 @@ pQueryFuturePParamsCmd envCli = do
     . Opt.info (QueryFuturePParamsCmd <$> pQueryNoArgCmdArgs envCli "future-pparams")
     $ Opt.progDesc "Get the protocol parameters that will apply at the next epoch"
 
+pQueryLeiosCommitteeCmd
+  :: IsEra era
+  => EnvCli
+  -> Maybe (Parser (QueryCmds era))
+pQueryLeiosCommitteeCmd envCli = do
+  pure
+    . Opt.hsubparser
+    . commandWithMetavar "leios-committee"
+    . Opt.info (QueryLeiosCommitteeCmd <$> pQueryNoArgCmdArgs envCli "leios-committee")
+    $ Opt.progDesc "Get the Leios voting committees of the current and the next epoch"
+
 -- TODO Conway: DRep State and DRep Stake Distribution parsers use DRep keys to obtain DRep credentials. This only
 -- makes use of 'KeyHashObj' constructor of 'Credential kr c'. Should we also support here 'ScriptHashObj'?
 -- What about 'DRep c' - this means that only 'KeyHash' constructor is in use here: should also

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

@@ -119,6 +119,7 @@ runQueryCmds cmd = do
     Cmd.QueryDRepStateCmd args -> runQueryDRepState args
     Cmd.QueryEraHistoryCmd args -> runQueryEraHistoryCmd args
     Cmd.QueryFuturePParamsCmd args -> runQueryFuturePParams args
+    Cmd.QueryLeiosCommitteeCmd args -> runQueryLeiosCommittee args
     Cmd.QueryGovStateCmd args -> runQueryGovState args
     Cmd.QueryKesPeriodInfoCmd args -> runQueryKesPeriodInfoCmd args
     Cmd.QueryLeadershipScheduleCmd args -> runQueryLeadershipScheduleCmd args
@@ -664,15 +665,14 @@ runQueryPoolStateCmd
 
           era <- supportedEra cEra
 
-          let beo = convert era
-              poolFilter = case allOrOnlyPoolIds of
+          let poolFilter = case allOrOnlyPoolIds of
                 All -> Nothing
-                Only poolIds -> Just $ fromList poolIds
-
-          currentEpoch <- easyRunQuery (queryEpoch (convert era))
+                Only poolIds -> Just . fromList $ map unStakePoolKeyHash poolIds
 
-          result <- easyRunQuery (queryPoolState beo poolFilter)
-          hoist liftIO $ writePoolState era currentEpoch outputFormat mOutFile result
+          result <-
+            easyRunQuery $
+              queryStakePoolState (convert era) poolFilter NotIncludeDelegators
+          hoist liftIO $ writePoolState outputFormat mOutFile result
       )
       & fromEitherCIOCli
 
@@ -1170,22 +1170,15 @@ writeStakeSnapshots era outputFormat mOutFile qState = do
     . newExceptT
     $ writeLazyByteStringOutput mOutFile output
 
--- | This function obtains the pool parameters, equivalent to the following jq query on the output of query ledger-state
---   .nesEs.esLState.lsDPState.dpsPState.psStakePoolParams.<pool_id>
+-- | The state of each stake pool: its current and future parameters, deposit,
+-- voting key and retirement epoch.
 writePoolState
-  :: Exp.Era era
-  -> EpochNo
-  -> Vary [FormatJson, FormatYaml]
+  :: Vary [FormatJson, FormatYaml]
   -> Maybe (File () Out)
-  -> SerialisedPoolState era
+  -> Map (L.KeyHash L.StakePool) (L.QueryResultStakePoolState era)
   -> ExceptT QueryCmdError IO ()
-writePoolState era currentEpoch outputFormat mOutFile serialisedCurrentEpochState = do
-  poolState <-
-    liftEither . first QueryCmdPoolStateDecodeError $
-      decodePoolState (convert era) serialisedCurrentEpochState
-
-  let poolStates = mkPoolStates currentEpoch poolState :: Map (L.KeyHash L.StakePool) PoolParams
-      output =
+writePoolState outputFormat mOutFile poolStates = do
+  let output =
         outputFormat
           & ( id
                 . Vary.on (\FormatJson -> Json.encodeJson)
@@ -1697,6 +1690,34 @@ runQueryFuturePParams
     fromEitherIOCli @(FileError ()) $
       writeLazyByteStringOutput mOutFile output
 
+runQueryLeiosCommittee
+  :: Cmd.QueryNoArgCmdArgs era
+  -> CIO e ()
+runQueryLeiosCommittee
+  Cmd.QueryNoArgCmdArgs
+    { Cmd.eon
+    , Cmd.commons =
+      Cmd.QueryCommons
+        { Cmd.nodeConnInfo
+        , Cmd.target
+        }
+    , Cmd.outputFormat
+    , Cmd.mOutFile
+    } = conwayEraOnwardsConstraints eon $ do
+    committee <- fromExceptTCli $ runQuery nodeConnInfo target $ queryLeiosCommittee (convert eon)
+
+    let output =
+          outputFormat
+            & ( id
+                  . Vary.on (\FormatJson -> Json.encodeJson)
+                  . Vary.on (\FormatYaml -> Json.encodeYaml)
+                  $ Vary.exhaustiveCase
+              )
+            $ committee
+
+    fromEitherIOCli @(FileError ()) $
+      writeLazyByteStringOutput mOutFile output
+
 runQueryDRepState
   :: Cmd.QueryDRepStateCmdArgs era
   -> CIO e ()

cardano-cli/src/Cardano/CLI/Orphan.hs

@@ -16,12 +16,14 @@ import Cardano.Api.Ledger qualified as L
 
 import Cardano.CLI.Type.Error.ScriptDecodeError
 import Cardano.Ledger.Conway.State qualified as L
+import Cardano.Ledger.Shelley.LedgerState qualified as L (nesStakePoolDistrG)
 
 import Control.Exception
 import Data.Aeson
 import Data.List qualified as List
 import Data.Typeable
 import Data.Word
+import Lens.Micro ((^.))
 
 instance Error [Bech32DecodeError] where
   prettyError errs = vsep $ map prettyError errs
@@ -34,14 +36,14 @@ instance
   (L.EraTxOut ledgerera, L.EraGov ledgerera, L.EraCertState ledgerera, L.EraStake ledgerera)
   => ToJSON (L.NewEpochState ledgerera)
   where
-  toJSON (L.NewEpochState nesEL nesBprev nesBCur nesEs nesRu nesPd _stashedAvvm) =
+  toJSON nes@(L.NewEpochState nesEL nesBprev nesBCur nesEs nesRu _stashedAvvm) =
     object
       [ "currentEpoch" .= nesEL
       , "priorBlocks" .= nesBprev
       , "currentEpochBlocks" .= nesBCur
       , "currentEpochState" .= nesEs
       , "rewardUpdate" .= nesRu
-      , "currentStakeDistribution" .= nesPd
+      , "currentStakeDistribution" .= (nes ^. L.nesStakePoolDistrG)
       ]
 
 instance ToJSON HashableScriptData where

cardano-cli/src/Cardano/CLI/Type/Common.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE StandaloneDeriving #-}
 
@@ -54,8 +53,6 @@ module Cardano.CLI.Type.Common
   , OpCertNodeStateCounter (..)
   , OpCertOnDiskCounter (..)
   , OpCertStartingKesPeriod (..)
-  , PoolParams (..)
-  , mkPoolStates
   , ParserFileDirection (..)
   , PrivKeyFile (..)
   , ProposalBinary
@@ -113,14 +110,9 @@ import Cardano.Api hiding (Script)
 import Cardano.Api.Experimental.Certificate (DRepMetadata, StakePoolMetadata)
 import Cardano.Api.Ledger qualified as L
 
-import Cardano.Ledger.Api.State.Query qualified as L
 import Cardano.Ledger.Plutus.Language qualified as L
-import Cardano.Ledger.State qualified as L
 
-import Data.Aeson (object, pairs, (.=))
 import Data.Aeson qualified as Aeson
-import Data.Map.Strict (Map)
-import Data.Map.Strict qualified as Map
 import Data.String (IsString)
 import Data.Text qualified as Text
 import Data.Word (Word64)
@@ -365,69 +357,6 @@ instance FromJSON GenesisFile where
 
 data AllOrOnly a = All | Only [a] deriving (Eq, Show)
 
--- | This data structure is used to allow nicely formatted output in the query pool-params command.
--- params are the current pool parameter settings, futureparams are new parameters, retiringEpoch is the
--- epoch that has been set for pool retirement.  Any of these may be Nothing.
-data PoolParams = PoolParams
-  { poolParameters :: Maybe L.StakePoolState
-  , futurePoolParameters :: Maybe L.StakePoolState
-  , retiringEpoch :: Maybe EpochNo
-  }
-  deriving Show
-
--- | The current epoch is needed to reconstruct a 'L.StakePoolState' from the
--- query result. 'L.QueryPoolStateResult' does not report the epoch in which a
--- pool's BLS voting key was registered, so the epoch in which the parameters
--- take effect is used instead: the current epoch for the active parameters and
--- the next one for the future parameters, which @POOLREAP@ activates at the
--- epoch boundary. This only affects pools that have registered a BLS key, and
--- it means the @bksRegisteredIn@ field in the @query pool-state@ output is a
--- placeholder.
---
--- TODO: use the real registration epoch once the ledger exposes it through a
--- query. See https://github.com/IntersectMBO/cardano-ledger/issues/6147.
-mkPoolStates :: EpochNo -> PoolState era -> Map (L.KeyHash L.StakePool) PoolParams
-mkPoolStates
-  currentEpoch
-  ( PoolState
-      ( L.QueryPoolStateResult
-          { L.qpsrStakePoolParams
-          , L.qpsrFutureStakePoolParams
-          , L.qpsrRetiring
-          , L.qpsrDeposits
-          }
-        )
-    ) = (`Map.mapWithKey` qpsrStakePoolParams) $ \kh pp -> do
-    let mDeposit = L.toCompact =<< Map.lookup kh qpsrDeposits
-        stakingCredentials = mempty -- QueryPoolStateResult does not provide delegators
-    PoolParams
-      { poolParameters =
-          (\deposit -> L.mkStakePoolState currentEpoch deposit stakingCredentials pp) <$> mDeposit
-      , futurePoolParameters = do
-          futurePp <- Map.lookup kh qpsrFutureStakePoolParams
-          -- Future parameters only take effect at the next epoch boundary.
-          (\deposit -> L.mkStakePoolState (succ currentEpoch) deposit stakingCredentials futurePp)
-            <$> mDeposit
-      , retiringEpoch = Map.lookup kh qpsrRetiring
-      }
-
--- | Pretty printing for pool parameters
-instance ToJSON PoolParams where
-  toJSON (PoolParams p fp r) =
-    object
-      [ "poolParams" .= p
-      , "futurePoolParams" .= fp
-      , "retiring" .= r
-      ]
-
-  toEncoding (PoolParams p fp r) =
-    pairs $
-      mconcat
-        [ "poolParams" .= p
-        , "futurePoolParams" .= fp
-        , "retiring" .= r
-        ]
-
 type SigningKeyFile = File (SigningKey ())
 
 type ProposalFile = File ()