Query a node for a snapshot of big ledger peers

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

@@ -28,6 +28,7 @@ module Cardano.CLI.EraBased.Commands.Query
   , QueryDRepStakeDistributionCmdArgs (..)
   , QuerySPOStakeDistributionCmdArgs (..)
   , QueryTreasuryValueCmdArgs (..)
+  , QueryLedgerPeerSnapshotCmdArgs (..)
   , renderQueryCmds
   , IncludeStake (..)
   )
@@ -69,6 +70,7 @@ data QueryCmds era
   | QueryCommitteeMembersStateCmd !(QueryCommitteeMembersStateCmdArgs era)
   | QueryTreasuryValueCmd !(QueryTreasuryValueCmdArgs era)
   | QueryProposalsCmd !(QueryProposalsCmdArgs era)
+  | QueryLedgerPeerSnapshotCmd !QueryLedgerPeerSnapshotCmdArgs
   deriving (Generic, Show)
 
 -- | Fields that are common to most queries
@@ -140,6 +142,12 @@ data QueryLedgerStateCmdArgs = QueryLedgerStateCmdArgs
   }
   deriving (Generic, Show)
 
+data QueryLedgerPeerSnapshotCmdArgs = QueryLedgerPeerSnapshotCmdArgs
+  { commons :: !QueryCommons
+  , outFile :: !(Maybe (File () Out))
+  }
+  deriving (Generic, Show)
+
 data QueryProtocolStateCmdArgs = QueryProtocolStateCmdArgs
   { commons :: !QueryCommons
   , mOutFile :: !(Maybe (File () Out))
@@ -266,6 +274,8 @@ renderQueryCmds = \case
     "query utxo"
   QueryLedgerStateCmd{} ->
     "query ledger-state"
+  QueryLedgerPeerSnapshotCmd{} ->
+    "query ledger-peer-snapshot"
   QueryProtocolStateCmd{} ->
     "query protocol-state"
   QueryStakeSnapshotCmd{} ->

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

@@ -46,6 +46,7 @@ pQueryCmdsTopLevel envCli =
         , pPoolState envCli
         , pTxMempool envCli
         , pSlotNumber envCli
+        , pQueryLedgerPeerSnapshot envCli
         ]
       i =
         Opt.progDesc $
@@ -164,6 +165,20 @@ pSlotNumber envCli =
     Opt.info (pQuerySlotNumberCmd ShelleyBasedEraConway envCli) $
       Opt.progDesc "Query slot number for UTC timestamp"
 
+pQueryLedgerPeerSnapshot :: EnvCli -> Parser (QueryCmds ConwayEra)
+pQueryLedgerPeerSnapshot envCli =
+  subParser "ledger-peer-snapshot" $
+    Opt.info (pQueryLedgerPeerSnapshotCmd ShelleyBasedEraConway envCli) $
+      Opt.progDesc $
+        mconcat
+          [ "Dump the current snapshot of big ledger peers. "
+          , "These are the largest pools that cumulatively hold "
+          , "90% of total stake."
+          ]
+
+-- \^ TODO use bigLedgerPeerQuota from Ouroboros.Network.PeerSelection.LedgerPeers.Utils
+-- which must be re-exposed thru cardano-api
+
 pQueryCmds
   :: ()
   => ShelleyBasedEra era
@@ -216,6 +231,17 @@ pQueryCmds era envCli =
                 [ "Dump the current ledger state of the node (Ledger.NewEpochState -- advanced command)"
                 ]
     , Just $
+        subParser "ledger-peer-snapshot" $
+          Opt.info (pQueryLedgerPeerSnapshotCmd era envCli) $
+            Opt.progDesc $
+              mconcat
+                [ "Dump the current snapshot of ledger peers."
+                , "These are the largest pools that cumulatively hold "
+                , "90% of total stake."
+                ]
+    , -- \^ TODO use bigLedgerPeerQuota from Ouroboros.Network.PeerSelection.LedgerPeers.Utils
+      -- which must be re-exposed thru cardano-api
+      Just $
         subParser "protocol-state" $
           Opt.info (pQueryProtocolStateCmd era envCli) $
             Opt.progDesc $
@@ -327,6 +353,13 @@ pQueryLedgerStateCmd era envCli =
       <$> pQueryCommons era envCli
       <*> pMaybeOutputFile
 
+pQueryLedgerPeerSnapshotCmd :: ShelleyBasedEra era -> EnvCli -> Parser (QueryCmds era)
+pQueryLedgerPeerSnapshotCmd era envCli =
+  fmap QueryLedgerPeerSnapshotCmd $
+    QueryLedgerPeerSnapshotCmdArgs
+      <$> pQueryCommons era envCli
+      <*> pMaybeOutputFile
+
 pQueryProtocolStateCmd :: ShelleyBasedEra era -> EnvCli -> Parser (QueryCmds era)
 pQueryProtocolStateCmd era envCli =
   fmap QueryProtocolStateCmd $

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

@@ -10,7 +10,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
 
@@ -19,6 +18,7 @@ module Cardano.CLI.EraBased.Run.Query
   , runQueryKesPeriodInfoCmd
   , runQueryLeadershipScheduleCmd
   , runQueryLedgerStateCmd
+  , runQueryLedgerPeerSnapshot
   , runQueryPoolStateCmd
   , runQueryProtocolParametersCmd
   , runQueryProtocolStateCmd
@@ -43,7 +43,7 @@ import qualified Cardano.Api as Api
 import qualified Cardano.Api.Consensus as Consensus
 import           Cardano.Api.Ledger (StandardCrypto, strictMaybeToMaybe)
 import qualified Cardano.Api.Ledger as L
-import           Cardano.Api.Network (Serialised (..))
+import           Cardano.Api.Network (LedgerPeerSnapshot, Serialised (..))
 import qualified Cardano.Api.Network as Consensus
 import           Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..))
 
@@ -103,6 +103,7 @@ runQueryCmds = \case
   Cmd.QueryStakeDistributionCmd args -> runQueryStakeDistributionCmd args
   Cmd.QueryStakeAddressInfoCmd args -> runQueryStakeAddressInfoCmd args
   Cmd.QueryLedgerStateCmd args -> runQueryLedgerStateCmd args
+  Cmd.QueryLedgerPeerSnapshotCmd args -> runQueryLedgerPeerSnapshot args
   Cmd.QueryStakeSnapshotCmd args -> runQueryStakeSnapshotCmd args
   Cmd.QueryProtocolStateCmd args -> runQueryProtocolStateCmd args
   Cmd.QueryUTxOCmd args -> runQueryUTxOCmd args
@@ -834,6 +835,41 @@ runQueryLedgerStateCmd
         & onLeft (left . QueryCmdAcquireFailure)
         & onLeft left
 
+runQueryLedgerPeerSnapshot
+  :: ()
+  => Cmd.QueryLedgerPeerSnapshotCmdArgs
+  -> ExceptT QueryCmdError IO ()
+runQueryLedgerPeerSnapshot
+  Cmd.QueryLedgerPeerSnapshotCmdArgs
+    { Cmd.commons =
+      Cmd.QueryCommons
+        { Cmd.nodeSocketPath
+        , Cmd.consensusModeParams
+        , Cmd.networkId
+        , Cmd.target
+        }
+    , Cmd.outFile
+    } = do
+    let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath
+
+    join $
+      lift
+        ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do
+            AnyCardanoEra era <-
+              lift queryCurrentEra
+                & onLeft (left . QueryCmdUnsupportedNtcVersion)
+
+            sbe <-
+              requireShelleyBasedEra era
+                & onNothing (left QueryCmdByronEra)
+
+            result <- easyRunQuery (queryLedgerPeerSnapshot sbe)
+
+            pure $ shelleyBasedEraConstraints sbe (writeLedgerPeerSnapshot outFile) result
+        )
+        & onLeft (left . QueryCmdAcquireFailure)
+        & onLeft left
+
 runQueryProtocolStateCmd
   :: ()
   => Cmd.QueryProtocolStateCmdArgs
@@ -1040,6 +1076,23 @@ writeLedgerState mOutFile qState@(SerialisedDebugLedgerState serLedgerState) =
         LBS.writeFile fpath $
           unSerialised serLedgerState
 
+-- | Writes JSON-encoded big ledger peer snapshot
+writeLedgerPeerSnapshot
+  :: Maybe (File () Out)
+  -> Serialised LedgerPeerSnapshot
+  -> ExceptT QueryCmdError IO ()
+writeLedgerPeerSnapshot mOutPath serBigLedgerPeerSnapshot = do
+  case decodeBigLedgerPeerSnapshot serBigLedgerPeerSnapshot of
+    Left (bs, _decoderError) ->
+      firstExceptT QueryCmdHelpersError $ pPrintCBOR bs
+    Right snapshot ->
+      case mOutPath of
+        Nothing -> liftIO . LBS.putStrLn $ Aeson.encode snapshot
+        Just fpath ->
+          firstExceptT QueryCmdWriteFileError $
+            newExceptT . writeLazyByteStringFile fpath $
+              encodePretty snapshot
+
 writeStakeSnapshots
   :: forall era ledgerera
    . ()