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/src/Cardano/CLI/EraBased/Commands/Query.hs

@@ -25,6 +25,7 @@ module Cardano.CLI.EraBased.Commands.Query
   , QueryNoArgCmdArgs (..)
   , QueryDRepStateCmdArgs (..)
   , QueryDRepStakeDistributionCmdArgs (..)
+  , QueryLedgerPeerSnapshotCmdArgs (..)
   , renderQueryCmds
   , IncludeStake (..)
   )
@@ -51,6 +52,7 @@ data QueryCmds era
   | QueryStakeAddressInfoCmd !QueryStakeAddressInfoCmdArgs
   | QueryUTxOCmd !QueryUTxOCmdArgs
   | QueryLedgerStateCmd !QueryLedgerStateCmdArgs
+  | QueryLedgerPeerSnapshotCmd !QueryLedgerPeerSnapshotCmdArgs
   | QueryProtocolStateCmd !QueryProtocolStateCmdArgs
   | QueryStakeSnapshotCmd !QueryStakeSnapshotCmdArgs
   | QueryKesPeriodInfoCmd !QueryKesPeriodInfoCmdArgs
@@ -155,6 +157,15 @@ data QueryLedgerStateCmdArgs = QueryLedgerStateCmdArgs
   }
   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
@@ -295,6 +306,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

@@ -77,6 +77,12 @@ pQueryCmds era envCli =
               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) $
@@ -204,6 +210,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

@@ -19,6 +19,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)
@@ -112,6 +114,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
@@ -885,6 +888,41 @@ 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
@@ -1070,6 +1108,16 @@ writeLedgerState mOutFile qState@(SerialisedDebugLedgerState serLedgerState) =
         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
    . ()

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
@@ -48,6 +49,15 @@ 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
@@ -201,6 +211,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

@@ -639,6 +639,11 @@ pQueryCmds envCli =
             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 (CBOR encoded)"]
     , subParser "ledger-state" $
         Opt.info pQueryLedgerState $
           Opt.progDesc $
@@ -749,6 +754,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,6 +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
   :: ()