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.
IntersectMBO · Nov 13, 2024 · 5c35ce1 · 5c35ce1
1 parent 31e628f
commit 5c35ce1
Show file tree

Hide file tree

Showing 4 changed files with 86 additions and 0 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs
@@ -26,6 +26,7 @@ module Cardano.CLI.EraBased.Commands.Query
   , QueryDRepStakeDistributionCmdArgs (..)
   , QuerySPOStakeDistributionCmdArgs (..)
   , QueryTreasuryValueCmdArgs (..)
+  , QueryLedgerPeerSnapshotCmdArgs (..)
   , renderQueryCmds
   , IncludeStake (..)
   )
@@ -65,6 +66,7 @@ data QueryCmds era
   | QuerySPOStakeDistributionCmd !(QuerySPOStakeDistributionCmdArgs era)
   | QueryCommitteeMembersStateCmd !(QueryCommitteeMembersStateCmdArgs era)
   | QueryTreasuryValueCmd !(QueryTreasuryValueCmdArgs era)
+  | QueryLedgerPeerSnapshotCmd !QueryLedgerPeerSnapshotCmdArgs
   deriving (Generic, Show)
 
 data QueryLeadershipScheduleCmdArgs = QueryLeadershipScheduleCmdArgs
@@ -148,6 +150,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
@@ -302,6 +313,8 @@ renderQueryCmds = \case
     "query utxo"
   QueryLedgerStateCmd{} ->
     "query ledger-state"
+  QueryLedgerPeerSnapshotCmd{} ->
+    "query ledger-peer-snapshot"
   QueryProtocolStateCmd{} ->
     "query protocol-state"
   QueryStakeSnapshotCmd{} ->

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs
@@ -215,6 +215,15 @@ 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) $
@@ -344,6 +353,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 :: ShelleyBasedEra era -> EnvCli -> Parser (QueryCmds era)
 pQueryProtocolStateCmd era envCli =
   fmap QueryProtocolStateCmd $

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs
@@ -18,6 +18,7 @@ module Cardano.CLI.EraBased.Run.Query
   , runQueryKesPeriodInfoCmd
   , runQueryLeadershipScheduleCmd
   , runQueryLedgerStateCmd
+  , runQueryLedgerPeerSnapshot
   , runQueryPoolStateCmd
   , runQueryProtocolParametersCmd
   , runQueryProtocolStateCmd
@@ -64,6 +65,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
 import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as Consensus
 
 import           Control.Monad (forM, forM_, join)
@@ -107,6 +109,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
@@ -848,6 +851,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
@@ -1033,6 +1071,19 @@ writeLedgerState mOutFile qState@(SerialisedDebugLedgerState serLedgerState) =
         LBS.writeFile fpath $
           unSerialised serLedgerState
 
+-- | Writes JSON-encoded big ledger peer snapshot
+writeLedgerPeerSnapshot
+  :: File () Out
+  -> Serialised LedgerPeerSnapshot
+  -> ExceptT QueryCmdError IO ()
+writeLedgerPeerSnapshot outPath serBigLedgerPeerSnapshot = do
+  snapshot <-
+    firstExceptT QueryCmdBigLedgerPeerSnapshotError $
+      hoistEither (decodeBigLedgerPeerSnapshot serBigLedgerPeerSnapshot)
+  firstExceptT QueryCmdWriteFileError $
+    newExceptT . writeLazyByteStringOutput (Just outPath) $
+      encodePretty snapshot
+
 writeStakeSnapshots
   :: forall era ledgerera
    . ()

diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdError.hs
@@ -55,6 +55,7 @@ data QueryCmdError
   | QueryCmdSPOKeyError !(FileError InputDecodeError)
   | QueryCmdCommitteeColdKeyError !(FileError InputDecodeError)
   | QueryCmdCommitteeHotKeyError !(FileError InputDecodeError)
+  | QueryCmdBigLedgerPeerSnapshotError DecoderError
   deriving Show
 
 renderQueryCmdError :: QueryCmdError -> Doc ann
@@ -115,3 +116,5 @@ renderQueryCmdError = \case
     "Error reading committee cold key: " <> prettyError e
   QueryCmdCommitteeHotKeyError e ->
     "Error reading committee hot key: " <> prettyError e
+  QueryCmdBigLedgerPeerSnapshotError decoderError ->
+    "Error decoding big ledger peer snapshot: " <> pshow decoderError