From 2a3098144a9d6c34237c7f7f725736fb07cdc406 Mon Sep 17 00:00:00 2001 From: EncodePanda Date: Tue, 14 Sep 2021 12:55:06 +0200 Subject: [PATCH] Add --store-ledger option to db-analyser --- .../ouroboros-consensus-cardano.cabal | 1 + .../tools/db-analyser/Analysis.hs | 91 +++++++++++++++++-- .../tools/db-analyser/Main.hs | 9 ++ .../Consensus/Storage/LedgerDB/OnDisk.hs | 3 +- 4 files changed, 94 insertions(+), 10 deletions(-) diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 1016ab177a2..b0452887ace 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -79,6 +79,7 @@ executable db-analyser , cardano-ledger-alonzo , cardano-ledger-byron , cardano-ledger-core + , cborg , containers , contra-tracer , mtl diff --git a/ouroboros-consensus-cardano/tools/db-analyser/Analysis.hs b/ouroboros-consensus-cardano/tools/db-analyser/Analysis.hs index d9751d53fe4..829845ae7ae 100644 --- a/ouroboros-consensus-cardano/tools/db-analyser/Analysis.hs +++ b/ouroboros-consensus-cardano/tools/db-analyser/Analysis.hs @@ -1,14 +1,16 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} - module Analysis ( AnalysisEnv (..) , AnalysisName (..) , runAnalysis ) where +import Codec.CBOR.Encoding (Encoding) import Control.Monad.Except import Data.List (intercalate) import qualified Data.Map.Strict as Map @@ -16,15 +18,26 @@ import Data.Word (Word16) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config +import Ouroboros.Consensus.Ledger.Abstract (tickThenApplyLedgerResult) +import Ouroboros.Consensus.Ledger.Basics (LedgerResult (..)) import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ledger.SupportsProtocol + (LedgerSupportsProtocol (..)) +import Ouroboros.Consensus.Storage.FS.API (SomeHasFS (..)) import Ouroboros.Consensus.Util.ResourceRegistry + import Ouroboros.Consensus.Storage.ChainDB (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB +import Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB + (LgrDbSerialiseConstraints) import Ouroboros.Consensus.Storage.Common (BlockComponent (..)) import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB -import Ouroboros.Consensus.Storage.Serialisation (SizeInBytes) +import Ouroboros.Consensus.Storage.LedgerDB.OnDisk (DiskSnapshot (..), + writeSnapshot) +import Ouroboros.Consensus.Storage.Serialisation (SizeInBytes, + encodeDisk) import HasAnalysis (HasAnalysis) import qualified HasAnalysis @@ -40,15 +53,23 @@ data AnalysisName = | ShowBlockTxsSize | ShowEBBs | OnlyValidation + | StoreLedgerState SlotNo deriving Show -runAnalysis :: HasAnalysis blk => AnalysisName -> Analysis blk -runAnalysis ShowSlotBlockNo = showSlotBlockNo -runAnalysis CountTxOutputs = countTxOutputs -runAnalysis ShowBlockHeaderSize = showHeaderSize -runAnalysis ShowBlockTxsSize = showBlockTxsSize -runAnalysis ShowEBBs = showEBBs -runAnalysis OnlyValidation = \_ -> return () +runAnalysis :: + forall blk . + ( LgrDbSerialiseConstraints blk + , HasAnalysis blk + , LedgerSupportsProtocol blk + ) + => AnalysisName -> Analysis blk +runAnalysis ShowSlotBlockNo = showSlotBlockNo +runAnalysis CountTxOutputs = countTxOutputs +runAnalysis ShowBlockHeaderSize = showHeaderSize +runAnalysis ShowBlockTxsSize = showBlockTxsSize +runAnalysis ShowEBBs = showEBBs +runAnalysis OnlyValidation = \_ -> return () +runAnalysis (StoreLedgerState slotNo) = storeLedgerAtSlot slotNo type Analysis blk = AnalysisEnv blk -> IO () @@ -57,6 +78,7 @@ data AnalysisEnv blk = AnalysisEnv { , initLedger :: ExtLedgerState blk , db :: Either (ImmutableDB IO blk) (ChainDB IO blk) , registry :: ResourceRegistry IO + , hasFS :: SomeHasFS IO } {------------------------------------------------------------------------------- @@ -161,6 +183,57 @@ showEBBs AnalysisEnv { db, registry } = do _otherwise -> return () -- Skip regular blocks +{------------------------------------------------------------------------------- + Analysis: show total number of tx outputs per block +-------------------------------------------------------------------------------} + +storeLedgerAtSlot :: + forall blk . + ( LgrDbSerialiseConstraints blk + , HasAnalysis blk + , LedgerSupportsProtocol blk + ) + => SlotNo -> Analysis blk +storeLedgerAtSlot slotNo (AnalysisEnv { db, registry, initLedger, cfg, hasFS }) = do + void $ processAll db registry GetBlock initLedger process + where + process :: ExtLedgerState blk -> blk -> IO (ExtLedgerState blk) + process oldLedger blk = do + let ledgerCfg = ExtLedgerCfg cfg + appliedResult = tickThenApplyLedgerResult ledgerCfg blk oldLedger + newLedger = either (error . show) lrResult $ runExcept $ appliedResult + putStrLn $ intercalate "\t" [ + show (blockNo blk) + , show (blockSlot blk) + ] + if slotNo == blockSlot blk then + storeAndReturnNewLedger blk newLedger + else return newLedger + + storeAndReturnNewLedger :: + blk + -> ExtLedgerState blk + -> IO (ExtLedgerState blk) + storeAndReturnNewLedger blk ledgerState = do + let snapshot = DiskSnapshot + (unSlotNo $ blockSlot blk) + (Just $ "db-analyser") + writeSnapshot hasFS encLedger snapshot ledgerState + putStrLn $ "storing state at " <> intercalate "\t" [ + show (blockNo blk) + , show (blockSlot blk) + , show (blockHash blk) + ] + pure ledgerState + + encLedger :: ExtLedgerState blk -> Encoding + encLedger = + let ccfg = configCodec cfg + in encodeExtLedgerState + (encodeDisk ccfg) + (encodeDisk ccfg) + (encodeDisk ccfg) + {------------------------------------------------------------------------------- Auxiliary: processing all blocks in the DB -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-cardano/tools/db-analyser/Main.hs b/ouroboros-consensus-cardano/tools/db-analyser/Main.hs index 5746d838029..6cd9b2058a2 100644 --- a/ouroboros-consensus-cardano/tools/db-analyser/Main.hs +++ b/ouroboros-consensus-cardano/tools/db-analyser/Main.hs @@ -114,9 +114,16 @@ parseAnalysis = asum [ long "show-ebbs" , help "Show all EBBs and their predecessors" ] + , storeLedgerParser , pure OnlyValidation ] +storeLedgerParser :: Parser AnalysisName +storeLedgerParser = (StoreLedgerState . SlotNo . read) <$> strOption + ( long "store-ledger" + <> metavar "SLOT NUMBER" + <> help "Store ledger state at specific slot number" ) + blockTypeParser :: Parser BlockType blockTypeParser = subparser $ mconcat [ command "byron" @@ -187,6 +194,7 @@ analyse CmdLine {..} args = , initLedger , db = Left immutableDB , registry + , hasFS = ChainDB.cdbHasFSLgrDB args' } tipPoint <- atomically $ ImmutableDB.getTipPoint immutableDB putStrLn $ "ImmutableDB tip: " ++ show tipPoint @@ -198,6 +206,7 @@ analyse CmdLine {..} args = , initLedger , db = Right chainDB , registry + , hasFS = ChainDB.cdbHasFSLgrDB args' } tipPoint <- atomically $ ChainDB.getTipPoint chainDB putStrLn $ "ChainDB tip: " ++ show tipPoint diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/OnDisk.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/OnDisk.hs index c664937b8e9..245afd9f904 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/OnDisk.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/OnDisk.hs @@ -26,12 +26,13 @@ module Ouroboros.Consensus.Storage.LedgerDB.OnDisk ( -- * Write to disk , takeSnapshot , trimSnapshots + , writeSnapshot -- * Low-level API (primarily exposed for testing) , deleteSnapshot , snapshotToFileName , snapshotToPath -- ** opaque - , DiskSnapshot + , DiskSnapshot (..) -- * Trace events , TraceEvent (..) , TraceReplayEvent (..)