1- {-# LANGUAGE BangPatterns #-}
2- {-# LANGUAGE BlockArguments #-}
3- {-# LANGUAGE DataKinds #-}
4- {-# LANGUAGE FlexibleContexts #-}
5- {-# LANGUAGE GADTs #-}
6- {-# LANGUAGE GeneralisedNewtypeDeriving #-}
7- {-# LANGUAGE LambdaCase #-}
8- {-# LANGUAGE NamedFieldPuns #-}
9- {-# LANGUAGE OverloadedStrings #-}
10- {-# LANGUAGE ScopedTypeVariables #-}
11- {-# LANGUAGE TupleSections #-}
12- {-# LANGUAGE TypeApplications #-}
13- {-# LANGUAGE TypeFamilies #-}
1+ {-# LANGUAGE BangPatterns #-}
2+ {-# LANGUAGE BlockArguments #-}
3+ {-# LANGUAGE DataKinds #-}
4+ {-# LANGUAGE FlexibleContexts #-}
5+ {-# LANGUAGE GADTs #-}
6+ {-# LANGUAGE LambdaCase #-}
7+ {-# LANGUAGE NamedFieldPuns #-}
8+ {-# LANGUAGE OverloadedStrings #-}
9+ {-# LANGUAGE ScopedTypeVariables #-}
10+ {-# LANGUAGE TupleSections #-}
11+ {-# LANGUAGE TypeApplications #-}
12+ {-# LANGUAGE TypeFamilies #-}
1413
1514module Cardano.Tools.DBAnalyser.Analysis (
1615 AnalysisEnv (.. )
@@ -33,6 +32,7 @@ import Cardano.Tools.DBAnalyser.CSV (computeAndWriteLine,
3332 writeHeaderLine )
3433import Cardano.Tools.DBAnalyser.HasAnalysis (HasAnalysis )
3534import qualified Cardano.Tools.DBAnalyser.HasAnalysis as HasAnalysis
35+ import Cardano.Tools.DBAnalyser.Types
3636import Codec.CBOR.Encoding (Encoding )
3737import Control.Monad (unless , void , when )
3838import Control.Monad.Except (runExcept )
@@ -49,11 +49,12 @@ import Ouroboros.Consensus.Block
4949import Ouroboros.Consensus.Config
5050import Ouroboros.Consensus.Forecast (forecastFor )
5151import Ouroboros.Consensus.HeaderValidation (HasAnnTip (.. ),
52- HeaderState (.. ), headerStatePoint , tickHeaderState ,
53- validateHeader )
54- import Ouroboros.Consensus.Ledger.Abstract (LedgerCfg , LedgerConfig ,
55- applyBlockLedgerResult , applyChainTick , tickThenApply ,
56- tickThenApplyLedgerResult , tickThenReapply )
52+ HeaderState (.. ), headerStatePoint , revalidateHeader ,
53+ tickHeaderState , validateHeader )
54+ import Ouroboros.Consensus.Ledger.Abstract
55+ (ApplyBlock (reapplyBlockLedgerResult ), LedgerCfg ,
56+ LedgerConfig , applyBlockLedgerResult , applyChainTick ,
57+ tickThenApply , tickThenApplyLedgerResult , tickThenReapply )
5758import Ouroboros.Consensus.Ledger.Basics (LedgerResult (.. ),
5859 LedgerState , getTipSlot )
5960import Ouroboros.Consensus.Ledger.Extended
@@ -83,39 +84,6 @@ import qualified System.IO as IO
8384 Run the requested analysis
8485-------------------------------------------------------------------------------}
8586
86- data AnalysisName =
87- ShowSlotBlockNo
88- | CountTxOutputs
89- | ShowBlockHeaderSize
90- | ShowBlockTxsSize
91- | ShowEBBs
92- | OnlyValidation
93- | StoreLedgerStateAt SlotNo LedgerApplicationMode
94- | CountBlocks
95- | CheckNoThunksEvery Word64
96- | TraceLedgerProcessing
97- | BenchmarkLedgerOps (Maybe FilePath )
98- | ReproMempoolAndForge Int
99- -- | Compute different block application metrics every 'NumberOfBlocks'.
100- --
101- -- The metrics will be written to the provided file path, or to
102- -- the standard output if no file path is specified.
103- | GetBlockApplicationMetrics NumberOfBlocks (Maybe FilePath )
104- deriving Show
105-
106- data AnalysisResult =
107- ResultCountBlock Int
108- | ResultMaxHeaderSize Word16
109- deriving (Eq , Show )
110-
111- newtype NumberOfBlocks = NumberOfBlocks { unNumberOfBlocks :: Word64 }
112- deriving (Eq , Show , Num , Read )
113-
114- -- | Whether to apply blocks to a ledger state via /reapplication/ (eg skipping
115- -- signature checks/Plutus scripts) or full /application/ (much slower).
116- data LedgerApplicationMode = LedgerReapply | LedgerApply
117- deriving (Eq , Show )
118-
11987runAnalysis ::
12088 forall blk .
12189 ( HasAnalysis blk
@@ -145,7 +113,7 @@ runAnalysis analysisName = case go analysisName of
145113 go (CheckNoThunksEvery nBks) = mkAnalysis $ checkNoThunksEvery nBks
146114 go TraceLedgerProcessing = mkAnalysis $ traceLedgerProcessing
147115 go (ReproMempoolAndForge nBks) = mkAnalysis $ reproMempoolForge nBks
148- go (BenchmarkLedgerOps mOutfile) = mkAnalysis $ benchmarkLedgerOps mOutfile
116+ go (BenchmarkLedgerOps mOutfile lgrAppMode ) = mkAnalysis $ benchmarkLedgerOps mOutfile lgrAppMode
149117 go (GetBlockApplicationMetrics nrBlocks mOutfile) = mkAnalysis $ getBlockApplicationMetrics nrBlocks mOutfile
150118
151119 mkAnalysis ::
@@ -569,13 +537,15 @@ benchmarkLedgerOps ::
569537 ( HasAnalysis blk
570538 , LedgerSupportsProtocol blk
571539 )
572- => Maybe FilePath -> Analysis blk StartFromLedgerState
573- benchmarkLedgerOps mOutfile AnalysisEnv {db, registry, startFrom, cfg, limit} = do
540+ => Maybe FilePath
541+ -> LedgerApplicationMode
542+ -> Analysis blk StartFromLedgerState
543+ benchmarkLedgerOps mOutfile ledgerAppMode AnalysisEnv {db, registry, startFrom, cfg, limit} = do
574544 -- We default to CSV when the no output file is provided (and thus the results are output to stdout).
575545 outFormat <- F. getOutputFormat mOutfile
576546
577547 withFile mOutfile $ \ outFileHandle -> do
578- F. writeMetadata outFileHandle outFormat
548+ F. writeMetadata outFileHandle outFormat ledgerAppMode
579549 F. writeHeader outFileHandle outFormat
580550
581551 void $ processAll db registry GetBlock startFrom limit initLedger (process outFileHandle outFormat)
@@ -672,10 +642,13 @@ benchmarkLedgerOps mOutfile AnalysisEnv {db, registry, startFrom, cfg, limit} =
672642 LedgerView (BlockProtocol blk )
673643 -> Ticked (HeaderState blk )
674644 -> IO (HeaderState blk )
675- applyTheHeader ledgerView tickedHeaderState = do
645+ applyTheHeader ledgerView tickedHeaderState = case ledgerAppMode of
646+ LedgerApply ->
676647 case runExcept $ validateHeader cfg ledgerView (getHeader blk) tickedHeaderState of
677648 Left err -> fail $ " benchmark doesn't support invalid headers: " <> show rp <> " " <> show err
678649 Right x -> pure x
650+ LedgerReapply ->
651+ pure $! revalidateHeader cfg ledgerView (getHeader blk) tickedHeaderState
679652
680653 tickTheLedgerState ::
681654 SlotNo
@@ -687,10 +660,13 @@ benchmarkLedgerOps mOutfile AnalysisEnv {db, registry, startFrom, cfg, limit} =
687660 applyTheBlock ::
688661 Ticked (LedgerState blk )
689662 -> IO (LedgerState blk )
690- applyTheBlock tickedLedgerSt = do
663+ applyTheBlock tickedLedgerSt = case ledgerAppMode of
664+ LedgerApply ->
691665 case runExcept (lrResult <$> applyBlockLedgerResult lcfg blk tickedLedgerSt) of
692666 Left err -> fail $ " benchmark doesn't support invalid blocks: " <> show rp <> " " <> show err
693667 Right x -> pure x
668+ LedgerReapply ->
669+ pure $! lrResult $ reapplyBlockLedgerResult lcfg blk tickedLedgerSt
694670
695671withFile :: Maybe FilePath -> (IO. Handle -> IO r ) -> IO r
696672withFile (Just outfile) = IO. withFile outfile IO. WriteMode
@@ -877,8 +853,6 @@ reproMempoolForge numBlks env = do
877853 Auxiliary: processing all blocks in the DB
878854-------------------------------------------------------------------------------}
879855
880- data Limit = Limit Int | Unlimited
881-
882856decreaseLimit :: Limit -> Maybe Limit
883857decreaseLimit Unlimited = Just Unlimited
884858decreaseLimit (Limit 0 ) = Nothing
0 commit comments