Add --store-ledger option to db-analyser

IntersectMBO · Sep 21, 2021 · 2a30981 · 2a30981
1 parent 5d87eca
commit 2a30981
Show file tree

Hide file tree

Showing 4 changed files with 94 additions and 10 deletions.
diff --git 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
@@ -1,30 +1,43 @@
 {-# 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
 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
@@ -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
@@ -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 (..)