db-analyser: support full block application in --store-ledger (#1155)

amesgen · web-flow · commit 91d36ca0c4e5 · 2024-06-20T08:58:27.000Z
This PR adds support for full validation of blocks according to the ledger rules for `--store-ledger`. This is useful to validate changes against an existing DB. In particular, if there is an error, a ledger state just before the offending block will be stored. Also, in a separate commit, we address the third point of #35 in order to avoid users being confused when seeing both `--validate-all-blocks` and `--full-ledger-validation`.
diff --git a/ouroboros-consensus-cardano/README.md b/ouroboros-consensus-cardano/README.md
@@ -91,12 +91,12 @@ User should run this if they are dealing with a `cardano` chain.
 
 The user can limit the maximum number of blocks that db-analyser will process.
 
-### Database validation
+### Database validation, via --db-validation
 
 The tool provides two database validation policies:
 
 - `validate-all-blocks`, which will cause the tool to validate all chunks on the
-  immutable and volatile databases.
+  immutable database.
 - `minimum-block-validation`, which will cause the tool to validate only the
   most recent chunk in the immutable database.
 
@@ -127,6 +127,12 @@ Lastly the user can provide the analysis that should be run on the chain:
   slot number, it will create one on the next available slot number (and issue a
   warning about this fact).
 
+  By default, for better performance, blocks are only *re*applied, skipping eg
+  validation of signatures and Plutus scripts. If desired (eg when investigating
+  a Ledger bug), one can use `--full-ledger-validation` to also perform these
+  checks. If there is an error on block application, the previous ledger state
+  is stored.
+
 * `--count-blocks` prints out the number of blocks it saw on the chain
 
 * `--benchmark-ledger-ops` applies the main ledger calculations to each block in
diff --git a/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs b/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE CPP           #-}
+{-# LANGUAGE LambdaCase    #-}
 
 module DBAnalyser.Parsers (
     BlockType (..)
@@ -8,6 +9,7 @@ module DBAnalyser.Parsers (
   ) where
 
 import           Cardano.Crypto (RequiresNetworkMagic (..))
+import           Cardano.Tools.DBAnalyser.Analysis
 import           Cardano.Tools.DBAnalyser.Block.Byron
 import           Cardano.Tools.DBAnalyser.Block.Cardano
 import           Cardano.Tools.DBAnalyser.Block.Shelley
@@ -55,16 +57,18 @@ parseSelectDB =
 
 
 parseValidationPolicy :: Parser (Maybe ValidateBlocks)
-parseValidationPolicy = optional $ asum [
-      flag' ValidateAllBlocks $ mconcat [
-          long "validate-all-blocks"
-        , help "Validate all blocks of the Immutable DB"
-        ]
-    , flag' MinimumBlockValidation $ mconcat [
-          long "minimum-block-validation"
-        , help "Validate a minimum part of the Immutable DB"
-        ]
-    ]
+parseValidationPolicy =
+    optional $ option reader $ mconcat [
+        long "db-validation"
+      , help $ "The extent of the ChainDB on-disk files validation. This is "
+            <> "completely unrelated to validation of the ledger rules. "
+            <> "Possible values: validate-all-blocks, minimum-block-validation."
+      ]
+  where
+    reader = maybeReader $ \case
+        "validate-all-blocks"      -> Just ValidateAllBlocks
+        "minimum-block-validation" -> Just MinimumBlockValidation
+        _                          -> Nothing
 
 parseAnalysis :: Parser AnalysisName
 parseAnalysis = asum [
@@ -114,10 +118,19 @@ parseAnalysis = asum [
     ]
 
 storeLedgerParser :: Parser AnalysisName
-storeLedgerParser = (StoreLedgerStateAt . SlotNo) <$> option auto
-  (  long "store-ledger"
-  <> metavar "SLOT_NUMBER"
-  <> help "Store ledger state at specific slot number" )
+storeLedgerParser = do
+  slot <- SlotNo <$> option auto
+    (  long "store-ledger"
+    <> metavar "SLOT_NUMBER"
+    <> help "Store ledger state at specific slot number" )
+  ledgerValidation <- flag LedgerReapply LedgerApply
+    (  long "full-ledger-validation"
+    <> help (  "Use full block application while applying blocks to ledger states, "
+            <> "also validating signatures and scripts. "
+            <> "This is much slower than block reapplication (the default)."
+            )
+    )
+  pure $ StoreLedgerStateAt slot ledgerValidation
 
 checkNoThunksParser :: Parser AnalysisName
 checkNoThunksParser = CheckNoThunksEvery <$> option auto
diff --git a/ouroboros-consensus-cardano/app/db-analyser.hs b/ouroboros-consensus-cardano/app/db-analyser.hs
@@ -4,14 +4,15 @@
 
 -- | Database analysis tool.
 --
--- Usage: db-analyser --db PATH [--analyse-from SLOT_NUMBER]
---                    [--validate-all-blocks | --minimum-block-validation]
+-- Usage: db-analyser --db PATH [--verbose] [--analyse-from SLOT_NUMBER]
+--                    [--db-validation ARG]
 --                    [--show-slot-block-no | --count-tx-outputs |
 --                      --show-block-header-size | --show-block-txs-size |
---                      --show-ebbs | --store-ledger SLOT_NUMBER | --count-blocks |
---                      --checkThunks BLOCK_COUNT | --trace-ledger |
---                      --repro-mempool-and-forge INT | --benchmark-ledger-ops
---                      [--out-file FILE] |
+--                      --show-ebbs | --store-ledger SLOT_NUMBER
+--                      [--full-ledger-validation] |
+--                      --count-blocks | --checkThunks BLOCK_COUNT |
+--                      --trace-ledger | --repro-mempool-and-forge INT |
+--                      --benchmark-ledger-ops [--out-file FILE] |
 --                      --get-block-application-metrics NUM [--out-file FILE]]
 --                    [--num-blocks-to-process INT] COMMAND
 module Main (main) where
diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs
@@ -17,6 +17,7 @@ module Cardano.Tools.DBAnalyser.Analysis (
   , AnalysisName (..)
   , AnalysisResult (..)
   , AnalysisStartFrom (..)
+  , LedgerApplicationMode (..)
   , Limit (..)
   , NumberOfBlocks (..)
   , SStartFrom (..)
@@ -51,7 +52,7 @@ import           Ouroboros.Consensus.HeaderValidation (HasAnnTip (..),
                      HeaderState (..), headerStatePoint, tickHeaderState,
                      validateHeader)
 import           Ouroboros.Consensus.Ledger.Abstract (LedgerCfg, LedgerConfig,
-                     applyBlockLedgerResult, applyChainTick,
+                     applyBlockLedgerResult, applyChainTick, tickThenApply,
                      tickThenApplyLedgerResult, tickThenReapply)
 import           Ouroboros.Consensus.Ledger.Basics (LedgerResult (..),
                      LedgerState, getTipSlot)
@@ -72,6 +73,7 @@ import           Ouroboros.Consensus.Storage.LedgerDB (DiskSnapshot (..),
                      writeSnapshot)
 import           Ouroboros.Consensus.Storage.Serialisation (SizeInBytes,
                      encodeDisk)
+import           Ouroboros.Consensus.Util ((..:))
 import qualified Ouroboros.Consensus.Util.IOLike as IOLike
 import           Ouroboros.Consensus.Util.ResourceRegistry
 import           System.FS.API (SomeHasFS (..))
@@ -88,7 +90,7 @@ data AnalysisName =
   | ShowBlockTxsSize
   | ShowEBBs
   | OnlyValidation
-  | StoreLedgerStateAt SlotNo
+  | StoreLedgerStateAt SlotNo LedgerApplicationMode
   | CountBlocks
   | CheckNoThunksEvery Word64
   | TraceLedgerProcessing
@@ -109,6 +111,11 @@ data AnalysisResult =
 newtype NumberOfBlocks = NumberOfBlocks { unNumberOfBlocks :: Word64 }
   deriving (Eq, Show, Num, Read)
 
+-- | Whether to apply blocks to a ledger state via /reapplication/ (eg skipping
+-- signature checks/Plutus scripts) or full /application/ (much slower).
+data LedgerApplicationMode = LedgerReapply | LedgerApply
+  deriving (Eq, Show)
+
 runAnalysis ::
      forall blk.
      ( HasAnalysis blk
@@ -133,7 +140,7 @@ runAnalysis analysisName = case go analysisName of
     go ShowBlockTxsSize                               = mkAnalysis $ showBlockTxsSize
     go ShowEBBs                                       = mkAnalysis $ showEBBs
     go OnlyValidation                                 = mkAnalysis @StartFromPoint $ \_ -> pure Nothing
-    go (StoreLedgerStateAt slotNo)                    = mkAnalysis $ storeLedgerStateAt slotNo
+    go (StoreLedgerStateAt slotNo lgrAppMode)         = mkAnalysis $ storeLedgerStateAt slotNo lgrAppMode
     go CountBlocks                                    = mkAnalysis $ countBlocks
     go (CheckNoThunksEvery nBks)                      = mkAnalysis $ checkNoThunksEvery nBks
     go TraceLedgerProcessing                          = mkAnalysis $ traceLedgerProcessing
@@ -221,6 +228,8 @@ data TraceEvent blk =
     -- ^ triggered once during  StoreLedgerStateAt analysis,
     --   when snapshot was created in slot proceeding the
     --   requested one
+  | LedgerErrorEvent (Point blk) (ExtValidationError blk)
+    -- ^ triggered when applying a block with the given point failed
   | BlockTxSizeEvent SlotNo Int SizeInBytes
     -- ^ triggered for all blocks during ShowBlockTxsSize analysis,
     --   it holds:
@@ -241,7 +250,7 @@ data TraceEvent blk =
     --   * total time spent in the mutator when calling 'Mempool.getSnapshotFor'
     --   * total time spent in gc when calling 'Mempool.getSnapshotFor'
 
-instance HasAnalysis blk => Show (TraceEvent blk) where
+instance (HasAnalysis blk, LedgerSupportsProtocol blk) => Show (TraceEvent blk) where
   show (StartedEvent analysisName)        = "Started " <> (show analysisName)
   show DoneEvent                          = "Done"
   show (BlockSlotEvent bn sn h)           = intercalate "\t" $ [
@@ -273,6 +282,8 @@ instance HasAnalysis blk => Show (TraceEvent blk) where
   show (SnapshotWarningEvent requested actual) =
     "Snapshot was created at " <> show actual <> " " <>
     "because there was no block forged at requested " <> show requested
+  show (LedgerErrorEvent pt err) =
+    "Applying block at " <> show pt <> " failed: " <> show err
   show (BlockTxSizeEvent slot numBlocks txsSize) = intercalate "\t" [
       show slot
     , "Num txs in block = " <> show numBlocks
@@ -398,21 +409,33 @@ storeLedgerStateAt ::
      , HasAnalysis blk
      , LedgerSupportsProtocol blk
      )
-  => SlotNo -> Analysis blk StartFromLedgerState
-storeLedgerStateAt slotNo (AnalysisEnv { db, registry, startFrom, cfg, limit, ledgerDbFS, tracer }) = do
+  => SlotNo
+  -> LedgerApplicationMode
+  -> Analysis blk StartFromLedgerState
+storeLedgerStateAt slotNo ledgerAppMode env = do
     void $ processAllUntil db registry GetBlock startFrom limit initLedger process
     pure Nothing
   where
+    AnalysisEnv { db, registry, startFrom, cfg, limit, ledgerDbFS, tracer } = env
     FromLedgerState initLedger = startFrom
 
     process :: ExtLedgerState blk -> blk -> IO (NextStep, ExtLedgerState blk)
     process oldLedger blk = do
       let ledgerCfg = ExtLedgerCfg cfg
-          newLedger = tickThenReapply ledgerCfg blk oldLedger
-      when (blockSlot blk >= slotNo) $ storeLedgerState blk newLedger
-      when (blockSlot blk > slotNo) $ issueWarning blk
-      when ((unBlockNo $ blockNo blk) `mod` 1000 == 0) $ reportProgress blk
-      return (continue blk, newLedger)
+      case runExcept $ tickThenXApply ledgerCfg blk oldLedger of
+        Right newLedger -> do
+          when (blockSlot blk >= slotNo) $ storeLedgerState newLedger
+          when (blockSlot blk > slotNo) $ issueWarning blk
+          when ((unBlockNo $ blockNo blk) `mod` 1000 == 0) $ reportProgress blk
+          return (continue blk, newLedger)
+        Left err -> do
+          traceWith tracer $ LedgerErrorEvent (blockPoint blk) err
+          storeLedgerState oldLedger
+          pure (Stop, oldLedger)
+
+    tickThenXApply = case ledgerAppMode of
+        LedgerReapply -> pure ..: tickThenReapply
+        LedgerApply   -> tickThenApply
 
     continue :: blk -> NextStep
     continue blk
@@ -424,16 +447,15 @@ storeLedgerStateAt slotNo (AnalysisEnv { db, registry, startFrom, cfg, limit, le
     reportProgress blk = let event = BlockSlotEvent (blockNo blk) (blockSlot blk) (blockHash blk)
                          in traceWith tracer event
 
-    storeLedgerState ::
-         blk
-      -> ExtLedgerState blk
-      -> IO ()
-    storeLedgerState blk ledgerState = do
-      let snapshot = DiskSnapshot
-                      (unSlotNo $ blockSlot blk)
-                      (Just $ "db-analyser")
-      writeSnapshot ledgerDbFS encLedger snapshot ledgerState
-      traceWith tracer $ SnapshotStoredEvent (blockSlot blk)
+    storeLedgerState :: ExtLedgerState blk -> IO ()
+    storeLedgerState ledgerState = case pointSlot pt of
+        NotOrigin slot -> do
+          let snapshot = DiskSnapshot (unSlotNo slot) (Just "db-analyser")
+          writeSnapshot ledgerDbFS encLedger snapshot ledgerState
+          traceWith tracer $ SnapshotStoredEvent slot
+        Origin -> pure ()
+      where
+        pt = headerStatePoint $ headerState ledgerState
 
     encLedger :: ExtLedgerState blk -> Encoding
     encLedger =
diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Types.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Types.hs
@@ -20,4 +20,6 @@ data DBAnalyserConfig = DBAnalyserConfig {
   , confLimit  :: Limit
   }
 
+-- | The extent of the ChainDB on-disk files validation. This is completely
+-- unrelated to validation of the ledger rules.
 data ValidateBlocks = ValidateAllBlocks | MinimumBlockValidation

Original file line number	Diff line number	Diff line change
`@@ -20,4 +20,6 @@ data DBAnalyserConfig = DBAnalyserConfig {`
`20`	`20`	`, confLimit :: Limit`
`21`	`21`	`}`
`22`	`22`
	`23`	`+-- \| The extent of the ChainDB on-disk files validation. This is completely`
	`24`	`+-- unrelated to validation of the ledger rules.`
`23`	`25`	`data ValidateBlocks = ValidateAllBlocks \| MinimumBlockValidation`