db-analyser: support full block application in --store-ledger

amesgen · amesgen · commit 44aad2a392bc · 2024-06-19T18:35:48.000+02:00
diff --git a/ouroboros-consensus-cardano/README.md b/ouroboros-consensus-cardano/README.md
@@ -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
@@ -9,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
@@ -117,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
@@ -8,10 +8,11 @@
 --                    [--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)             = intercalate "\t" $ [
@@ -272,6 +281,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
@@ -396,21 +407,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
@@ -422,16 +445,15 @@ storeLedgerStateAt slotNo (AnalysisEnv { db, registry, startFrom, cfg, limit, le
     reportProgress blk = let event = BlockSlotEvent (blockNo blk) (blockSlot 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,6 +20,6 @@ data DBAnalyserConfig = DBAnalyserConfig {
   , confLimit  :: Limit
   }
 
--- | Whether to validate the on-disk files of the ChainDB. This is completely
+-- | 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,6 +20,6 @@ data DBAnalyserConfig = DBAnalyserConfig {`
`20`	`20`	`, confLimit :: Limit`
`21`	`21`	`}`
`22`	`22`
`23`		`--- \| Whether to validate the on-disk files of the ChainDB. This is completely`
	`23`	`+-- \| The extent of the ChainDB on-disk files validation. This is completely`
`24`	`24`	`-- unrelated to validation of the ledger rules.`
`25`	`25`	`data ValidateBlocks = ValidateAllBlocks \| MinimumBlockValidation`