Skip to content

Commit

Permalink
Add ledger-peer-snapshot to query command:
Browse files Browse the repository at this point in the history
This change introduces query subcommand ledger-peer-snapshot to
serialize a snapshot of big ledger peers from the tip of the current
chain.
  • Loading branch information
crocodile-dentist authored and palas committed Jul 15, 2024
1 parent 23e4354 commit 5dd6616
Show file tree
Hide file tree
Showing 9 changed files with 682 additions and 10 deletions.
2 changes: 1 addition & 1 deletion cardano-cli/cardano-cli.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -242,7 +242,7 @@ library
ouroboros-consensus-cardano ^>=0.18,
ouroboros-consensus-protocol ^>=0.9.0.1,
ouroboros-network-api ^>=0.7.3,
ouroboros-network-protocols,
ouroboros-network-protocols ^>=0.9,
parsec,
prettyprinter,
prettyprinter-ansi-terminal,
Expand Down
459 changes: 459 additions & 0 deletions cardano-cli/cardano-cli.cabal.orig

Large diffs are not rendered by default.

13 changes: 13 additions & 0 deletions cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs
Original file line number Diff line number Diff line change
Expand Up @@ -25,6 +25,7 @@ module Cardano.CLI.EraBased.Commands.Query
, QueryNoArgCmdArgs (..)
, QueryDRepStateCmdArgs (..)
, QueryDRepStakeDistributionCmdArgs (..)
, QueryLedgerPeerSnapshotCmdArgs (..)
, renderQueryCmds
, IncludeStake (..)
)
Expand All @@ -51,6 +52,7 @@ data QueryCmds era
| QueryStakeAddressInfoCmd !QueryStakeAddressInfoCmdArgs
| QueryUTxOCmd !QueryUTxOCmdArgs
| QueryLedgerStateCmd !QueryLedgerStateCmdArgs
| QueryLedgerPeerSnapshotCmd !QueryLedgerPeerSnapshotCmdArgs
| QueryProtocolStateCmd !QueryProtocolStateCmdArgs
| QueryStakeSnapshotCmd !QueryStakeSnapshotCmdArgs
| QueryKesPeriodInfoCmd !QueryKesPeriodInfoCmdArgs
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -295,6 +306,8 @@ renderQueryCmds = \case
"query utxo"
QueryLedgerStateCmd{} ->
"query ledger-state"
QueryLedgerPeerSnapshotCmd{} ->
"query ledger-peer-snapshot"
QueryProtocolStateCmd{} ->
"query protocol-state"
QueryStakeSnapshotCmd{} ->
Expand Down
16 changes: 16 additions & 0 deletions cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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) $
Expand Down Expand Up @@ -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 $
Expand Down
48 changes: 48 additions & 0 deletions cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,7 @@ module Cardano.CLI.EraBased.Run.Query
, runQueryKesPeriodInfoCmd
, runQueryLeadershipScheduleCmd
, runQueryLedgerStateCmd
, runQueryLedgerPeerSnapshot
, runQueryPoolStateCmd
, runQueryProtocolParametersCmd
, runQueryProtocolStateCmd
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
. ()
Expand Down
11 changes: 11 additions & 0 deletions cardano-cli/src/Cardano/CLI/Legacy/Commands/Query.hs
Original file line number Diff line number Diff line change
Expand Up @@ -20,6 +20,7 @@ module Cardano.CLI.Legacy.Commands.Query
, LegacyQueryPoolStateCmdArgs (..)
, LegacyQueryTxMempoolCmdArgs (..)
, LegacyQuerySlotNumberCmdArgs (..)
, LegacyQueryLedgerPeerSnapshotCmdArgs (..)
, renderLegacyQueryCmds
)
where
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
14 changes: 14 additions & 0 deletions cardano-cli/src/Cardano/CLI/Legacy/Options.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 $
Expand Down Expand Up @@ -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 $
Expand Down
9 changes: 9 additions & 0 deletions cardano-cli/src/Cardano/CLI/Legacy/Run/Query.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
:: ()
Expand Down
Loading

0 comments on commit 5dd6616

Please sign in to comment.