Add ledger-peer-snapshot to query command:

This change introduces query subcommand ledger-peer-snapshot to
serialize a snapshot of big ledger peers from the tip of the current
chain.

cardano-cli/CHANGELOG.md

@@ -1,5 +1,9 @@
 # Changelog for cardano-cli
 
+- added `runQueryLedgerPeerSnapshot` function to retrieve and store
+  a snapshot of big ledger peers. This function is invoked by ledger-peer-snapshot
+  subcommand of query.
+
 ## 8.22.0.0
 
 - Add `ref-script-size` query command

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

@@ -25,6 +25,7 @@ module Cardano.CLI.EraBased.Commands.Query
   , QueryNoArgCmdArgs(..)
   , QueryDRepStateCmdArgs(..)
   , QueryDRepStakeDistributionCmdArgs(..)
+  , QueryLedgerPeerSnapshotCmdArgs (..)
   , renderQueryCmds
   , IncludeStake (..)
   ) where
@@ -50,6 +51,7 @@ data QueryCmds era
   | QueryStakeAddressInfoCmd        !QueryStakeAddressInfoCmdArgs
   | QueryUTxOCmd                    !QueryUTxOCmdArgs
   | QueryLedgerStateCmd             !QueryLedgerStateCmdArgs
+  | QueryLedgerPeerSnapshotCmd      !QueryLedgerPeerSnapshotCmdArgs
   | QueryProtocolStateCmd           !QueryProtocolStateCmdArgs
   | QueryStakeSnapshotCmd           !QueryStakeSnapshotCmdArgs
   | QueryKesPeriodInfoCmd           !QueryKesPeriodInfoCmdArgs
@@ -144,6 +146,14 @@ data QueryLedgerStateCmdArgs = QueryLedgerStateCmdArgs
   , mOutFile            :: !(Maybe (File () Out))
   } deriving (Generic, Show)
 
+data QueryLedgerPeerSnapshotCmdArgs = QueryLedgerPeerSnapshotCmdArgs
+  { nodeSocketPath      :: !SocketPath
+  , consensusModeParams :: !ConsensusModeParams
+  , networkId           :: !NetworkId
+  , target              :: !(Consensus.Target ChainPoint)
+  , outFile             :: !(File () Out)
+  } deriving (Generic, Show)
+
 data QueryProtocolStateCmdArgs = QueryProtocolStateCmdArgs
   { nodeSocketPath      :: !SocketPath
   , consensusModeParams :: !ConsensusModeParams
@@ -273,6 +283,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

@@ -71,6 +71,11 @@ pQueryCmds era envCli =
         $ Opt.progDesc $ mconcat
             [ "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" ]
     , Just
         $ subParser "protocol-state"
         $ Opt.info (pQueryProtocolStateCmd era envCli)
@@ -194,6 +199,16 @@ pQueryLedgerStateCmd era envCli =
       <*> pTarget era
       <*> pMaybeOutputFile
 
+pQueryLedgerPeerSnapshotCmd :: CardanoEra era -> EnvCli -> Parser (QueryCmds era)
+pQueryLedgerPeerSnapshotCmd era envCli =
+  fmap QueryLedgerPeerSnapshotCmd $
+    QueryLedgerPeerSnapshotCmdArgs
+      <$> pSocketPath envCli
+      <*> pConsensusModeParams
+      <*> pNetworkId envCli
+      <*> pTarget era
+      <*> pOutputFile
+
 pQueryProtocolStateCmd :: CardanoEra era -> EnvCli -> Parser (QueryCmds era)
 pQueryProtocolStateCmd era envCli =
   fmap QueryProtocolStateCmd $

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

@@ -20,6 +20,7 @@ module Cardano.CLI.EraBased.Run.Query
   , runQueryKesPeriodInfoCmd
   , runQueryLeadershipScheduleCmd
   , runQueryLedgerStateCmd
+  , runQueryLedgerPeerSnapshot
   , runQueryPoolStateCmd
   , runQueryProtocolParametersCmd
   , runQueryProtocolStateCmd
@@ -66,6 +67,7 @@ import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus
 import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus
 import           Ouroboros.Consensus.Protocol.TPraos (StandardCrypto)
 import           Ouroboros.Network.Block (Serialised (..))
+import           Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot)
 import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as Consensus
 
 import           Control.Monad (forM, forM_, join)
@@ -113,6 +115,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
@@ -795,6 +798,36 @@ runQueryLedgerStateCmd
     & onLeft (left . QueryCmdAcquireFailure)
     & onLeft left
 
+runQueryLedgerPeerSnapshot :: ()
+  => Cmd.QueryLedgerPeerSnapshotCmdArgs
+  -> ExceptT QueryCmdError IO ()
+runQueryLedgerPeerSnapshot
+    Cmd.QueryLedgerPeerSnapshotCmdArgs
+    { 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 <- lift (queryLedgerPeerSnapshot sbe)
+          & onLeft (left . QueryCmdUnsupportedNtcVersion)
+          & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError)
+
+        pure $ shelleyBasedEraConstraints sbe (writeLedgerPeerSnapshot outFile) result
+    )
+    & onLeft (left . QueryCmdAcquireFailure)
+    & onLeft left
+
 runQueryProtocolStateCmd :: ()
   => Cmd.QueryProtocolStateCmdArgs
   -> ExceptT QueryCmdError IO ()
@@ -960,6 +993,14 @@ writeLedgerState mOutFile qState@(SerialisedDebugLedgerState serLedgerState) =
       handleIOExceptT (QueryCmdWriteFileError . FileIOError fpath)
         $ LBS.writeFile fpath $ unSerialised serLedgerState
 
+-- | Writes a snapshot of peers from the ledger out to a file
+writeLedgerPeerSnapshot :: File () Out
+                        -> Serialised LedgerPeerSnapshot
+                        -> ExceptT QueryCmdError IO ()
+writeLedgerPeerSnapshot (File outPath) (Serialised bytes) = 
+  handleIOExceptT (QueryCmdWriteFileError . FileIOError outPath)
+                  (LBS.writeFile outPath bytes)
+
 writeStakeSnapshots :: forall era ledgerera. ()
   => ShelleyLedgerEra era ~ ledgerera
   => L.EraCrypto ledgerera ~ StandardCrypto

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

@@ -20,6 +20,7 @@ module Cardano.CLI.Legacy.Commands.Query
   , LegacyQueryPoolStateCmdArgs (..)
   , LegacyQueryTxMempoolCmdArgs (..)
   , LegacyQuerySlotNumberCmdArgs (..)
+  , LegacyQueryLedgerPeerSnapshotCmdArgs (..)
   , renderLegacyQueryCmds
   ) where
 
@@ -47,8 +48,16 @@ data LegacyQueryCmds
   | QueryPoolStateCmd           !LegacyQueryPoolStateCmdArgs
   | QueryTxMempoolCmd           !LegacyQueryTxMempoolCmdArgs
   | QuerySlotNumberCmd          !LegacyQuerySlotNumberCmdArgs
+  | QueryLedgerPeerSnapshotCmd  !LegacyQueryLedgerPeerSnapshotCmdArgs
   deriving (Generic, Show)
 
+data LegacyQueryLedgerPeerSnapshotCmdArgs = LegacyQueryLedgerPeerSnapshotCmdArgs
+  { nodeSocketPath      :: !SocketPath
+  , consensusModeParams :: !ConsensusModeParams
+  , networkId           :: !NetworkId
+  , outFile             :: !(File () Out)
+  } deriving (Generic, Show)
+
 data LegacyQueryLeadershipScheduleCmdArgs = LegacyQueryLeadershipScheduleCmdArgs
   { nodeSocketPath      :: !SocketPath
   , consensusModeParams :: !ConsensusModeParams
@@ -184,6 +193,7 @@ renderLegacyQueryCmds = \case
   QueryPoolStateCmd {} -> "query pool-state"
   QueryTxMempoolCmd (LegacyQueryTxMempoolCmdArgs _ _ _ txMempoolQuery _) -> "query tx-mempool" <> renderTxMempoolQuery txMempoolQuery
   QuerySlotNumberCmd {} -> "query slot-number"
+  QueryLedgerPeerSnapshotCmd {} -> "query ledger-peer-snapshot"
   where
     renderTxMempoolQuery = \case
       TxMempoolQueryTxExists tx -> "tx-exists " <> serialiseToRawBytesHexText tx

cardano-cli/src/Cardano/CLI/Legacy/Options.hs

@@ -587,6 +587,10 @@ pQueryCmds envCli =
         $ Opt.progDesc $ mconcat
             [ "Get a portion of the current UTxO: by tx in, by address or the whole."
             ]
+    , subParser "ledger-peer-snapshot"
+        $ Opt.info pQueryLedgerSnapshot
+        $ Opt.progDesc $ mconcat
+            [ "Dump the current ledger peer snapshot" ]
     , subParser "ledger-state"
         $ Opt.info pQueryLedgerState
         $ Opt.progDesc $ mconcat
@@ -692,6 +696,15 @@ pQueryCmds envCli =
         <*> pNetworkId envCli
         <*> pMaybeOutputFile
 
+    pQueryLedgerSnapshot :: Parser LegacyQueryCmds
+    pQueryLedgerSnapshot =
+      fmap QueryLedgerPeerSnapshotCmd $
+        LegacyQueryLedgerPeerSnapshotCmdArgs
+        <$> pSocketPath envCli
+        <*> pConsensusModeParams
+        <*> pNetworkId envCli
+        <*> pOutputFile        
+
     pQueryProtocolState :: Parser LegacyQueryCmds
     pQueryProtocolState =
       fmap QueryProtocolStateCmd $

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

@@ -33,7 +33,15 @@ runLegacyQueryCmds = \case
   Cmd.QueryPoolStateCmd           args -> runLegacyQueryPoolStateCmd args
   Cmd.QueryTxMempoolCmd           args -> runLegacyQueryTxMempoolCmd args
   Cmd.QuerySlotNumberCmd          args -> runLegacyQuerySlotNumberCmd args
+  Cmd.QueryLedgerPeerSnapshotCmd  args -> runLegacyQueryPeerSnapshot args
 
+runLegacyQueryPeerSnapshot :: ()
+  => Cmd.LegacyQueryLedgerPeerSnapshotCmdArgs
+  -> ExceptT QueryCmdError IO ()
+runLegacyQueryPeerSnapshot Cmd.LegacyQueryLedgerPeerSnapshotCmdArgs {..} =
+  EraBased.runQueryLedgerPeerSnapshot
+    EraBased.QueryLedgerPeerSnapshotCmdArgs {target = Consensus.VolatileTip, ..}
+
 runLegacyQueryProtocolParametersCmd :: ()
   => Cmd.LegacyQueryProtocolParametersCmdArgs
   -> ExceptT QueryCmdError IO ()