{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.Tools.DBAnalyser.Analysis (
    AnalysisEnv (..)
  , AnalysisName (..)
  , AnalysisResult (..)
  , AnalysisStartFrom (..)
  , LedgerApplicationMode (..)
  , Limit (..)
  , NumberOfBlocks (..)
  , SStartFrom (..)
  , SomeAnalysis (..)
  , StartFrom (..)
  , runAnalysis
  ) where

import qualified Cardano.Slotting.Slot as Slotting
import qualified Cardano.Tools.DBAnalyser.Analysis.BenchmarkLedgerOps.FileWriting as F
import qualified Cardano.Tools.DBAnalyser.Analysis.BenchmarkLedgerOps.SlotDataPoint as DP
import           Cardano.Tools.DBAnalyser.CSV (computeAndWriteLine,
                     writeHeaderLine)
import           Cardano.Tools.DBAnalyser.HasAnalysis (HasAnalysis)
import qualified Cardano.Tools.DBAnalyser.HasAnalysis as HasAnalysis
import           Cardano.Tools.DBAnalyser.Types
import           Control.Monad (unless, void, when)
import           Control.Monad.Except (runExcept)
import           Control.ResourceRegistry
import           Control.Tracer (Tracer (..), nullTracer, traceWith)
import           Data.Int (Int64)
import           Data.List (intercalate)
import qualified Data.Map.Strict as Map
import           Data.Singletons
import           Data.Word (Word16, Word32, Word64)
import qualified Debug.Trace as Debug
import qualified GHC.Stats as GC
import           NoThunks.Class (noThunks)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Forecast (forecastFor)
import           Ouroboros.Consensus.HeaderValidation (HasAnnTip (..),
                     HeaderState (..), headerStatePoint, revalidateHeader,
                     tickHeaderState, validateHeader)
import           Ouroboros.Consensus.Ledger.Abstract
                     (ApplyBlock (getBlockKeySets, reapplyBlockLedgerResult),
                     applyBlockLedgerResult, tickThenApply,
                     tickThenApplyLedgerResult, tickThenReapply)
import           Ouroboros.Consensus.Ledger.Basics
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.SupportsMempool
                     (LedgerSupportsMempool)
import qualified Ouroboros.Consensus.Ledger.SupportsMempool as LedgerSupportsMempool
import           Ouroboros.Consensus.Ledger.SupportsProtocol
                     (LedgerSupportsProtocol (..))
import           Ouroboros.Consensus.Ledger.Tables.Utils
import qualified Ouroboros.Consensus.Mempool as Mempool
import           Ouroboros.Consensus.Protocol.Abstract (LedgerView)
import           Ouroboros.Consensus.Storage.Common (BlockComponent (..))
import           Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB)
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
import qualified Ouroboros.Consensus.Util.IOLike as IOLike
import           Ouroboros.Network.Protocol.LocalStateQuery.Type
import           Ouroboros.Network.SizeInBytes
import qualified System.IO as IO

{-------------------------------------------------------------------------------
  Run the requested analysis
-------------------------------------------------------------------------------}

runAnalysis ::
     forall blk.
     ( HasAnalysis blk
     , LedgerSupportsMempool.HasTxId (LedgerSupportsMempool.GenTx blk)
     , LedgerSupportsMempool.HasTxs blk
     , LedgerSupportsMempool blk
     , LedgerSupportsProtocol blk
     , CanStowLedgerTables (LedgerState blk)
     )
  => AnalysisName -> SomeAnalysis blk
runAnalysis :: forall blk.
(HasAnalysis blk, HasTxId (GenTx blk), HasTxs blk,
 LedgerSupportsMempool blk, LedgerSupportsProtocol blk,
 CanStowLedgerTables (LedgerState blk)) =>
AnalysisName -> SomeAnalysis blk
runAnalysis AnalysisName
analysisName = case AnalysisName -> SomeAnalysis blk
go AnalysisName
analysisName of
    SomeAnalysis Proxy startFrom
p Analysis blk startFrom
analysis -> Proxy startFrom -> Analysis blk startFrom -> SomeAnalysis blk
forall blk (startFrom :: StartFrom).
SingI startFrom =>
Proxy startFrom -> Analysis blk startFrom -> SomeAnalysis blk
SomeAnalysis Proxy startFrom
p (Analysis blk startFrom -> SomeAnalysis blk)
-> Analysis blk startFrom -> SomeAnalysis blk
forall a b. (a -> b) -> a -> b
$ \env :: AnalysisEnv IO blk startFrom
env@AnalysisEnv{ Tracer IO (TraceEvent blk)
tracer :: Tracer IO (TraceEvent blk)
tracer :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Tracer m (TraceEvent blk)
tracer } -> do
      Tracer IO (TraceEvent blk) -> TraceEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (TraceEvent blk)
tracer (AnalysisName -> TraceEvent blk
forall blk. AnalysisName -> TraceEvent blk
StartedEvent AnalysisName
analysisName)
      result <- Analysis blk startFrom
analysis AnalysisEnv IO blk startFrom
env
      traceWith tracer DoneEvent
      pure result
  where
    go :: AnalysisName -> SomeAnalysis blk
    go :: AnalysisName -> SomeAnalysis blk
go AnalysisName
ShowSlotBlockNo                                = Analysis blk 'StartFromPoint -> SomeAnalysis blk
forall (startFrom :: StartFrom).
SingI startFrom =>
Analysis blk startFrom -> SomeAnalysis blk
mkAnalysis (Analysis blk 'StartFromPoint -> SomeAnalysis blk)
-> Analysis blk 'StartFromPoint -> SomeAnalysis blk
forall a b. (a -> b) -> a -> b
$ Analysis blk 'StartFromPoint
forall blk. HasAnalysis blk => Analysis blk 'StartFromPoint
showSlotBlockNo
    go AnalysisName
CountTxOutputs                                 = Analysis blk 'StartFromPoint -> SomeAnalysis blk
forall (startFrom :: StartFrom).
SingI startFrom =>
Analysis blk startFrom -> SomeAnalysis blk
mkAnalysis (Analysis blk 'StartFromPoint -> SomeAnalysis blk)
-> Analysis blk 'StartFromPoint -> SomeAnalysis blk
forall a b. (a -> b) -> a -> b
$ Analysis blk 'StartFromPoint
forall blk. HasAnalysis blk => Analysis blk 'StartFromPoint
countTxOutputs
    go AnalysisName
ShowBlockHeaderSize                            = Analysis blk 'StartFromPoint -> SomeAnalysis blk
forall (startFrom :: StartFrom).
SingI startFrom =>
Analysis blk startFrom -> SomeAnalysis blk
mkAnalysis (Analysis blk 'StartFromPoint -> SomeAnalysis blk)
-> Analysis blk 'StartFromPoint -> SomeAnalysis blk
forall a b. (a -> b) -> a -> b
$ Analysis blk 'StartFromPoint
forall blk. HasAnalysis blk => Analysis blk 'StartFromPoint
showHeaderSize
    go AnalysisName
ShowBlockTxsSize                               = Analysis blk 'StartFromPoint -> SomeAnalysis blk
forall (startFrom :: StartFrom).
SingI startFrom =>
Analysis blk startFrom -> SomeAnalysis blk
mkAnalysis (Analysis blk 'StartFromPoint -> SomeAnalysis blk)
-> Analysis blk 'StartFromPoint -> SomeAnalysis blk
forall a b. (a -> b) -> a -> b
$ Analysis blk 'StartFromPoint
forall blk. HasAnalysis blk => Analysis blk 'StartFromPoint
showBlockTxsSize
    go AnalysisName
ShowEBBs                                       = Analysis blk 'StartFromPoint -> SomeAnalysis blk
forall (startFrom :: StartFrom).
SingI startFrom =>
Analysis blk startFrom -> SomeAnalysis blk
mkAnalysis (Analysis blk 'StartFromPoint -> SomeAnalysis blk)
-> Analysis blk 'StartFromPoint -> SomeAnalysis blk
forall a b. (a -> b) -> a -> b
$ Analysis blk 'StartFromPoint
forall blk. HasAnalysis blk => Analysis blk 'StartFromPoint
showEBBs
    go AnalysisName
OnlyValidation                                 = forall (startFrom :: StartFrom).
SingI startFrom =>
Analysis blk startFrom -> SomeAnalysis blk
mkAnalysis @StartFromPoint (Analysis blk 'StartFromPoint -> SomeAnalysis blk)
-> Analysis blk 'StartFromPoint -> SomeAnalysis blk
forall a b. (a -> b) -> a -> b
$ \AnalysisEnv IO blk 'StartFromPoint
_ -> Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AnalysisResult
forall a. Maybe a
Nothing
    go (StoreLedgerStateAt SlotNo
slotNo LedgerApplicationMode
lgrAppMode)         = Analysis blk 'StartFromLedgerState -> SomeAnalysis blk
forall (startFrom :: StartFrom).
SingI startFrom =>
Analysis blk startFrom -> SomeAnalysis blk
mkAnalysis (Analysis blk 'StartFromLedgerState -> SomeAnalysis blk)
-> Analysis blk 'StartFromLedgerState -> SomeAnalysis blk
forall a b. (a -> b) -> a -> b
$ SlotNo
-> LedgerApplicationMode -> Analysis blk 'StartFromLedgerState
forall blk.
(LedgerSupportsProtocol blk, HasAnalysis blk) =>
SlotNo
-> LedgerApplicationMode -> Analysis blk 'StartFromLedgerState
storeLedgerStateAt SlotNo
slotNo LedgerApplicationMode
lgrAppMode
    go AnalysisName
CountBlocks                                    = Analysis blk 'StartFromPoint -> SomeAnalysis blk
forall (startFrom :: StartFrom).
SingI startFrom =>
Analysis blk startFrom -> SomeAnalysis blk
mkAnalysis (Analysis blk 'StartFromPoint -> SomeAnalysis blk)
-> Analysis blk 'StartFromPoint -> SomeAnalysis blk
forall a b. (a -> b) -> a -> b
$ Analysis blk 'StartFromPoint
forall blk. HasAnalysis blk => Analysis blk 'StartFromPoint
countBlocks
    go (CheckNoThunksEvery Word64
nBks)                      = Analysis blk 'StartFromLedgerState -> SomeAnalysis blk
forall (startFrom :: StartFrom).
SingI startFrom =>
Analysis blk startFrom -> SomeAnalysis blk
mkAnalysis (Analysis blk 'StartFromLedgerState -> SomeAnalysis blk)
-> Analysis blk 'StartFromLedgerState -> SomeAnalysis blk
forall a b. (a -> b) -> a -> b
$ Word64 -> Analysis blk 'StartFromLedgerState
forall blk.
(HasAnalysis blk, LedgerSupportsProtocol blk,
 CanStowLedgerTables (LedgerState blk)) =>
Word64 -> Analysis blk 'StartFromLedgerState
checkNoThunksEvery Word64
nBks
    go AnalysisName
TraceLedgerProcessing                          = Analysis blk 'StartFromLedgerState -> SomeAnalysis blk
forall (startFrom :: StartFrom).
SingI startFrom =>
Analysis blk startFrom -> SomeAnalysis blk
mkAnalysis (Analysis blk 'StartFromLedgerState -> SomeAnalysis blk)
-> Analysis blk 'StartFromLedgerState -> SomeAnalysis blk
forall a b. (a -> b) -> a -> b
$ Analysis blk 'StartFromLedgerState
forall blk.
(HasAnalysis blk, LedgerSupportsProtocol blk) =>
Analysis blk 'StartFromLedgerState
traceLedgerProcessing
    go (ReproMempoolAndForge Int
nBks)                    = Analysis blk 'StartFromLedgerState -> SomeAnalysis blk
forall (startFrom :: StartFrom).
SingI startFrom =>
Analysis blk startFrom -> SomeAnalysis blk
mkAnalysis (Analysis blk 'StartFromLedgerState -> SomeAnalysis blk)
-> Analysis blk 'StartFromLedgerState -> SomeAnalysis blk
forall a b. (a -> b) -> a -> b
$ Int -> Analysis blk 'StartFromLedgerState
forall blk.
(HasAnalysis blk, HasTxId (GenTx blk), HasTxs blk,
 LedgerSupportsMempool blk, LedgerSupportsProtocol blk) =>
Int -> Analysis blk 'StartFromLedgerState
reproMempoolForge Int
nBks
    go (BenchmarkLedgerOps Maybe FilePath
mOutfile LedgerApplicationMode
lgrAppMode)       = Analysis blk 'StartFromLedgerState -> SomeAnalysis blk
forall (startFrom :: StartFrom).
SingI startFrom =>
Analysis blk startFrom -> SomeAnalysis blk
mkAnalysis (Analysis blk 'StartFromLedgerState -> SomeAnalysis blk)
-> Analysis blk 'StartFromLedgerState -> SomeAnalysis blk
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> LedgerApplicationMode -> Analysis blk 'StartFromLedgerState
forall blk.
(LedgerSupportsProtocol blk, HasAnalysis blk) =>
Maybe FilePath
-> LedgerApplicationMode -> Analysis blk 'StartFromLedgerState
benchmarkLedgerOps Maybe FilePath
mOutfile LedgerApplicationMode
lgrAppMode
    go (GetBlockApplicationMetrics NumberOfBlocks
nrBlocks Maybe FilePath
mOutfile) = Analysis blk 'StartFromLedgerState -> SomeAnalysis blk
forall (startFrom :: StartFrom).
SingI startFrom =>
Analysis blk startFrom -> SomeAnalysis blk
mkAnalysis (Analysis blk 'StartFromLedgerState -> SomeAnalysis blk)
-> Analysis blk 'StartFromLedgerState -> SomeAnalysis blk
forall a b. (a -> b) -> a -> b
$ NumberOfBlocks
-> Maybe FilePath -> Analysis blk 'StartFromLedgerState
forall blk.
(HasAnalysis blk, LedgerSupportsProtocol blk) =>
NumberOfBlocks
-> Maybe FilePath -> Analysis blk 'StartFromLedgerState
getBlockApplicationMetrics NumberOfBlocks
nrBlocks Maybe FilePath
mOutfile

    mkAnalysis ::
         forall startFrom. SingI startFrom
      => Analysis blk startFrom -> SomeAnalysis blk
    mkAnalysis :: forall (startFrom :: StartFrom).
SingI startFrom =>
Analysis blk startFrom -> SomeAnalysis blk
mkAnalysis = Proxy startFrom -> Analysis blk startFrom -> SomeAnalysis blk
forall blk (startFrom :: StartFrom).
SingI startFrom =>
Proxy startFrom -> Analysis blk startFrom -> SomeAnalysis blk
SomeAnalysis (forall {k} (t :: k). Proxy t
forall (t :: StartFrom). Proxy t
Proxy @startFrom)

type Analysis blk startFrom = AnalysisEnv IO blk startFrom -> IO (Maybe AnalysisResult)

data SomeAnalysis blk =
       forall startFrom. SingI startFrom
    => SomeAnalysis (Proxy startFrom) (Analysis blk startFrom)

data AnalysisEnv m blk startFrom = AnalysisEnv {
      forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> TopLevelConfig blk
cfg       :: TopLevelConfig blk
    , forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom m blk startFrom
startFrom :: AnalysisStartFrom m blk startFrom
    , forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ImmutableDB IO blk
db        :: ImmutableDB IO blk
    , forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ResourceRegistry IO
registry  :: ResourceRegistry IO
    , forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Limit
limit     :: Limit
    , forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Tracer m (TraceEvent blk)
tracer    :: Tracer m (TraceEvent blk)
    }

-- | Whether the db-analyser pass needs access to a ledger state.
data StartFrom = StartFromPoint | StartFromLedgerState

data SStartFrom startFrom where
  SStartFromPoint       :: SStartFrom StartFromPoint
  SStartFromLedgerState :: SStartFrom StartFromLedgerState

type instance Sing = SStartFrom
instance SingI StartFromPoint       where sing :: Sing 'StartFromPoint
sing = Sing 'StartFromPoint
SStartFrom 'StartFromPoint
SStartFromPoint
instance SingI StartFromLedgerState where sing :: Sing 'StartFromLedgerState
sing = Sing 'StartFromLedgerState
SStartFrom 'StartFromLedgerState
SStartFromLedgerState

data AnalysisStartFrom m blk startFrom where
  FromPoint ::
    Point blk -> AnalysisStartFrom m blk StartFromPoint
  FromLedgerState ::
    LedgerDB.LedgerDB' m blk -> LedgerDB.TestInternals' m blk -> AnalysisStartFrom m blk StartFromLedgerState

startFromPoint :: (IOLike.IOLike m, HasAnnTip blk) => AnalysisStartFrom m blk startFrom -> m (Point blk)
startFromPoint :: forall (m :: * -> *) blk (startFrom :: StartFrom).
(IOLike m, HasAnnTip blk) =>
AnalysisStartFrom m blk startFrom -> m (Point blk)
startFromPoint = \case
  FromPoint Point blk
pt         -> Point blk -> m (Point blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Point blk
pt
  FromLedgerState LedgerDB' m blk
st TestInternals' m blk
_ -> HeaderState blk -> Point blk
forall blk. HasAnnTip blk => HeaderState blk -> Point blk
headerStatePoint (HeaderState blk -> Point blk)
-> (ExtLedgerState blk EmptyMK -> HeaderState blk)
-> ExtLedgerState blk EmptyMK
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerState blk EmptyMK -> HeaderState blk
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> HeaderState blk
headerState (ExtLedgerState blk EmptyMK -> Point blk)
-> m (ExtLedgerState blk EmptyMK) -> m (Point blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (ExtLedgerState blk EmptyMK)
-> m (ExtLedgerState blk EmptyMK)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
IOLike.atomically (LedgerDB' m blk -> STM m (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk -> STM m (l EmptyMK)
LedgerDB.getVolatileTip LedgerDB' m blk
st)

data TraceEvent blk =
    StartedEvent AnalysisName
    -- ^ triggered when given analysis has started
  | DoneEvent
    -- ^ triggered when analysis has ended
  | BlockSlotEvent BlockNo SlotNo (HeaderHash blk)
    -- ^ triggered when block has been found, it holds:
    --   * block's number
    --   * slot number when the block was forged
  | CountTxOutputsEvent BlockNo SlotNo Int Int
    -- ^ triggered when block has been found, it holds:
    --   * block's number
    --   * slot number when the block was forged
    --   * cumulative tx output
    --   * count tx output
  | EbbEvent (HeaderHash blk) (ChainHash blk) Bool
    -- ^ triggered when EBB block has been found, it holds:
    --   * its hash,
    --   * hash of previous block
    --   * flag whether the EBB is known
  | CountedBlocksEvent Int
    -- ^ triggered once during CountBLocks analysis,
    --   when blocks were counted
  | HeaderSizeEvent BlockNo SlotNo Word16 Word32
    -- ^ triggered when header size has been measured
    --   * block's number
    --   * slot number when the block was forged
    --   * block's header size
    --   * block's size
  | MaxHeaderSizeEvent Word16
    -- ^ triggered once during ShowBlockTxsSize analysis,
    --   holding maximum encountered header size
  | SnapshotStoredEvent SlotNo
    -- ^ triggered when snapshot of ledger has been stored for SlotNo
  | SnapshotWarningEvent SlotNo SlotNo
    -- ^ 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:
    --   * slot number when the block was forged
    --   * number of transactions in the block
    --   * total size of transactions in the block
  | BlockMempoolAndForgeRepro BlockNo SlotNo Int SizeInBytes IOLike.DiffTime Int64 Int64 IOLike.DiffTime Int64 Int64
    -- ^ triggered for all blocks during MempoolAndForgeRepro analysis,
    --   it holds:
    --   * block number
    --   * slot number when the block was forged
    --   * number of transactions in the block
    --   * total size of transactions in the block
    --   * monotonic time to tick ledger state
    --   * total time spent in the mutator when ticking the ledger state
    --   * total time spent in gc when ticking the ledger state
    --   * monotonic time to call 'Mempool.getSnapshotFor'
    --   * total time spent in the mutator when calling 'Mempool.getSnapshotFor'
    --   * total time spent in gc when calling 'Mempool.getSnapshotFor'

instance (HasAnalysis blk, LedgerSupportsProtocol blk) => Show (TraceEvent blk) where
  show :: TraceEvent blk -> FilePath
show (StartedEvent AnalysisName
analysisName)        = FilePath
"Started " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> (AnalysisName -> FilePath
forall a. Show a => a -> FilePath
show AnalysisName
analysisName)
  show TraceEvent blk
DoneEvent                          = FilePath
"Done"
  show (BlockSlotEvent BlockNo
bn SlotNo
sn HeaderHash blk
h)           = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\t" ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [
      BlockNo -> FilePath
forall a. Show a => a -> FilePath
show BlockNo
bn
    , SlotNo -> FilePath
forall a. Show a => a -> FilePath
show SlotNo
sn
    , HeaderHash blk -> FilePath
forall a. Show a => a -> FilePath
show HeaderHash blk
h
    ]
  show (CountTxOutputsEvent BlockNo
bn SlotNo
sn Int
cumulative Int
count) = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\t" ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [
      BlockNo -> FilePath
forall a. Show a => a -> FilePath
show BlockNo
bn
    , SlotNo -> FilePath
forall a. Show a => a -> FilePath
show SlotNo
sn
    , FilePath
"cumulative: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
cumulative
    , FilePath
"count: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
count
    ]
  show (EbbEvent HeaderHash blk
ebb ChainHash blk
previous Bool
known)      = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\t" [
      FilePath
"EBB: "   FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> HeaderHash blk -> FilePath
forall a. Show a => a -> FilePath
show HeaderHash blk
ebb
    , FilePath
"Prev: "  FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ChainHash blk -> FilePath
forall a. Show a => a -> FilePath
show ChainHash blk
previous
    , FilePath
"Known: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Bool -> FilePath
forall a. Show a => a -> FilePath
show Bool
known
    ]
  show (CountedBlocksEvent Int
counted)       = FilePath
"Counted " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
counted FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" blocks."
  show (HeaderSizeEvent BlockNo
bn SlotNo
sn Word16
hSz Word32
bSz)    = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\t" ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [
      BlockNo -> FilePath
forall a. Show a => a -> FilePath
show BlockNo
bn
    , SlotNo -> FilePath
forall a. Show a => a -> FilePath
show SlotNo
sn
    , FilePath
"header size: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word16 -> FilePath
forall a. Show a => a -> FilePath
show Word16
hSz
    , FilePath
"block size: "  FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word32 -> FilePath
forall a. Show a => a -> FilePath
show Word32
bSz
    ]
  show (MaxHeaderSizeEvent Word16
size)          =
    FilePath
"Maximum encountered header size = " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word16 -> FilePath
forall a. Show a => a -> FilePath
show Word16
size
  show (SnapshotStoredEvent SlotNo
slot)         =
    FilePath
"Snapshot stored at " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> SlotNo -> FilePath
forall a. Show a => a -> FilePath
show SlotNo
slot
  show (SnapshotWarningEvent SlotNo
requested SlotNo
actual) =
    FilePath
"Snapshot was created at " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> SlotNo -> FilePath
forall a. Show a => a -> FilePath
show SlotNo
actual FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
    FilePath
"because there was no block forged at requested " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> SlotNo -> FilePath
forall a. Show a => a -> FilePath
show SlotNo
requested
  show (LedgerErrorEvent Point blk
pt ExtValidationError blk
err) =
    FilePath
"Applying block at " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Point blk -> FilePath
forall a. Show a => a -> FilePath
show Point blk
pt FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" failed: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ExtValidationError blk -> FilePath
forall a. Show a => a -> FilePath
show ExtValidationError blk
err
  show (BlockTxSizeEvent SlotNo
slot Int
numBlocks SizeInBytes
txsSize) = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\t" [
      SlotNo -> FilePath
forall a. Show a => a -> FilePath
show SlotNo
slot
    , FilePath
"Num txs in block = " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
numBlocks
    , FilePath
"Total size of txs in block = " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> SizeInBytes -> FilePath
forall a. Show a => a -> FilePath
show SizeInBytes
txsSize
    ]
  show (BlockMempoolAndForgeRepro BlockNo
bno SlotNo
slot Int
txsCount SizeInBytes
txsSize DiffTime
durTick Int64
mutTick Int64
gcTick DiffTime
durSnap Int64
mutSnap Int64
gcSnap) = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\t" [
      BlockNo -> FilePath
forall a. Show a => a -> FilePath
show BlockNo
bno
    , SlotNo -> FilePath
forall a. Show a => a -> FilePath
show SlotNo
slot
    , FilePath
"txsCount " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
txsCount
    , FilePath
"txsSize " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> SizeInBytes -> FilePath
forall a. Show a => a -> FilePath
show SizeInBytes
txsSize
    , FilePath
"durTick " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> DiffTime -> FilePath
forall a. Show a => a -> FilePath
show DiffTime
durTick
    , FilePath
"mutTick " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int64 -> FilePath
forall a. Show a => a -> FilePath
show Int64
mutTick
    , FilePath
"gcTick " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int64 -> FilePath
forall a. Show a => a -> FilePath
show Int64
gcTick
    , FilePath
"durSnap " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> DiffTime -> FilePath
forall a. Show a => a -> FilePath
show DiffTime
durSnap
    , FilePath
"mutSnap " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int64 -> FilePath
forall a. Show a => a -> FilePath
show Int64
mutSnap
    , FilePath
"gcSnap " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int64 -> FilePath
forall a. Show a => a -> FilePath
show Int64
gcSnap
    ]


{-------------------------------------------------------------------------------
  Analysis: show block and slot number and hash for all blocks
-------------------------------------------------------------------------------}

showSlotBlockNo :: forall blk. HasAnalysis blk => Analysis blk StartFromPoint
showSlotBlockNo :: forall blk. HasAnalysis blk => Analysis blk 'StartFromPoint
showSlotBlockNo AnalysisEnv { ImmutableDB IO blk
db :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ImmutableDB IO blk
db :: ImmutableDB IO blk
db, ResourceRegistry IO
registry :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ResourceRegistry IO
registry :: ResourceRegistry IO
registry, AnalysisStartFrom IO blk 'StartFromPoint
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom m blk startFrom
startFrom :: AnalysisStartFrom IO blk 'StartFromPoint
startFrom, Limit
limit :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Limit
limit :: Limit
limit, Tracer IO (TraceEvent blk)
tracer :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Tracer m (TraceEvent blk)
tracer :: Tracer IO (TraceEvent blk)
tracer } =
    ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk (Header blk)
-> AnalysisStartFrom IO blk 'StartFromPoint
-> Limit
-> (Header blk -> IO ())
-> IO ()
forall blk b (startFrom :: StartFrom).
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> (b -> IO ())
-> IO ()
processAll_ ImmutableDB IO blk
db ResourceRegistry IO
registry BlockComponent blk (Header blk)
forall blk. BlockComponent blk (Header blk)
GetHeader AnalysisStartFrom IO blk 'StartFromPoint
startFrom Limit
limit Header blk -> IO ()
process
        IO () -> IO (Maybe AnalysisResult) -> IO (Maybe AnalysisResult)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AnalysisResult
forall a. Maybe a
Nothing
  where
    process :: Header blk -> IO ()
    process :: Header blk -> IO ()
process Header blk
hdr = Tracer IO (TraceEvent blk) -> TraceEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (TraceEvent blk)
tracer (TraceEvent blk -> IO ()) -> TraceEvent blk -> IO ()
forall a b. (a -> b) -> a -> b
$
        BlockNo -> SlotNo -> HeaderHash blk -> TraceEvent blk
forall blk. BlockNo -> SlotNo -> HeaderHash blk -> TraceEvent blk
BlockSlotEvent (Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr) (Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr) (Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr)

{-------------------------------------------------------------------------------
  Analysis: show total number of tx outputs per block
-------------------------------------------------------------------------------}

countTxOutputs :: forall blk. HasAnalysis blk => Analysis blk StartFromPoint
countTxOutputs :: forall blk. HasAnalysis blk => Analysis blk 'StartFromPoint
countTxOutputs AnalysisEnv { ImmutableDB IO blk
db :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ImmutableDB IO blk
db :: ImmutableDB IO blk
db, ResourceRegistry IO
registry :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ResourceRegistry IO
registry :: ResourceRegistry IO
registry, AnalysisStartFrom IO blk 'StartFromPoint
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom m blk startFrom
startFrom :: AnalysisStartFrom IO blk 'StartFromPoint
startFrom, Limit
limit :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Limit
limit :: Limit
limit, Tracer IO (TraceEvent blk)
tracer :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Tracer m (TraceEvent blk)
tracer :: Tracer IO (TraceEvent blk)
tracer } = do
    IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk blk
-> AnalysisStartFrom IO blk 'StartFromPoint
-> Limit
-> Int
-> (Int -> blk -> IO Int)
-> IO Int
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> st
-> (st -> b -> IO st)
-> IO st
processAll ImmutableDB IO blk
db ResourceRegistry IO
registry BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock AnalysisStartFrom IO blk 'StartFromPoint
startFrom Limit
limit Int
0 Int -> blk -> IO Int
process
    Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AnalysisResult
forall a. Maybe a
Nothing
  where
    process :: Int -> blk -> IO Int
    process :: Int -> blk -> IO Int
process Int
cumulative blk
blk = do
        let cumulative' :: Int
cumulative' = Int
cumulative Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
count
            event :: TraceEvent blk
event       = BlockNo -> SlotNo -> Int -> Int -> TraceEvent blk
forall blk. BlockNo -> SlotNo -> Int -> Int -> TraceEvent blk
CountTxOutputsEvent (blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo blk
blk)
                                              (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk)
                                              Int
cumulative'
                                              Int
count
        Tracer IO (TraceEvent blk) -> TraceEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (TraceEvent blk)
tracer TraceEvent blk
event
        Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
cumulative'
      where
        count :: Int
count = blk -> Int
forall blk. HasAnalysis blk => blk -> Int
HasAnalysis.countTxOutputs blk
blk

{-------------------------------------------------------------------------------
  Analysis: show the header size in bytes for all blocks
-------------------------------------------------------------------------------}

showHeaderSize :: forall blk. HasAnalysis blk => Analysis blk StartFromPoint
showHeaderSize :: forall blk. HasAnalysis blk => Analysis blk 'StartFromPoint
showHeaderSize AnalysisEnv { ImmutableDB IO blk
db :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ImmutableDB IO blk
db :: ImmutableDB IO blk
db, ResourceRegistry IO
registry :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ResourceRegistry IO
registry :: ResourceRegistry IO
registry, AnalysisStartFrom IO blk 'StartFromPoint
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom m blk startFrom
startFrom :: AnalysisStartFrom IO blk 'StartFromPoint
startFrom, Limit
limit :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Limit
limit :: Limit
limit, Tracer IO (TraceEvent blk)
tracer :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Tracer m (TraceEvent blk)
tracer :: Tracer IO (TraceEvent blk)
tracer } = do
    maxHeaderSize <-
      ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk (Header blk, Word16, SizeInBytes)
-> AnalysisStartFrom IO blk 'StartFromPoint
-> Limit
-> Word16
-> (Word16 -> (Header blk, Word16, SizeInBytes) -> IO Word16)
-> IO Word16
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> st
-> (st -> b -> IO st)
-> IO st
processAll ImmutableDB IO blk
db ResourceRegistry IO
registry ((,,) (Header blk
 -> Word16 -> SizeInBytes -> (Header blk, Word16, SizeInBytes))
-> BlockComponent blk (Header blk)
-> BlockComponent
     blk (Word16 -> SizeInBytes -> (Header blk, Word16, SizeInBytes))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockComponent blk (Header blk)
forall blk. BlockComponent blk (Header blk)
GetHeader BlockComponent
  blk (Word16 -> SizeInBytes -> (Header blk, Word16, SizeInBytes))
-> BlockComponent blk Word16
-> BlockComponent
     blk (SizeInBytes -> (Header blk, Word16, SizeInBytes))
forall a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk Word16
forall blk. BlockComponent blk Word16
GetHeaderSize BlockComponent
  blk (SizeInBytes -> (Header blk, Word16, SizeInBytes))
-> BlockComponent blk SizeInBytes
-> BlockComponent blk (Header blk, Word16, SizeInBytes)
forall a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk SizeInBytes
forall blk. BlockComponent blk SizeInBytes
GetBlockSize) AnalysisStartFrom IO blk 'StartFromPoint
startFrom Limit
limit Word16
0 Word16 -> (Header blk, Word16, SizeInBytes) -> IO Word16
process
    traceWith tracer $ MaxHeaderSizeEvent maxHeaderSize
    pure $ Just $ ResultMaxHeaderSize maxHeaderSize
  where
    process :: Word16 -> (Header blk, Word16, SizeInBytes) -> IO Word16
    process :: Word16 -> (Header blk, Word16, SizeInBytes) -> IO Word16
process Word16
maxHeaderSize (Header blk
hdr, Word16
headerSize, SizeInBytes
blockSize) = do
      let event :: TraceEvent blk
event = BlockNo -> SlotNo -> Word16 -> Word32 -> TraceEvent blk
forall blk. BlockNo -> SlotNo -> Word16 -> Word32 -> TraceEvent blk
HeaderSizeEvent (Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr)
                                  (Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr)
                                   Word16
headerSize
                                  (SizeInBytes -> Word32
getSizeInBytes SizeInBytes
blockSize)
      Tracer IO (TraceEvent blk) -> TraceEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (TraceEvent blk)
tracer TraceEvent blk
event
      Word16 -> IO Word16
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word16 -> IO Word16) -> Word16 -> IO Word16
forall a b. (a -> b) -> a -> b
$ Word16
maxHeaderSize Word16 -> Word16 -> Word16
forall a. Ord a => a -> a -> a
`max` Word16
headerSize

{-------------------------------------------------------------------------------
  Analysis: show the total transaction sizes in bytes per block
-------------------------------------------------------------------------------}

showBlockTxsSize :: forall blk. HasAnalysis blk => Analysis blk StartFromPoint
showBlockTxsSize :: forall blk. HasAnalysis blk => Analysis blk 'StartFromPoint
showBlockTxsSize AnalysisEnv { ImmutableDB IO blk
db :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ImmutableDB IO blk
db :: ImmutableDB IO blk
db, ResourceRegistry IO
registry :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ResourceRegistry IO
registry :: ResourceRegistry IO
registry, AnalysisStartFrom IO blk 'StartFromPoint
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom m blk startFrom
startFrom :: AnalysisStartFrom IO blk 'StartFromPoint
startFrom, Limit
limit :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Limit
limit :: Limit
limit, Tracer IO (TraceEvent blk)
tracer :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Tracer m (TraceEvent blk)
tracer :: Tracer IO (TraceEvent blk)
tracer } = do
    ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk blk
-> AnalysisStartFrom IO blk 'StartFromPoint
-> Limit
-> (blk -> IO ())
-> IO ()
forall blk b (startFrom :: StartFrom).
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> (b -> IO ())
-> IO ()
processAll_ ImmutableDB IO blk
db ResourceRegistry IO
registry BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock AnalysisStartFrom IO blk 'StartFromPoint
startFrom Limit
limit blk -> IO ()
process
    Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AnalysisResult
forall a. Maybe a
Nothing
  where
    process :: blk -> IO ()
    process :: blk -> IO ()
process blk
blk =
      Tracer IO (TraceEvent blk) -> TraceEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (TraceEvent blk)
tracer (TraceEvent blk -> IO ()) -> TraceEvent blk -> IO ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> Int -> SizeInBytes -> TraceEvent blk
forall blk. SlotNo -> Int -> SizeInBytes -> TraceEvent blk
BlockTxSizeEvent (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk) Int
numBlockTxs SizeInBytes
blockTxsSize
      where
        txSizes :: [SizeInBytes]
        txSizes :: [SizeInBytes]
txSizes = blk -> [SizeInBytes]
forall blk. HasAnalysis blk => blk -> [SizeInBytes]
HasAnalysis.blockTxSizes blk
blk

        numBlockTxs :: Int
        numBlockTxs :: Int
numBlockTxs = [SizeInBytes] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SizeInBytes]
txSizes

        blockTxsSize :: SizeInBytes
        blockTxsSize :: SizeInBytes
blockTxsSize = [SizeInBytes] -> SizeInBytes
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [SizeInBytes]
txSizes

{-------------------------------------------------------------------------------
  Analysis: show EBBs and their predecessors
-------------------------------------------------------------------------------}

showEBBs :: forall blk. HasAnalysis blk => Analysis blk StartFromPoint
showEBBs :: forall blk. HasAnalysis blk => Analysis blk 'StartFromPoint
showEBBs AnalysisEnv { ImmutableDB IO blk
db :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ImmutableDB IO blk
db :: ImmutableDB IO blk
db, ResourceRegistry IO
registry :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ResourceRegistry IO
registry :: ResourceRegistry IO
registry, AnalysisStartFrom IO blk 'StartFromPoint
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom m blk startFrom
startFrom :: AnalysisStartFrom IO blk 'StartFromPoint
startFrom, Limit
limit :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Limit
limit :: Limit
limit, Tracer IO (TraceEvent blk)
tracer :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Tracer m (TraceEvent blk)
tracer :: Tracer IO (TraceEvent blk)
tracer } = do
    ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk blk
-> AnalysisStartFrom IO blk 'StartFromPoint
-> Limit
-> (blk -> IO ())
-> IO ()
forall blk b (startFrom :: StartFrom).
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> (b -> IO ())
-> IO ()
processAll_ ImmutableDB IO blk
db ResourceRegistry IO
registry BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock AnalysisStartFrom IO blk 'StartFromPoint
startFrom Limit
limit blk -> IO ()
process
    Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AnalysisResult
forall a. Maybe a
Nothing
  where
    process :: blk -> IO ()
    process :: blk -> IO ()
process blk
blk =
        case blk -> Maybe EpochNo
forall blk. GetHeader blk => blk -> Maybe EpochNo
blockIsEBB blk
blk of
          Just EpochNo
_epoch -> do
            let known :: Bool
known =  HeaderHash blk
-> Map (HeaderHash blk) (ChainHash blk) -> Maybe (ChainHash blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup
                            (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk)
                            (Proxy blk -> Map (HeaderHash blk) (ChainHash blk)
forall blk (proxy :: * -> *).
HasAnalysis blk =>
proxy blk -> Map (HeaderHash blk) (ChainHash blk)
forall (proxy :: * -> *).
proxy blk -> Map (HeaderHash blk) (ChainHash blk)
HasAnalysis.knownEBBs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk))
                       Maybe (ChainHash blk) -> Maybe (ChainHash blk) -> Bool
forall a. Eq a => a -> a -> Bool
== ChainHash blk -> Maybe (ChainHash blk)
forall a. a -> Maybe a
Just (blk -> ChainHash blk
forall blk. GetPrevHash blk => blk -> ChainHash blk
blockPrevHash blk
blk)
                event :: TraceEvent blk
event = HeaderHash blk -> ChainHash blk -> Bool -> TraceEvent blk
forall blk.
HeaderHash blk -> ChainHash blk -> Bool -> TraceEvent blk
EbbEvent (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk) (blk -> ChainHash blk
forall blk. GetPrevHash blk => blk -> ChainHash blk
blockPrevHash blk
blk) Bool
known
            Tracer IO (TraceEvent blk) -> TraceEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (TraceEvent blk)
tracer TraceEvent blk
event
          Maybe EpochNo
_otherwise -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- Skip regular blocks

{-------------------------------------------------------------------------------
  Analysis: store a ledger at specific slot
-------------------------------------------------------------------------------}

storeLedgerStateAt ::
     forall blk .
     ( LedgerSupportsProtocol blk
#if __GLASGOW_HASKELL__ > 810
     , HasAnalysis blk
#endif
     )
  => SlotNo
  -> LedgerApplicationMode
  -> Analysis blk StartFromLedgerState
storeLedgerStateAt :: forall blk.
(LedgerSupportsProtocol blk, HasAnalysis blk) =>
SlotNo
-> LedgerApplicationMode -> Analysis blk 'StartFromLedgerState
storeLedgerStateAt SlotNo
slotNo LedgerApplicationMode
ledgerAppMode AnalysisEnv IO blk 'StartFromLedgerState
env = do
    IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk blk
-> AnalysisStartFrom IO blk 'StartFromLedgerState
-> Limit
-> ()
-> (() -> blk -> IO (NextStep, ()))
-> IO ()
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> st
-> (st -> b -> IO (NextStep, st))
-> IO st
processAllUntil ImmutableDB IO blk
db ResourceRegistry IO
registry BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom Limit
limit () () -> blk -> IO (NextStep, ())
process
    Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AnalysisResult
forall a. Maybe a
Nothing
  where
    AnalysisEnv { ImmutableDB IO blk
db :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ImmutableDB IO blk
db :: ImmutableDB IO blk
db, ResourceRegistry IO
registry :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ResourceRegistry IO
registry :: ResourceRegistry IO
registry, AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom m blk startFrom
startFrom :: AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom, TopLevelConfig blk
cfg :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg, Limit
limit :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Limit
limit :: Limit
limit, Tracer IO (TraceEvent blk)
tracer :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Tracer m (TraceEvent blk)
tracer :: Tracer IO (TraceEvent blk)
tracer } = AnalysisEnv IO blk 'StartFromLedgerState
env
    FromLedgerState LedgerDB IO (ExtLedgerState blk) blk
initLedgerDB TestInternals IO (ExtLedgerState blk) blk
internal = AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom

    process :: () -> blk -> IO (NextStep, ())
    process :: () -> blk -> IO (NextStep, ())
process ()
_ blk
blk = do
      let ledgerCfg :: ExtLedgerCfg blk
ledgerCfg = TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
cfg
      oldLedger <- STM IO (ExtLedgerState blk EmptyMK)
-> IO (ExtLedgerState blk EmptyMK)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
IOLike.atomically (STM IO (ExtLedgerState blk EmptyMK)
 -> IO (ExtLedgerState blk EmptyMK))
-> STM IO (ExtLedgerState blk EmptyMK)
-> IO (ExtLedgerState blk EmptyMK)
forall a b. (a -> b) -> a -> b
$ LedgerDB IO (ExtLedgerState blk) blk
-> STM IO (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk -> STM m (l EmptyMK)
LedgerDB.getVolatileTip LedgerDB IO (ExtLedgerState blk) blk
initLedgerDB
      frk <- LedgerDB.getForkerAtTarget initLedgerDB registry VolatileTip >>= \case
        Left {} -> FilePath -> IO (Forker IO (ExtLedgerState blk) blk)
forall a. HasCallStack => FilePath -> a
error FilePath
"Unreachable, volatile tip MUST be in the LedgerDB"
        Right Forker IO (ExtLedgerState blk) blk
f -> Forker IO (ExtLedgerState blk) blk
-> IO (Forker IO (ExtLedgerState blk) blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Forker IO (ExtLedgerState blk) blk
f
      tbs <- LedgerDB.forkerReadTables frk (getBlockKeySets blk)
      LedgerDB.forkerClose frk
      case runExcept $ tickThenXApply OmitLedgerEvents ledgerCfg blk (oldLedger `withLedgerTables` tbs) of
        Right ExtLedgerState blk DiffMK
newLedger -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
slotNo) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExtLedgerState blk DiffMK -> IO ()
forall (mk :: MapKind). ExtLedgerState blk mk -> IO ()
storeLedgerState ExtLedgerState blk DiffMK
newLedger
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
slotNo) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ blk -> IO ()
issueWarning blk
blk
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((BlockNo -> Word64
unBlockNo (BlockNo -> Word64) -> BlockNo -> Word64
forall a b. (a -> b) -> a -> b
$ blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo blk
blk) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
1000 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ blk -> IO ()
reportProgress blk
blk
          TestInternals IO (ExtLedgerState blk) blk
-> ExtLedgerState blk DiffMK -> IO ()
forall {k} (m :: * -> *) (l :: k) blk.
TestInternals m l blk -> ExtLedgerState blk DiffMK -> m ()
LedgerDB.push TestInternals IO (ExtLedgerState blk) blk
internal ExtLedgerState blk DiffMK
newLedger
          LedgerDB IO (ExtLedgerState blk) blk -> IO ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk -> m ()
LedgerDB.tryFlush LedgerDB IO (ExtLedgerState blk) blk
initLedgerDB
          (NextStep, ()) -> IO (NextStep, ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (blk -> NextStep
continue blk
blk, ())
        Left ExtValidationError blk
err -> do
          Tracer IO (TraceEvent blk) -> TraceEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (TraceEvent blk)
tracer (TraceEvent blk -> IO ()) -> TraceEvent blk -> IO ()
forall a b. (a -> b) -> a -> b
$ Point blk -> ExtValidationError blk -> TraceEvent blk
forall blk. Point blk -> ExtValidationError blk -> TraceEvent blk
LedgerErrorEvent (blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint blk
blk) ExtValidationError blk
err
          ExtLedgerState blk ValuesMK -> IO ()
forall (mk :: MapKind). ExtLedgerState blk mk -> IO ()
storeLedgerState (ExtLedgerState blk EmptyMK
oldLedger ExtLedgerState blk EmptyMK
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> ExtLedgerState blk ValuesMK
forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
ExtLedgerState blk any
-> LedgerTables (ExtLedgerState blk) mk -> ExtLedgerState blk mk
forall (l :: LedgerStateKind) (mk :: MapKind) (any :: MapKind).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
`withLedgerTables` LedgerTables (ExtLedgerState blk) ValuesMK
tbs)
          (NextStep, ()) -> IO (NextStep, ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NextStep
Stop, ())

    tickThenXApply :: ComputeLedgerEvents
-> ExtLedgerCfg blk
-> blk
-> ExtLedgerState blk ValuesMK
-> Except (ExtValidationError blk) (ExtLedgerState blk DiffMK)
tickThenXApply = case LedgerApplicationMode
ledgerAppMode of
        LedgerApplicationMode
LedgerReapply -> ExtLedgerState blk DiffMK
-> Except (ExtValidationError blk) (ExtLedgerState blk DiffMK)
forall a. a -> ExceptT (ExtValidationError blk) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExtLedgerState blk DiffMK
 -> Except (ExtValidationError blk) (ExtLedgerState blk DiffMK))
-> (ComputeLedgerEvents
    -> ExtLedgerCfg blk
    -> blk
    -> ExtLedgerState blk ValuesMK
    -> ExtLedgerState blk DiffMK)
-> ComputeLedgerEvents
-> ExtLedgerCfg blk
-> blk
-> ExtLedgerState blk ValuesMK
-> Except (ExtValidationError blk) (ExtLedgerState blk DiffMK)
forall y z x0 x1 x2 x3.
(y -> z)
-> (x0 -> x1 -> x2 -> x3 -> y) -> x0 -> x1 -> x2 -> x3 -> z
...: ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> blk
-> ExtLedgerState blk ValuesMK
-> ExtLedgerState blk DiffMK
ComputeLedgerEvents
-> ExtLedgerCfg blk
-> blk
-> ExtLedgerState blk ValuesMK
-> ExtLedgerState blk DiffMK
forall (l :: LedgerStateKind) blk.
ApplyBlock l blk =>
ComputeLedgerEvents -> LedgerCfg l -> blk -> l ValuesMK -> l DiffMK
tickThenReapply
        LedgerApplicationMode
LedgerApply   -> ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> blk
-> ExtLedgerState blk ValuesMK
-> Except
     (LedgerErr (ExtLedgerState blk)) (ExtLedgerState blk DiffMK)
ComputeLedgerEvents
-> ExtLedgerCfg blk
-> blk
-> ExtLedgerState blk ValuesMK
-> Except (ExtValidationError blk) (ExtLedgerState blk DiffMK)
forall (l :: LedgerStateKind) blk.
ApplyBlock l blk =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> l ValuesMK
-> Except (LedgerErr l) (l DiffMK)
tickThenApply

    continue :: blk -> NextStep
    continue :: blk -> NextStep
continue blk
blk
      | blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
slotNo = NextStep
Stop
      | Bool
otherwise               = NextStep
Continue

    issueWarning :: blk -> IO ()
issueWarning blk
blk   = let event :: TraceEvent blk
event = SlotNo -> SlotNo -> TraceEvent blk
forall blk. SlotNo -> SlotNo -> TraceEvent blk
SnapshotWarningEvent SlotNo
slotNo (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk)
                         in Tracer IO (TraceEvent blk) -> TraceEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (TraceEvent blk)
tracer TraceEvent blk
event
    reportProgress :: blk -> IO ()
reportProgress blk
blk = let event :: TraceEvent blk
event = BlockNo -> SlotNo -> HeaderHash blk -> TraceEvent blk
forall blk. BlockNo -> SlotNo -> HeaderHash blk -> TraceEvent blk
BlockSlotEvent (blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo blk
blk) (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk) (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk)
                         in Tracer IO (TraceEvent blk) -> TraceEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (TraceEvent blk)
tracer TraceEvent blk
event

    storeLedgerState :: ExtLedgerState blk mk -> IO ()
    storeLedgerState :: forall (mk :: MapKind). ExtLedgerState blk mk -> IO ()
storeLedgerState ExtLedgerState blk mk
ledgerState = case Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
pt of
        NotOrigin SlotNo
slot -> do
          TestInternals IO (ExtLedgerState blk) blk
-> WhereToTakeSnapshot -> Maybe FilePath -> IO ()
forall {k} (m :: * -> *) (l :: k) blk.
TestInternals m l blk
-> WhereToTakeSnapshot -> Maybe FilePath -> m ()
LedgerDB.takeSnapshotNOW TestInternals IO (ExtLedgerState blk) blk
internal WhereToTakeSnapshot
LedgerDB.TakeAtVolatileTip (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"db-analyser")
          Tracer IO (TraceEvent blk) -> TraceEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (TraceEvent blk)
tracer (TraceEvent blk -> IO ()) -> TraceEvent blk -> IO ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> TraceEvent blk
forall blk. SlotNo -> TraceEvent blk
SnapshotStoredEvent SlotNo
slot
        WithOrigin SlotNo
Origin -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        pt :: Point blk
pt = HeaderState blk -> Point blk
forall blk. HasAnnTip blk => HeaderState blk -> Point blk
headerStatePoint (HeaderState blk -> Point blk) -> HeaderState blk -> Point blk
forall a b. (a -> b) -> a -> b
$ ExtLedgerState blk mk -> HeaderState blk
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> HeaderState blk
headerState ExtLedgerState blk mk
ledgerState

countBlocks ::
     forall blk .
     ( HasAnalysis blk
     )
  => Analysis blk StartFromPoint
countBlocks :: forall blk. HasAnalysis blk => Analysis blk 'StartFromPoint
countBlocks (AnalysisEnv { ImmutableDB IO blk
db :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ImmutableDB IO blk
db :: ImmutableDB IO blk
db, ResourceRegistry IO
registry :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ResourceRegistry IO
registry :: ResourceRegistry IO
registry, AnalysisStartFrom IO blk 'StartFromPoint
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom m blk startFrom
startFrom :: AnalysisStartFrom IO blk 'StartFromPoint
startFrom, Limit
limit :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Limit
limit :: Limit
limit, Tracer IO (TraceEvent blk)
tracer :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Tracer m (TraceEvent blk)
tracer :: Tracer IO (TraceEvent blk)
tracer }) = do
    counted <- ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk ()
-> AnalysisStartFrom IO blk 'StartFromPoint
-> Limit
-> Int
-> (Int -> () -> IO Int)
-> IO Int
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> st
-> (st -> b -> IO st)
-> IO st
processAll ImmutableDB IO blk
db ResourceRegistry IO
registry (() -> BlockComponent blk ()
forall a blk. a -> BlockComponent blk a
GetPure ()) AnalysisStartFrom IO blk 'StartFromPoint
startFrom Limit
limit Int
0 Int -> () -> IO Int
process
    traceWith tracer $ CountedBlocksEvent counted
    pure $ Just $ ResultCountBlock counted
  where
    process :: Int -> () -> IO Int
    process :: Int -> () -> IO Int
process Int
count ()
_ = Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
{-------------------------------------------------------------------------------
  Analysis: check for ledger state thunks every n blocks
-------------------------------------------------------------------------------}

checkNoThunksEvery ::
  forall blk.
  ( HasAnalysis blk,
    LedgerSupportsProtocol blk,
    CanStowLedgerTables (LedgerState blk)
  ) =>
  Word64 ->
  Analysis blk StartFromLedgerState
checkNoThunksEvery :: forall blk.
(HasAnalysis blk, LedgerSupportsProtocol blk,
 CanStowLedgerTables (LedgerState blk)) =>
Word64 -> Analysis blk 'StartFromLedgerState
checkNoThunksEvery
  Word64
nBlocks
  (AnalysisEnv {ImmutableDB IO blk
db :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ImmutableDB IO blk
db :: ImmutableDB IO blk
db, ResourceRegistry IO
registry :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ResourceRegistry IO
registry :: ResourceRegistry IO
registry, AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom m blk startFrom
startFrom :: AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom, TopLevelConfig blk
cfg :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg, Limit
limit :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Limit
limit :: Limit
limit}) = do
    FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath
"Checking for thunks in each block where blockNo === 0 (mod " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> FilePath
forall a. Show a => a -> FilePath
show Word64
nBlocks FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
")."
    IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk blk
-> AnalysisStartFrom IO blk 'StartFromLedgerState
-> Limit
-> ()
-> (() -> blk -> IO ())
-> IO ()
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> st
-> (st -> b -> IO st)
-> IO st
processAll ImmutableDB IO blk
db ResourceRegistry IO
registry BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom Limit
limit () () -> blk -> IO ()
process
    Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AnalysisResult
forall a. Maybe a
Nothing
  where
    FromLedgerState LedgerDB IO (ExtLedgerState blk) blk
ldb TestInternals IO (ExtLedgerState blk) blk
internal = AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom

    process :: () -> blk -> IO ()
    process :: () -> blk -> IO ()
process ()
_ blk
blk = do
      oldLedger <- STM IO (ExtLedgerState blk EmptyMK)
-> IO (ExtLedgerState blk EmptyMK)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
IOLike.atomically (STM IO (ExtLedgerState blk EmptyMK)
 -> IO (ExtLedgerState blk EmptyMK))
-> STM IO (ExtLedgerState blk EmptyMK)
-> IO (ExtLedgerState blk EmptyMK)
forall a b. (a -> b) -> a -> b
$ LedgerDB IO (ExtLedgerState blk) blk
-> STM IO (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk -> STM m (l EmptyMK)
LedgerDB.getVolatileTip LedgerDB IO (ExtLedgerState blk) blk
ldb
      frk <- LedgerDB.getForkerAtTarget ldb registry VolatileTip >>= \case
        Left {} -> FilePath -> IO (Forker IO (ExtLedgerState blk) blk)
forall a. HasCallStack => FilePath -> a
error FilePath
"Unreachable, volatile tip MUST be in the LedgerDB"
        Right Forker IO (ExtLedgerState blk) blk
f -> Forker IO (ExtLedgerState blk) blk
-> IO (Forker IO (ExtLedgerState blk) blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Forker IO (ExtLedgerState blk) blk
f
      tbs <- LedgerDB.forkerReadTables frk (getBlockKeySets blk)
      LedgerDB.forkerClose frk
      let oldLedger' = ExtLedgerState blk EmptyMK
oldLedger ExtLedgerState blk EmptyMK
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> ExtLedgerState blk ValuesMK
forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
ExtLedgerState blk any
-> LedgerTables (ExtLedgerState blk) mk -> ExtLedgerState blk mk
forall (l :: LedgerStateKind) (mk :: MapKind) (any :: MapKind).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
`withLedgerTables` LedgerTables (ExtLedgerState blk) ValuesMK
tbs
      let ledgerCfg     = TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
cfg
          appliedResult = ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> blk
-> ExtLedgerState blk ValuesMK
-> Except
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
forall (l :: LedgerStateKind) blk.
ApplyBlock l blk =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> l ValuesMK
-> Except (LedgerErr l) (LedgerResult l (l DiffMK))
tickThenApplyLedgerResult ComputeLedgerEvents
OmitLedgerEvents LedgerCfg (ExtLedgerState blk)
ExtLedgerCfg blk
ledgerCfg blk
blk ExtLedgerState blk ValuesMK
oldLedger'
          newLedger     = (ExtValidationError blk -> ExtLedgerState blk DiffMK)
-> (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK)
    -> ExtLedgerState blk DiffMK)
-> Either
     (ExtValidationError blk)
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
-> ExtLedgerState blk DiffMK
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> ExtLedgerState blk DiffMK
forall a. HasCallStack => FilePath -> a
error (FilePath -> ExtLedgerState blk DiffMK)
-> (ExtValidationError blk -> FilePath)
-> ExtValidationError blk
-> ExtLedgerState blk DiffMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtValidationError blk -> FilePath
forall a. Show a => a -> FilePath
show) LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK)
-> ExtLedgerState blk DiffMK
forall (l :: LedgerStateKind) a. LedgerResult l a -> a
lrResult (Either
   (ExtValidationError blk)
   (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
 -> ExtLedgerState blk DiffMK)
-> Either
     (ExtValidationError blk)
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
-> ExtLedgerState blk DiffMK
forall a b. (a -> b) -> a -> b
$ Except
  (ExtValidationError blk)
  (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
-> Either
     (ExtValidationError blk)
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
forall e a. Except e a -> Either e a
runExcept Except
  (LedgerErr (ExtLedgerState blk))
  (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
Except
  (ExtValidationError blk)
  (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
appliedResult
          newLedger'    = ExtLedgerState blk ValuesMK
-> ExtLedgerState blk DiffMK -> ExtLedgerState blk ValuesMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
l ValuesMK -> l' DiffMK -> l' ValuesMK
applyDiffs ExtLedgerState blk ValuesMK
oldLedger' ExtLedgerState blk DiffMK
newLedger
          bn            = blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo blk
blk
      when (unBlockNo bn `mod` nBlocks == 0 ) $ do
        -- Check the new ledger state with new values stowed. This checks that
        -- the ledger has no thunks in their ledgerstate type.
        IOLike.evaluate (stowLedgerTables $ ledgerState newLedger') >>= checkNoThunks bn
        -- Check the new ledger state with diffs in the tables. This should
        -- catch any additional thunks in the diffs tables.
        IOLike.evaluate (ledgerState newLedger) >>= checkNoThunks bn
        -- Check the new ledger state with values in the ledger tables. This
        -- should catch any additional thunks in the values tables.
        IOLike.evaluate (ledgerState newLedger') >>= checkNoThunks bn

      LedgerDB.push internal newLedger
      LedgerDB.tryFlush ldb


    checkNoThunks :: NoThunksMK mk => BlockNo -> LedgerState blk mk -> IO ()
    checkNoThunks :: forall (mk :: MapKind).
NoThunksMK mk =>
BlockNo -> LedgerState blk mk -> IO ()
checkNoThunks BlockNo
bn LedgerState blk mk
ls =
      [FilePath] -> LedgerState blk mk -> IO (Maybe ThunkInfo)
forall a. NoThunks a => [FilePath] -> a -> IO (Maybe ThunkInfo)
noThunks [FilePath
"--checkThunks"] LedgerState blk mk
ls IO (Maybe ThunkInfo) -> (Maybe ThunkInfo -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe ThunkInfo
Nothing -> FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ BlockNo -> FilePath
forall a. Show a => a -> FilePath
show BlockNo
bn FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
": no thunks found."
        Just ThunkInfo
ti -> do
          FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ BlockNo -> FilePath
forall a. Show a => a -> FilePath
show BlockNo
bn FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
": thunks found."
          ThunkInfo -> IO ()
forall a. Show a => a -> IO ()
print ThunkInfo
ti

{-------------------------------------------------------------------------------
  Analysis: maintain a ledger state and issue trace markers at appropriate
  points in the epoch
-------------------------------------------------------------------------------}

traceLedgerProcessing ::
  forall blk.
  ( HasAnalysis blk,
    LedgerSupportsProtocol blk
  ) =>
  Analysis blk StartFromLedgerState
traceLedgerProcessing :: forall blk.
(HasAnalysis blk, LedgerSupportsProtocol blk) =>
Analysis blk 'StartFromLedgerState
traceLedgerProcessing
  (AnalysisEnv {ImmutableDB IO blk
db :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ImmutableDB IO blk
db :: ImmutableDB IO blk
db, ResourceRegistry IO
registry :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ResourceRegistry IO
registry :: ResourceRegistry IO
registry, AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom m blk startFrom
startFrom :: AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom, TopLevelConfig blk
cfg :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg, Limit
limit :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Limit
limit :: Limit
limit}) = do
    IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk blk
-> AnalysisStartFrom IO blk 'StartFromLedgerState
-> Limit
-> ()
-> (() -> blk -> IO ())
-> IO ()
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> st
-> (st -> b -> IO st)
-> IO st
processAll ImmutableDB IO blk
db ResourceRegistry IO
registry BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom Limit
limit () (LedgerDB' IO blk -> () -> blk -> IO ()
process LedgerDB' IO blk
initLedger)
    Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AnalysisResult
forall a. Maybe a
Nothing
  where
    FromLedgerState LedgerDB' IO blk
initLedger TestInternals' IO blk
internal = AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom

    process
      :: LedgerDB.LedgerDB' IO blk
      -> ()
      -> blk
      -> IO ()
    process :: LedgerDB' IO blk -> () -> blk -> IO ()
process LedgerDB' IO blk
ledgerDB ()
_ blk
blk = do
      frk <- LedgerDB' IO blk
-> ResourceRegistry IO
-> Target (Point blk)
-> IO (Either GetForkerError (Forker IO (ExtLedgerState blk) blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
LedgerDB.getForkerAtTarget LedgerDB' IO blk
ledgerDB ResourceRegistry IO
registry Target (Point blk)
forall point. Target point
VolatileTip IO (Either GetForkerError (Forker IO (ExtLedgerState blk) blk))
-> (Either GetForkerError (Forker IO (ExtLedgerState blk) blk)
    -> IO (Forker IO (ExtLedgerState blk) blk))
-> IO (Forker IO (ExtLedgerState blk) blk)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left {} -> FilePath -> IO (Forker IO (ExtLedgerState blk) blk)
forall a. HasCallStack => FilePath -> a
error FilePath
"Unreachable, volatile tip MUST be in the LedgerDB"
        Right Forker IO (ExtLedgerState blk) blk
f -> Forker IO (ExtLedgerState blk) blk
-> IO (Forker IO (ExtLedgerState blk) blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Forker IO (ExtLedgerState blk) blk
f
      oldLedgerSt <- IOLike.atomically $ LedgerDB.forkerGetLedgerState frk
      oldLedgerTbs <- LedgerDB.forkerReadTables frk (getBlockKeySets blk)
      let oldLedger = ExtLedgerState blk EmptyMK
oldLedgerSt ExtLedgerState blk EmptyMK
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> ExtLedgerState blk ValuesMK
forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
ExtLedgerState blk any
-> LedgerTables (ExtLedgerState blk) mk -> ExtLedgerState blk mk
forall (l :: LedgerStateKind) (mk :: MapKind) (any :: MapKind).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
`withLedgerTables` LedgerTables (ExtLedgerState blk) ValuesMK
oldLedgerTbs
      LedgerDB.forkerClose frk

      let ledgerCfg     = TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
cfg
          appliedResult = ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> blk
-> ExtLedgerState blk ValuesMK
-> Except
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
forall (l :: LedgerStateKind) blk.
ApplyBlock l blk =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> l ValuesMK
-> Except (LedgerErr l) (LedgerResult l (l DiffMK))
tickThenApplyLedgerResult ComputeLedgerEvents
OmitLedgerEvents LedgerCfg (ExtLedgerState blk)
ExtLedgerCfg blk
ledgerCfg blk
blk ExtLedgerState blk ValuesMK
oldLedger
          newLedger     = (ExtValidationError blk -> ExtLedgerState blk DiffMK)
-> (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK)
    -> ExtLedgerState blk DiffMK)
-> Either
     (ExtValidationError blk)
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
-> ExtLedgerState blk DiffMK
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> ExtLedgerState blk DiffMK
forall a. HasCallStack => FilePath -> a
error (FilePath -> ExtLedgerState blk DiffMK)
-> (ExtValidationError blk -> FilePath)
-> ExtValidationError blk
-> ExtLedgerState blk DiffMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtValidationError blk -> FilePath
forall a. Show a => a -> FilePath
show) LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK)
-> ExtLedgerState blk DiffMK
forall (l :: LedgerStateKind) a. LedgerResult l a -> a
lrResult (Either
   (ExtValidationError blk)
   (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
 -> ExtLedgerState blk DiffMK)
-> Either
     (ExtValidationError blk)
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
-> ExtLedgerState blk DiffMK
forall a b. (a -> b) -> a -> b
$ Except
  (ExtValidationError blk)
  (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
-> Either
     (ExtValidationError blk)
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
forall e a. Except e a -> Either e a
runExcept Except
  (LedgerErr (ExtLedgerState blk))
  (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
Except
  (ExtValidationError blk)
  (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk DiffMK))
appliedResult
          newLedger'    = ExtLedgerState blk ValuesMK
-> ExtLedgerState blk DiffMK -> ExtLedgerState blk ValuesMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
l ValuesMK -> l' DiffMK -> l' ValuesMK
applyDiffs ExtLedgerState blk ValuesMK
oldLedger ExtLedgerState blk DiffMK
newLedger
          traces        =
            (WithLedgerState blk -> [FilePath]
forall blk. HasAnalysis blk => WithLedgerState blk -> [FilePath]
HasAnalysis.emitTraces (WithLedgerState blk -> [FilePath])
-> WithLedgerState blk -> [FilePath]
forall a b. (a -> b) -> a -> b
$
              blk
-> LedgerState blk ValuesMK
-> LedgerState blk ValuesMK
-> WithLedgerState blk
forall blk.
blk
-> LedgerState blk ValuesMK
-> LedgerState blk ValuesMK
-> WithLedgerState blk
HasAnalysis.WithLedgerState blk
blk (ExtLedgerState blk ValuesMK -> LedgerState blk ValuesMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState ExtLedgerState blk ValuesMK
oldLedger) (ExtLedgerState blk ValuesMK -> LedgerState blk ValuesMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState ExtLedgerState blk ValuesMK
newLedger'))
      mapM_ Debug.traceMarkerIO traces

      LedgerDB.push internal newLedger
      LedgerDB.tryFlush ledgerDB

{-------------------------------------------------------------------------------
  Analysis: maintain a ledger state and time the five major ledger calculations
  for each block:

  0. Forecast.
  1. Header tick.
  2. Header application.
  3. Block tick.
  4. Block application.

  We focus on these 5 operations because they are involved in:

  - Chain syncing.
  - Block forging.
  - Block validation.

-------------------------------------------------------------------------------}

benchmarkLedgerOps ::
     forall blk.
     ( LedgerSupportsProtocol blk
     , HasAnalysis blk
     )
  => Maybe FilePath
  -> LedgerApplicationMode
  -> Analysis blk StartFromLedgerState
benchmarkLedgerOps :: forall blk.
(LedgerSupportsProtocol blk, HasAnalysis blk) =>
Maybe FilePath
-> LedgerApplicationMode -> Analysis blk 'StartFromLedgerState
benchmarkLedgerOps Maybe FilePath
mOutfile LedgerApplicationMode
ledgerAppMode AnalysisEnv {ImmutableDB IO blk
db :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ImmutableDB IO blk
db :: ImmutableDB IO blk
db, ResourceRegistry IO
registry :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ResourceRegistry IO
registry :: ResourceRegistry IO
registry, AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom m blk startFrom
startFrom :: AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom, TopLevelConfig blk
cfg :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg, Limit
limit :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Limit
limit :: Limit
limit} = do
    -- We default to CSV when the no output file is provided (and thus the results are output to stdout).
    outFormat <- Maybe FilePath -> IO OutputFormat
F.getOutputFormat Maybe FilePath
mOutfile

    withFile mOutfile $ \Handle
outFileHandle -> do
      Handle -> OutputFormat -> LedgerApplicationMode -> IO ()
F.writeMetadata Handle
outFileHandle OutputFormat
outFormat LedgerApplicationMode
ledgerAppMode
      Handle -> OutputFormat -> IO ()
F.writeHeader   Handle
outFileHandle OutputFormat
outFormat

      IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk (blk, SizeInBytes)
-> AnalysisStartFrom IO blk 'StartFromLedgerState
-> Limit
-> ()
-> (() -> (blk, SizeInBytes) -> IO ())
-> IO ()
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> st
-> (st -> b -> IO st)
-> IO st
processAll
        ImmutableDB IO blk
db
        ResourceRegistry IO
registry
        ((,) (blk -> SizeInBytes -> (blk, SizeInBytes))
-> BlockComponent blk blk
-> BlockComponent blk (SizeInBytes -> (blk, SizeInBytes))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock BlockComponent blk (SizeInBytes -> (blk, SizeInBytes))
-> BlockComponent blk SizeInBytes
-> BlockComponent blk (blk, SizeInBytes)
forall a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk SizeInBytes
forall blk. BlockComponent blk SizeInBytes
GetBlockSize)
        AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom
        Limit
limit
        ()
        (LedgerDB' IO blk
-> TestInternals' IO blk
-> Handle
-> OutputFormat
-> ()
-> (blk, SizeInBytes)
-> IO ()
process LedgerDB' IO blk
initLedger TestInternals' IO blk
initial Handle
outFileHandle OutputFormat
outFormat)
      Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AnalysisResult
forall a. Maybe a
Nothing
  where
    ccfg :: ConsensusConfig (BlockProtocol blk)
ccfg = TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
topLevelConfigProtocol TopLevelConfig blk
cfg
    lcfg :: LedgerConfig blk
lcfg = TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
topLevelConfigLedger   TopLevelConfig blk
cfg

    FromLedgerState LedgerDB' IO blk
initLedger TestInternals' IO blk
initial = AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom

    process ::
         LedgerDB.LedgerDB' IO blk
      -> LedgerDB.TestInternals' IO blk
      -> IO.Handle
      -> F.OutputFormat
      -> ()
      -> (blk, SizeInBytes)
      -> IO ()
    process :: LedgerDB' IO blk
-> TestInternals' IO blk
-> Handle
-> OutputFormat
-> ()
-> (blk, SizeInBytes)
-> IO ()
process LedgerDB' IO blk
ledgerDB TestInternals' IO blk
intLedgerDB Handle
outFileHandle OutputFormat
outFormat ()
_ (blk
blk, SizeInBytes
sz) = do
        (prevLedgerState, tables) <- LedgerDB' IO blk
-> (Forker IO (ExtLedgerState blk) blk
    -> IO
         (ExtLedgerState blk EmptyMK,
          LedgerTables (ExtLedgerState blk) ValuesMK))
-> IO
     (ExtLedgerState blk EmptyMK,
      LedgerTables (ExtLedgerState blk) ValuesMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk a.
IOLike m =>
LedgerDB m l blk -> (Forker m l blk -> m a) -> m a
LedgerDB.withPrivateTipForker LedgerDB' IO blk
ledgerDB ((Forker IO (ExtLedgerState blk) blk
  -> IO
       (ExtLedgerState blk EmptyMK,
        LedgerTables (ExtLedgerState blk) ValuesMK))
 -> IO
      (ExtLedgerState blk EmptyMK,
       LedgerTables (ExtLedgerState blk) ValuesMK))
-> (Forker IO (ExtLedgerState blk) blk
    -> IO
         (ExtLedgerState blk EmptyMK,
          LedgerTables (ExtLedgerState blk) ValuesMK))
-> IO
     (ExtLedgerState blk EmptyMK,
      LedgerTables (ExtLedgerState blk) ValuesMK)
forall a b. (a -> b) -> a -> b
$ \Forker IO (ExtLedgerState blk) blk
frk -> do
          st <- STM IO (ExtLedgerState blk EmptyMK)
-> IO (ExtLedgerState blk EmptyMK)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
IOLike.atomically (STM IO (ExtLedgerState blk EmptyMK)
 -> IO (ExtLedgerState blk EmptyMK))
-> STM IO (ExtLedgerState blk EmptyMK)
-> IO (ExtLedgerState blk EmptyMK)
forall a b. (a -> b) -> a -> b
$ Forker IO (ExtLedgerState blk) blk
-> STM IO (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> STM m (l EmptyMK)
LedgerDB.forkerGetLedgerState Forker IO (ExtLedgerState blk) blk
frk
          tbs <- LedgerDB.forkerReadTables frk (getBlockKeySets blk)
          pure (st, tbs)
        prevRtsStats <- GC.getRTSStats
        let
          -- Compute how many nanoseconds the mutator used from the last
          -- recorded 'elapsedTime' till the end of the execution of the given
          -- action. This function forces the evaluation of its argument's
          -- result.
          time IO a
act = do
              tPrev <- RTSStats -> Int64
GC.mutator_elapsed_ns (RTSStats -> Int64) -> IO RTSStats -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO RTSStats
GC.getRTSStats
              !r <- act
              tNow <- GC.mutator_elapsed_ns <$> GC.getRTSStats
              pure (r, tNow - tPrev)

        let slot = blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot      blk
blk
        -- We do not use strictness annotation on the resulting tuples since
        -- 'time' takes care of forcing the evaluation of its argument's result.
        (ldgrView, tForecast) <- time $ forecast            slot prevLedgerState
        (tkHdrSt,  tHdrTick)  <- time $ tickTheHeaderState  slot prevLedgerState ldgrView
        (!newHeader,   tHdrApp)       <- time $ applyTheHeader                           ldgrView tkHdrSt
        (tkLdgrSt, tBlkTick)  <- time $ tickTheLedgerState  slot prevLedgerState
        let !tkLdgrSt' = ExtLedgerState blk ValuesMK
-> Ticked (LedgerState blk) DiffMK
-> Ticked (LedgerState blk) ValuesMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
l ValuesMK -> l' DiffMK -> l' ValuesMK
applyDiffs (ExtLedgerState blk EmptyMK
prevLedgerState ExtLedgerState blk EmptyMK
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> ExtLedgerState blk ValuesMK
forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
ExtLedgerState blk any
-> LedgerTables (ExtLedgerState blk) mk -> ExtLedgerState blk mk
forall (l :: LedgerStateKind) (mk :: MapKind) (any :: MapKind).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
`withLedgerTables` LedgerTables (ExtLedgerState blk) ValuesMK
tables) Ticked (LedgerState blk) DiffMK
tkLdgrSt
        (!newLedger,  tBlkApp)        <- time $ applyTheBlock                                     tkLdgrSt'

        currentRtsStats <- GC.getRTSStats
        let
          currentMinusPrevious :: Num a => (GC.RTSStats -> a) -> a
          currentMinusPrevious RTSStats -> a
f = RTSStats -> a
f RTSStats
currentRtsStats a -> a -> a
forall a. Num a => a -> a -> a
- RTSStats -> a
f RTSStats
prevRtsStats
          major_gcs              = (RTSStats -> Word32) -> Word32
forall a. Num a => (RTSStats -> a) -> a
currentMinusPrevious RTSStats -> Word32
GC.major_gcs
          slotDataPoint =
            DP.SlotDataPoint
            { slot :: SlotNo
DP.slot            = RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot RealPoint blk
rp
            , slotGap :: Word64
DP.slotGap         = SlotNo
slot SlotNo -> WithOrigin SlotNo -> Word64
`slotCount` ExtLedgerState blk EmptyMK -> WithOrigin SlotNo
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot ExtLedgerState blk EmptyMK
prevLedgerState
            , totalTime :: Int64
DP.totalTime       = (RTSStats -> Int64) -> Int64
forall a. Num a => (RTSStats -> a) -> a
currentMinusPrevious RTSStats -> Int64
GC.elapsed_ns          Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
1000
            , mut :: Int64
DP.mut             = (RTSStats -> Int64) -> Int64
forall a. Num a => (RTSStats -> a) -> a
currentMinusPrevious RTSStats -> Int64
GC.mutator_elapsed_ns  Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
1000
            , gc :: Int64
DP.gc              = (RTSStats -> Int64) -> Int64
forall a. Num a => (RTSStats -> a) -> a
currentMinusPrevious RTSStats -> Int64
GC.gc_elapsed_ns       Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
1000
            , majGcCount :: Word32
DP.majGcCount      = Word32
major_gcs
            , minGcCount :: Word32
DP.minGcCount      = (RTSStats -> Word32) -> Word32
forall a. Num a => (RTSStats -> a) -> a
currentMinusPrevious RTSStats -> Word32
GC.gcs Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
major_gcs
            , allocatedBytes :: Word64
DP.allocatedBytes  = (RTSStats -> Word64) -> Word64
forall a. Num a => (RTSStats -> a) -> a
currentMinusPrevious RTSStats -> Word64
GC.allocated_bytes
            , mut_forecast :: Int64
DP.mut_forecast    = Int64
tForecast Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
1000
            , mut_headerTick :: Int64
DP.mut_headerTick  = Int64
tHdrTick  Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
1000
            , mut_headerApply :: Int64
DP.mut_headerApply = Int64
tHdrApp   Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
1000
            , mut_blockTick :: Int64
DP.mut_blockTick   = Int64
tBlkTick  Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
1000
            , mut_blockApply :: Int64
DP.mut_blockApply  = Int64
tBlkApp   Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
1000
            , blockByteSize :: Word32
DP.blockByteSize   = SizeInBytes -> Word32
getSizeInBytes SizeInBytes
sz
            , blockStats :: BlockStats
DP.blockStats      = [TextBuilder] -> BlockStats
DP.BlockStats ([TextBuilder] -> BlockStats) -> [TextBuilder] -> BlockStats
forall a b. (a -> b) -> a -> b
$ blk -> [TextBuilder]
forall blk. HasAnalysis blk => blk -> [TextBuilder]
HasAnalysis.blockStats blk
blk
            }

          slotCount (SlotNo Word64
i) = \case
            WithOrigin SlotNo
Slotting.Origin        -> Word64
i
            Slotting.At (SlotNo Word64
j) -> Word64
i Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
j

        F.writeDataPoint outFileHandle outFormat slotDataPoint

        LedgerDB.push intLedgerDB $ ExtLedgerState newLedger newHeader
        LedgerDB.tryFlush ledgerDB
      where
        rp :: RealPoint blk
rp = blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
blk

        forecast ::
             SlotNo
          -> ExtLedgerState blk mk
          -> IO (LedgerView (BlockProtocol blk))
        forecast :: forall (mk :: MapKind).
SlotNo
-> ExtLedgerState blk mk -> IO (LedgerView (BlockProtocol blk))
forecast SlotNo
slot ExtLedgerState blk mk
st = do
            let forecaster :: Forecast (LedgerView (BlockProtocol blk))
forecaster = LedgerConfig blk
-> LedgerState blk mk -> Forecast (LedgerView (BlockProtocol blk))
forall blk (mk :: MapKind).
(LedgerSupportsProtocol blk, HasCallStack) =>
LedgerConfig blk
-> LedgerState blk mk -> Forecast (LedgerView (BlockProtocol blk))
forall (mk :: MapKind).
HasCallStack =>
LedgerConfig blk
-> LedgerState blk mk -> Forecast (LedgerView (BlockProtocol blk))
ledgerViewForecastAt LedgerConfig blk
lcfg (ExtLedgerState blk mk -> LedgerState blk mk
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState ExtLedgerState blk mk
st)
            case Except OutsideForecastRange (LedgerView (BlockProtocol blk))
-> Either OutsideForecastRange (LedgerView (BlockProtocol blk))
forall e a. Except e a -> Either e a
runExcept (Except OutsideForecastRange (LedgerView (BlockProtocol blk))
 -> Either OutsideForecastRange (LedgerView (BlockProtocol blk)))
-> Except OutsideForecastRange (LedgerView (BlockProtocol blk))
-> Either OutsideForecastRange (LedgerView (BlockProtocol blk))
forall a b. (a -> b) -> a -> b
$ Forecast (LedgerView (BlockProtocol blk))
-> SlotNo
-> Except OutsideForecastRange (LedgerView (BlockProtocol blk))
forall a. Forecast a -> SlotNo -> Except OutsideForecastRange a
forecastFor Forecast (LedgerView (BlockProtocol blk))
forecaster SlotNo
slot of
              Left OutsideForecastRange
err -> FilePath -> IO (LedgerView (BlockProtocol blk))
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO (LedgerView (BlockProtocol blk)))
-> FilePath -> IO (LedgerView (BlockProtocol blk))
forall a b. (a -> b) -> a -> b
$ FilePath
"benchmark doesn't support headers beyond the forecast limit: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> RealPoint blk -> FilePath
forall a. Show a => a -> FilePath
show RealPoint blk
rp FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> OutsideForecastRange -> FilePath
forall a. Show a => a -> FilePath
show OutsideForecastRange
err
              Right LedgerView (BlockProtocol blk)
x  -> LedgerView (BlockProtocol blk)
-> IO (LedgerView (BlockProtocol blk))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerView (BlockProtocol blk)
x

        tickTheHeaderState ::
             SlotNo
          -> ExtLedgerState blk mk
          -> LedgerView (BlockProtocol blk)
          -> IO (Ticked (HeaderState blk))
        tickTheHeaderState :: forall (mk :: MapKind).
SlotNo
-> ExtLedgerState blk mk
-> LedgerView (BlockProtocol blk)
-> IO (Ticked (HeaderState blk))
tickTheHeaderState SlotNo
slot ExtLedgerState blk mk
st LedgerView (BlockProtocol blk)
ledgerView =
            Ticked (HeaderState blk) -> IO (Ticked (HeaderState blk))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ticked (HeaderState blk) -> IO (Ticked (HeaderState blk)))
-> Ticked (HeaderState blk) -> IO (Ticked (HeaderState blk))
forall a b. (a -> b) -> a -> b
$! ConsensusConfig (BlockProtocol blk)
-> LedgerView (BlockProtocol blk)
-> SlotNo
-> HeaderState blk
-> Ticked (HeaderState blk)
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
ConsensusConfig (BlockProtocol blk)
-> LedgerView (BlockProtocol blk)
-> SlotNo
-> HeaderState blk
-> Ticked (HeaderState blk)
tickHeaderState ConsensusConfig (BlockProtocol blk)
ccfg
                                    LedgerView (BlockProtocol blk)
ledgerView
                                    SlotNo
slot
                                    (ExtLedgerState blk mk -> HeaderState blk
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> HeaderState blk
headerState ExtLedgerState blk mk
st)

        applyTheHeader ::
             LedgerView (BlockProtocol blk)
          -> Ticked (HeaderState blk)
          -> IO (HeaderState blk)
        applyTheHeader :: LedgerView (BlockProtocol blk)
-> Ticked (HeaderState blk) -> IO (HeaderState blk)
applyTheHeader LedgerView (BlockProtocol blk)
ledgerView Ticked (HeaderState blk)
tickedHeaderState = case LedgerApplicationMode
ledgerAppMode of
          LedgerApplicationMode
LedgerApply ->
            case Except (HeaderError blk) (HeaderState blk)
-> Either (HeaderError blk) (HeaderState blk)
forall e a. Except e a -> Either e a
runExcept (Except (HeaderError blk) (HeaderState blk)
 -> Either (HeaderError blk) (HeaderState blk))
-> Except (HeaderError blk) (HeaderState blk)
-> Either (HeaderError blk) (HeaderState blk)
forall a b. (a -> b) -> a -> b
$ TopLevelConfig blk
-> LedgerView (BlockProtocol blk)
-> Header blk
-> Ticked (HeaderState blk)
-> Except (HeaderError blk) (HeaderState blk)
forall blk.
(BlockSupportsProtocol blk, ValidateEnvelope blk) =>
TopLevelConfig blk
-> LedgerView (BlockProtocol blk)
-> Header blk
-> Ticked (HeaderState blk)
-> Except (HeaderError blk) (HeaderState blk)
validateHeader TopLevelConfig blk
cfg LedgerView (BlockProtocol blk)
ledgerView (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk) Ticked (HeaderState blk)
tickedHeaderState of
              Left HeaderError blk
err -> FilePath -> IO (HeaderState blk)
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO (HeaderState blk))
-> FilePath -> IO (HeaderState blk)
forall a b. (a -> b) -> a -> b
$ FilePath
"benchmark doesn't support invalid headers: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> RealPoint blk -> FilePath
forall a. Show a => a -> FilePath
show RealPoint blk
rp FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> HeaderError blk -> FilePath
forall a. Show a => a -> FilePath
show HeaderError blk
err
              Right HeaderState blk
x -> HeaderState blk -> IO (HeaderState blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeaderState blk
x
          LedgerApplicationMode
LedgerReapply ->
            HeaderState blk -> IO (HeaderState blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HeaderState blk -> IO (HeaderState blk))
-> HeaderState blk -> IO (HeaderState blk)
forall a b. (a -> b) -> a -> b
$! TopLevelConfig blk
-> LedgerView (BlockProtocol blk)
-> Header blk
-> Ticked (HeaderState blk)
-> HeaderState blk
forall blk.
(BlockSupportsProtocol blk, ValidateEnvelope blk, HasCallStack) =>
TopLevelConfig blk
-> LedgerView (BlockProtocol blk)
-> Header blk
-> Ticked (HeaderState blk)
-> HeaderState blk
revalidateHeader TopLevelConfig blk
cfg LedgerView (BlockProtocol blk)
ledgerView (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk) Ticked (HeaderState blk)
tickedHeaderState

        tickTheLedgerState ::
             SlotNo
          -> ExtLedgerState blk EmptyMK
          -> IO (Ticked (LedgerState blk) DiffMK)
        tickTheLedgerState :: SlotNo
-> ExtLedgerState blk EmptyMK
-> IO (Ticked (LedgerState blk) DiffMK)
tickTheLedgerState SlotNo
slot ExtLedgerState blk EmptyMK
st =
            Ticked (LedgerState blk) DiffMK
-> IO (Ticked (LedgerState blk) DiffMK)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ticked (LedgerState blk) DiffMK
 -> IO (Ticked (LedgerState blk) DiffMK))
-> Ticked (LedgerState blk) DiffMK
-> IO (Ticked (LedgerState blk) DiffMK)
forall a b. (a -> b) -> a -> b
$ ComputeLedgerEvents
-> LedgerConfig blk
-> SlotNo
-> LedgerState blk EmptyMK
-> Ticked (LedgerState blk) DiffMK
forall (l :: LedgerStateKind).
IsLedger l =>
ComputeLedgerEvents
-> LedgerCfg l -> SlotNo -> l EmptyMK -> Ticked l DiffMK
applyChainTick ComputeLedgerEvents
OmitLedgerEvents LedgerConfig blk
lcfg SlotNo
slot (ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState ExtLedgerState blk EmptyMK
st)

        applyTheBlock ::
             TickedLedgerState blk ValuesMK
          -> IO (LedgerState blk DiffMK)
        applyTheBlock :: Ticked (LedgerState blk) ValuesMK -> IO (LedgerState blk DiffMK)
applyTheBlock Ticked (LedgerState blk) ValuesMK
tickedLedgerSt = case LedgerApplicationMode
ledgerAppMode of
          LedgerApplicationMode
LedgerApply ->
            case Except (LedgerErr (LedgerState blk)) (LedgerState blk DiffMK)
-> Either (LedgerErr (LedgerState blk)) (LedgerState blk DiffMK)
forall e a. Except e a -> Either e a
runExcept (LedgerResult (LedgerState blk) (LedgerState blk DiffMK)
-> LedgerState blk DiffMK
forall (l :: LedgerStateKind) a. LedgerResult l a -> a
lrResult (LedgerResult (LedgerState blk) (LedgerState blk DiffMK)
 -> LedgerState blk DiffMK)
-> ExceptT
     (LedgerErr (LedgerState blk))
     Identity
     (LedgerResult (LedgerState blk) (LedgerState blk DiffMK))
-> Except (LedgerErr (LedgerState blk)) (LedgerState blk DiffMK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ComputeLedgerEvents
-> LedgerConfig blk
-> blk
-> Ticked (LedgerState blk) ValuesMK
-> ExceptT
     (LedgerErr (LedgerState blk))
     Identity
     (LedgerResult (LedgerState blk) (LedgerState blk DiffMK))
forall (l :: LedgerStateKind) blk.
(ApplyBlock l blk, HasCallStack) =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> Ticked l ValuesMK
-> Except (LedgerErr l) (LedgerResult l (l DiffMK))
applyBlockLedgerResult ComputeLedgerEvents
OmitLedgerEvents LedgerConfig blk
lcfg blk
blk Ticked (LedgerState blk) ValuesMK
tickedLedgerSt) of
              Left LedgerErr (LedgerState blk)
err -> FilePath -> IO (LedgerState blk DiffMK)
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO (LedgerState blk DiffMK))
-> FilePath -> IO (LedgerState blk DiffMK)
forall a b. (a -> b) -> a -> b
$ FilePath
"benchmark doesn't support invalid blocks: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> RealPoint blk -> FilePath
forall a. Show a => a -> FilePath
show RealPoint blk
rp FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> LedgerErr (LedgerState blk) -> FilePath
forall a. Show a => a -> FilePath
show LedgerErr (LedgerState blk)
err
              Right LedgerState blk DiffMK
x  -> LedgerState blk DiffMK -> IO (LedgerState blk DiffMK)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerState blk DiffMK
x
          LedgerApplicationMode
LedgerReapply ->
            LedgerState blk DiffMK -> IO (LedgerState blk DiffMK)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LedgerState blk DiffMK -> IO (LedgerState blk DiffMK))
-> LedgerState blk DiffMK -> IO (LedgerState blk DiffMK)
forall a b. (a -> b) -> a -> b
$! LedgerResult (LedgerState blk) (LedgerState blk DiffMK)
-> LedgerState blk DiffMK
forall (l :: LedgerStateKind) a. LedgerResult l a -> a
lrResult (LedgerResult (LedgerState blk) (LedgerState blk DiffMK)
 -> LedgerState blk DiffMK)
-> LedgerResult (LedgerState blk) (LedgerState blk DiffMK)
-> LedgerState blk DiffMK
forall a b. (a -> b) -> a -> b
$ ComputeLedgerEvents
-> LedgerConfig blk
-> blk
-> Ticked (LedgerState blk) ValuesMK
-> LedgerResult (LedgerState blk) (LedgerState blk DiffMK)
forall (l :: LedgerStateKind) blk.
(ApplyBlock l blk, HasCallStack) =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> Ticked l ValuesMK
-> LedgerResult l (l DiffMK)
reapplyBlockLedgerResult ComputeLedgerEvents
OmitLedgerEvents LedgerConfig blk
lcfg blk
blk Ticked (LedgerState blk) ValuesMK
tickedLedgerSt

withFile :: Maybe FilePath -> (IO.Handle -> IO r) -> IO r
withFile :: forall r. Maybe FilePath -> (Handle -> IO r) -> IO r
withFile (Just FilePath
outfile) = FilePath -> IOMode -> (Handle -> IO r) -> IO r
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile FilePath
outfile IOMode
IO.WriteMode
withFile Maybe FilePath
Nothing        = \Handle -> IO r
f -> Handle -> IO r
f Handle
IO.stdout

{-------------------------------------------------------------------------------
  Analysis: trace ledger state metrics
-------------------------------------------------------------------------------}

getBlockApplicationMetrics ::
    forall blk .
    ( HasAnalysis blk
    , LedgerSupportsProtocol blk
    )
  => NumberOfBlocks -> Maybe FilePath -> Analysis blk StartFromLedgerState
getBlockApplicationMetrics :: forall blk.
(HasAnalysis blk, LedgerSupportsProtocol blk) =>
NumberOfBlocks
-> Maybe FilePath -> Analysis blk 'StartFromLedgerState
getBlockApplicationMetrics (NumberOfBlocks Word64
nrBlocks) Maybe FilePath
mOutFile AnalysisEnv IO blk 'StartFromLedgerState
env = do
    Maybe FilePath
-> (Handle -> IO (Maybe AnalysisResult))
-> IO (Maybe AnalysisResult)
forall r. Maybe FilePath -> (Handle -> IO r) -> IO r
withFile Maybe FilePath
mOutFile ((Handle -> IO (Maybe AnalysisResult))
 -> IO (Maybe AnalysisResult))
-> (Handle -> IO (Maybe AnalysisResult))
-> IO (Maybe AnalysisResult)
forall a b. (a -> b) -> a -> b
$ \Handle
outFileHandle -> do
        Handle
-> Separator
-> [(TextBuilder, WithLedgerState blk -> IO TextBuilder)]
-> IO ()
forall a. Handle -> Separator -> [(TextBuilder, a)] -> IO ()
writeHeaderLine Handle
outFileHandle Separator
separator (forall blk.
HasAnalysis blk =>
[(TextBuilder, WithLedgerState blk -> IO TextBuilder)]
HasAnalysis.blockApplicationMetrics @blk)
        IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk blk
-> AnalysisStartFrom IO blk 'StartFromLedgerState
-> Limit
-> ()
-> (() -> blk -> IO ())
-> IO ()
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> st
-> (st -> b -> IO st)
-> IO st
processAll ImmutableDB IO blk
db ResourceRegistry IO
registry BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom Limit
limit () (LedgerDB' IO blk
-> TestInternals' IO blk -> Handle -> () -> blk -> IO ()
process LedgerDB' IO blk
initLedger TestInternals' IO blk
internal Handle
outFileHandle)
        Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AnalysisResult
forall a. Maybe a
Nothing
  where
    separator :: Separator
separator = Separator
", "

    AnalysisEnv {ImmutableDB IO blk
db :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ImmutableDB IO blk
db :: ImmutableDB IO blk
db, ResourceRegistry IO
registry :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ResourceRegistry IO
registry :: ResourceRegistry IO
registry, AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom m blk startFrom
startFrom :: AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom, TopLevelConfig blk
cfg :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg, Limit
limit :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Limit
limit :: Limit
limit } = AnalysisEnv IO blk 'StartFromLedgerState
env
    FromLedgerState LedgerDB' IO blk
initLedger TestInternals' IO blk
internal = AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom

    process ::
         LedgerDB.LedgerDB' IO blk
      -> LedgerDB.TestInternals' IO blk
      -> IO.Handle
      -> ()
      -> blk
      -> IO ()
    process :: LedgerDB' IO blk
-> TestInternals' IO blk -> Handle -> () -> blk -> IO ()
process LedgerDB' IO blk
ledgerDB TestInternals' IO blk
intLedgerDB Handle
outFileHandle ()
_ blk
blk = do
      frk <- LedgerDB' IO blk
-> ResourceRegistry IO
-> Target (Point blk)
-> IO (Either GetForkerError (Forker IO (ExtLedgerState blk) blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
LedgerDB.getForkerAtTarget LedgerDB' IO blk
ledgerDB ResourceRegistry IO
registry Target (Point blk)
forall point. Target point
VolatileTip IO (Either GetForkerError (Forker IO (ExtLedgerState blk) blk))
-> (Either GetForkerError (Forker IO (ExtLedgerState blk) blk)
    -> IO (Forker IO (ExtLedgerState blk) blk))
-> IO (Forker IO (ExtLedgerState blk) blk)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left {} -> FilePath -> IO (Forker IO (ExtLedgerState blk) blk)
forall a. HasCallStack => FilePath -> a
error FilePath
"Unreachable, volatile tip MUST be in the LedgerDB"
        Right Forker IO (ExtLedgerState blk) blk
f -> Forker IO (ExtLedgerState blk) blk
-> IO (Forker IO (ExtLedgerState blk) blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Forker IO (ExtLedgerState blk) blk
f
      oldLedgerSt <- IOLike.atomically $ LedgerDB.forkerGetLedgerState frk
      oldLedgerTbs <- LedgerDB.forkerReadTables frk (getBlockKeySets blk)
      let oldLedger = ExtLedgerState blk EmptyMK
oldLedgerSt ExtLedgerState blk EmptyMK
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> ExtLedgerState blk ValuesMK
forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
ExtLedgerState blk any
-> LedgerTables (ExtLedgerState blk) mk -> ExtLedgerState blk mk
forall (l :: LedgerStateKind) (mk :: MapKind) (any :: MapKind).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
`withLedgerTables` LedgerTables (ExtLedgerState blk) ValuesMK
oldLedgerTbs
      LedgerDB.forkerClose frk

      let nextLedgerSt = ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> blk
-> ExtLedgerState blk ValuesMK
-> ExtLedgerState blk DiffMK
forall (l :: LedgerStateKind) blk.
ApplyBlock l blk =>
ComputeLedgerEvents -> LedgerCfg l -> blk -> l ValuesMK -> l DiffMK
tickThenReapply ComputeLedgerEvents
OmitLedgerEvents (TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
cfg) blk
blk ExtLedgerState blk ValuesMK
oldLedger
      when (unBlockNo (blockNo blk) `mod` nrBlocks == 0) $ do
          let blockApplication =
                blk
-> LedgerState blk ValuesMK
-> LedgerState blk ValuesMK
-> WithLedgerState blk
forall blk.
blk
-> LedgerState blk ValuesMK
-> LedgerState blk ValuesMK
-> WithLedgerState blk
HasAnalysis.WithLedgerState blk
blk
                                            (ExtLedgerState blk ValuesMK -> LedgerState blk ValuesMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState ExtLedgerState blk ValuesMK
oldLedger)
                                            (ExtLedgerState blk ValuesMK -> LedgerState blk ValuesMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState (ExtLedgerState blk ValuesMK -> LedgerState blk ValuesMK)
-> ExtLedgerState blk ValuesMK -> LedgerState blk ValuesMK
forall a b. (a -> b) -> a -> b
$ ExtLedgerState blk ValuesMK
-> ExtLedgerState blk DiffMK -> ExtLedgerState blk ValuesMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
l ValuesMK -> l' DiffMK -> l' ValuesMK
applyDiffs ExtLedgerState blk ValuesMK
oldLedger ExtLedgerState blk DiffMK
nextLedgerSt)

          computeAndWriteLine outFileHandle
                              separator
                              (HasAnalysis.blockApplicationMetrics @blk)
                              blockApplication

          IO.hFlush outFileHandle

      LedgerDB.push intLedgerDB nextLedgerSt
      LedgerDB.tryFlush ledgerDB

      pure ()

{-------------------------------------------------------------------------------
  Analysis: reforge the blocks, via the mempool
-------------------------------------------------------------------------------}

data ReproMempoolForgeHowManyBlks = ReproMempoolForgeOneBlk | ReproMempoolForgeTwoBlks

reproMempoolForge ::
  forall blk.
  ( HasAnalysis blk
  , LedgerSupportsMempool.HasTxId (LedgerSupportsMempool.GenTx blk)
  , LedgerSupportsMempool.HasTxs blk
  , LedgerSupportsMempool blk
  , LedgerSupportsProtocol blk
  ) =>
  Int ->
  Analysis blk StartFromLedgerState
reproMempoolForge :: forall blk.
(HasAnalysis blk, HasTxId (GenTx blk), HasTxs blk,
 LedgerSupportsMempool blk, LedgerSupportsProtocol blk) =>
Int -> Analysis blk 'StartFromLedgerState
reproMempoolForge Int
numBlks AnalysisEnv IO blk 'StartFromLedgerState
env = do
    howManyBlocks <- case Int
numBlks of
      Int
1 -> ReproMempoolForgeHowManyBlks -> IO ReproMempoolForgeHowManyBlks
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReproMempoolForgeHowManyBlks
ReproMempoolForgeOneBlk
      Int
2 -> ReproMempoolForgeHowManyBlks -> IO ReproMempoolForgeHowManyBlks
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReproMempoolForgeHowManyBlks
ReproMempoolForgeTwoBlks
      Int
_ -> FilePath -> IO ReproMempoolForgeHowManyBlks
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ReproMempoolForgeHowManyBlks)
-> FilePath -> IO ReproMempoolForgeHowManyBlks
forall a b. (a -> b) -> a -> b
$ FilePath
"--repro-mempool-and-forge only supports"
               FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"1 or 2 blocks at a time, not " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
numBlks

    mempool <- Mempool.openMempoolWithoutSyncThread
      Mempool.LedgerInterface {
          Mempool.getCurrentLedgerState = ledgerState <$> LedgerDB.getVolatileTip ledgerDB
        , Mempool.getLedgerTablesAtFor = \Point blk
pt LedgerTables (LedgerState blk) KeysMK
keys -> do
            frk <- LedgerDB IO (ExtLedgerState blk) blk
-> ResourceRegistry IO
-> Target (Point blk)
-> IO (Either GetForkerError (Forker IO (ExtLedgerState blk) blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
LedgerDB.getForkerAtTarget LedgerDB IO (ExtLedgerState blk) blk
ledgerDB ResourceRegistry IO
registry (Point blk -> Target (Point blk)
forall point. point -> Target point
SpecificPoint Point blk
pt)
            case frk of
              Left GetForkerError
_ -> Maybe (LedgerTables (LedgerState blk) ValuesMK)
-> IO (Maybe (LedgerTables (LedgerState blk) ValuesMK))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (LedgerTables (LedgerState blk) ValuesMK)
forall a. Maybe a
Nothing
              Right Forker IO (ExtLedgerState blk) blk
fr -> do
                tbs <- LedgerTables (LedgerState blk) ValuesMK
-> Maybe (LedgerTables (LedgerState blk) ValuesMK)
forall a. a -> Maybe a
Just (LedgerTables (LedgerState blk) ValuesMK
 -> Maybe (LedgerTables (LedgerState blk) ValuesMK))
-> (LedgerTables (ExtLedgerState blk) ValuesMK
    -> LedgerTables (LedgerState blk) ValuesMK)
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> Maybe (LedgerTables (LedgerState blk) ValuesMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerTables (ExtLedgerState blk) ValuesMK
-> LedgerTables (LedgerState blk) ValuesMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: MapKind).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables
                   (LedgerTables (ExtLedgerState blk) ValuesMK
 -> Maybe (LedgerTables (LedgerState blk) ValuesMK))
-> IO (LedgerTables (ExtLedgerState blk) ValuesMK)
-> IO (Maybe (LedgerTables (LedgerState blk) ValuesMK))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Forker IO (ExtLedgerState blk) blk
-> LedgerTables (ExtLedgerState blk) KeysMK
-> IO (LedgerTables (ExtLedgerState blk) ValuesMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk
-> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
LedgerDB.forkerReadTables Forker IO (ExtLedgerState blk) blk
fr (LedgerTables (LedgerState blk) KeysMK
-> LedgerTables (ExtLedgerState blk) KeysMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: MapKind).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables LedgerTables (LedgerState blk) KeysMK
keys)
                LedgerDB.forkerClose fr
                pure tbs

      }
      lCfg
      -- one mebibyte should generously accomodate two blocks' worth of txs
      ( Mempool.MempoolCapacityBytesOverride
      $ LedgerSupportsMempool.ByteSize32
      $ 1024*1024
      )
      nullTracer

    void $ processAll db registry GetBlock startFrom limit Nothing (process howManyBlocks mempool)
    pure Nothing
  where
    AnalysisEnv {
      TopLevelConfig blk
cfg :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg
    , startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom m blk startFrom
startFrom = startFrom :: AnalysisStartFrom IO blk 'StartFromLedgerState
startFrom@(FromLedgerState LedgerDB IO (ExtLedgerState blk) blk
ledgerDB TestInternals' IO blk
intLedgerDB)
    , ImmutableDB IO blk
db :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ImmutableDB IO blk
db :: ImmutableDB IO blk
db
    , ResourceRegistry IO
registry :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> ResourceRegistry IO
registry :: ResourceRegistry IO
registry
    , Limit
limit :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Limit
limit :: Limit
limit
    , Tracer IO (TraceEvent blk)
tracer :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> Tracer m (TraceEvent blk)
tracer :: Tracer IO (TraceEvent blk)
tracer
    } = AnalysisEnv IO blk 'StartFromLedgerState
env

    lCfg :: LedgerConfig blk
    lCfg :: LedgerConfig blk
lCfg = TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg

    timed :: IO a -> IO (a, IOLike.DiffTime, Int64, Int64)
    timed :: forall a. IO a -> IO (a, DiffTime, Int64, Int64)
timed IO a
m = do
      before <- IO Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
IOLike.getMonotonicTime
      prevRtsStats <- GC.getRTSStats
      !x <- m
      newRtsStats <- GC.getRTSStats
      after <- IOLike.getMonotonicTime
      pure ( x
           , after `IOLike.diffTime` before
           , (GC.mutator_elapsed_ns newRtsStats - GC.mutator_elapsed_ns prevRtsStats) `div` 1000
           , (GC.gc_elapsed_ns newRtsStats - GC.gc_elapsed_ns prevRtsStats) `div` 1000
           )

    process
      :: ReproMempoolForgeHowManyBlks
      -> Mempool.Mempool IO blk
      -> Maybe blk
      -> blk
      -> IO (Maybe blk)
    process :: ReproMempoolForgeHowManyBlks
-> Mempool IO blk -> Maybe blk -> blk -> IO (Maybe blk)
process ReproMempoolForgeHowManyBlks
howManyBlocks Mempool IO blk
mempool Maybe blk
mbBlk blk
blk' = (\() -> blk -> Maybe blk
forall a. a -> Maybe a
Just blk
blk') (() -> Maybe blk) -> IO () -> IO (Maybe blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      -- add this block's transactions to the mempool
      do
        results <- Mempool IO blk -> [GenTx blk] -> IO [MempoolAddTxResult blk]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
Mempool.addTxs Mempool IO blk
mempool ([GenTx blk] -> IO [MempoolAddTxResult blk])
-> [GenTx blk] -> IO [MempoolAddTxResult blk]
forall a b. (a -> b) -> a -> b
$ blk -> [GenTx blk]
forall blk. HasTxs blk => blk -> [GenTx blk]
LedgerSupportsMempool.extractTxs blk
blk'
        let rejs =
              [ (GenTx blk -> TxId (GenTx blk)
forall tx. HasTxId tx => tx -> TxId tx
LedgerSupportsMempool.txId GenTx blk
tx, MempoolAddTxResult blk
rej)
              | rej :: MempoolAddTxResult blk
rej@(Mempool.MempoolTxRejected GenTx blk
tx ApplyTxErr blk
_) <- [MempoolAddTxResult blk]
results
              ]
        unless (null rejs) $ do
          fail $ unlines $
               ["Mempool rejected some of the on-chain txs: " <> show rejs]
            <> case howManyBlocks of
                 ReproMempoolForgeHowManyBlks
ReproMempoolForgeOneBlk -> []
                 ReproMempoolForgeHowManyBlks
ReproMempoolForgeTwoBlks ->
                   [ FilePath
"This might be expected, see the db-analyser README."
                   , FilePath
"Consider trying again with `--repro-mempool-and-forge 1`."
                   ]

      let scrutinee :: Maybe blk
scrutinee = case ReproMempoolForgeHowManyBlks
howManyBlocks of
            ReproMempoolForgeHowManyBlks
ReproMempoolForgeOneBlk  -> blk -> Maybe blk
forall a. a -> Maybe a
Just blk
blk'
            ReproMempoolForgeHowManyBlks
ReproMempoolForgeTwoBlks -> Maybe blk
mbBlk
      case Maybe blk
scrutinee of
        Maybe blk
Nothing  -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just blk
blk -> do
          LedgerDB IO (ExtLedgerState blk) blk
-> (Forker IO (ExtLedgerState blk) blk -> IO ()) -> IO ()
forall (m :: * -> *) (l :: LedgerStateKind) blk a.
IOLike m =>
LedgerDB m l blk -> (Forker m l blk -> m a) -> m a
LedgerDB.withPrivateTipForker LedgerDB IO (ExtLedgerState blk) blk
ledgerDB ((Forker IO (ExtLedgerState blk) blk -> IO ()) -> IO ())
-> (Forker IO (ExtLedgerState blk) blk -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Forker IO (ExtLedgerState blk) blk
forker -> do
            st <- STM IO (ExtLedgerState blk EmptyMK)
-> IO (ExtLedgerState blk EmptyMK)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
IOLike.atomically (STM IO (ExtLedgerState blk EmptyMK)
 -> IO (ExtLedgerState blk EmptyMK))
-> STM IO (ExtLedgerState blk EmptyMK)
-> IO (ExtLedgerState blk EmptyMK)
forall a b. (a -> b) -> a -> b
$ Forker IO (ExtLedgerState blk) blk
-> STM IO (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> STM m (l EmptyMK)
LedgerDB.forkerGetLedgerState Forker IO (ExtLedgerState blk) blk
forker

            -- time the suspected slow parts of the forge thread that created
            -- this block
            --
            -- Primary caveat: that thread's mempool may have had more transactions in it.
            let slot = blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk
            (ticked, durTick, mutTick, gcTick) <- timed $ IOLike.evaluate $
                applyChainTick OmitLedgerEvents lCfg slot (ledgerState st)
            ((), durSnap, mutSnap, gcSnap) <- timed $ do
                snap <- Mempool.getSnapshotFor mempool slot ticked $
                  fmap castLedgerTables . LedgerDB.forkerReadTables forker . castLedgerTables

                pure $ length (Mempool.snapshotTxs snap) `seq` Mempool.snapshotStateHash snap `seq` ()

            let sizes = blk -> [SizeInBytes]
forall blk. HasAnalysis blk => blk -> [SizeInBytes]
HasAnalysis.blockTxSizes blk
blk
            traceWith tracer $
              BlockMempoolAndForgeRepro
                (blockNo blk)
                slot
                (length sizes)
                (sum sizes)
                durTick
                mutTick
                gcTick
                durSnap
                mutSnap
                gcSnap

          -- advance the ledger state to include this block
          --
          -- TODO We could inline/reuse parts of the IsLedger ExtLedgerState
          -- instance here as an optimization that avoids repeating the
          -- 'applyChainTick' call above. We want to leave that call alone, though,
          -- since it currently matches the call in the forging thread, which is
          -- the primary intention of this Analysis. Maybe GHC's CSE is already
          -- doing this sharing optimization?
          TestInternals' IO blk -> blk -> IO ()
forall {k} (m :: * -> *) (l :: k) blk.
TestInternals m l blk -> blk -> m ()
LedgerDB.reapplyThenPushNOW TestInternals' IO blk
intLedgerDB blk
blk
          LedgerDB IO (ExtLedgerState blk) blk -> IO ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk -> m ()
LedgerDB.tryFlush LedgerDB IO (ExtLedgerState blk) blk
ledgerDB

          -- this flushes blk from the mempool, since every tx in it is now on the chain
          IO (MempoolSnapshot blk) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (MempoolSnapshot blk) -> IO ())
-> IO (MempoolSnapshot blk) -> IO ()
forall a b. (a -> b) -> a -> b
$ Mempool IO blk -> IO (MempoolSnapshot blk)
forall (m :: * -> *) blk. Mempool m blk -> m (MempoolSnapshot blk)
Mempool.syncWithLedger Mempool IO blk
mempool

{-------------------------------------------------------------------------------
  Auxiliary: processing all blocks in the DB
-------------------------------------------------------------------------------}

decreaseLimit :: Limit -> Maybe Limit
decreaseLimit :: Limit -> Maybe Limit
decreaseLimit Limit
Unlimited = Limit -> Maybe Limit
forall a. a -> Maybe a
Just Limit
Unlimited
decreaseLimit (Limit Int
0) = Maybe Limit
forall a. Maybe a
Nothing
decreaseLimit (Limit Int
n) = Limit -> Maybe Limit
forall a. a -> Maybe a
Just (Limit -> Maybe Limit) -> (Int -> Limit) -> Int -> Maybe Limit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Limit
Limit (Int -> Maybe Limit) -> Int -> Maybe Limit
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

data NextStep = Continue | Stop


processAllUntil ::
     forall blk b startFrom st. (HasHeader blk, HasAnnTip blk)
  => ImmutableDB IO blk
  -> ResourceRegistry IO
  -> BlockComponent blk b
  -> AnalysisStartFrom IO blk startFrom
  -> Limit
  -> st
  -> (st -> b -> IO (NextStep, st))
  -> IO st
processAllUntil :: forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> st
-> (st -> b -> IO (NextStep, st))
-> IO st
processAllUntil ImmutableDB IO blk
immutableDB ResourceRegistry IO
registry BlockComponent blk b
blockComponent AnalysisStartFrom IO blk startFrom
startFrom Limit
limit st
initState st -> b -> IO (NextStep, st)
callback = do
    st <- AnalysisStartFrom IO blk startFrom -> IO (Point blk)
forall (m :: * -> *) blk (startFrom :: StartFrom).
(IOLike m, HasAnnTip blk) =>
AnalysisStartFrom m blk startFrom -> m (Point blk)
startFromPoint AnalysisStartFrom IO blk startFrom
startFrom
    itr <- ImmutableDB.streamAfterKnownPoint
      immutableDB
      registry
      blockComponent
      st
    go itr limit initState
  where
    go :: ImmutableDB.Iterator IO blk b -> Limit -> st -> IO st
    go :: Iterator IO blk b -> Limit -> st -> IO st
go Iterator IO blk b
itr Limit
lt !st
st = case Limit -> Maybe Limit
decreaseLimit Limit
lt of
      Maybe Limit
Nothing               -> st -> IO st
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return st
st
      Just Limit
decreasedLimit   -> do
        itrResult <- Iterator IO blk b -> HasCallStack => IO (IteratorResult b)
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m (IteratorResult b)
ImmutableDB.iteratorNext Iterator IO blk b
itr
        case itrResult of
          IteratorResult b
ImmutableDB.IteratorExhausted -> st -> IO st
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return st
st
          ImmutableDB.IteratorResult b
b  -> st -> b -> IO (NextStep, st)
callback st
st b
b IO (NextStep, st) -> ((NextStep, st) -> IO st) -> IO st
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            (NextStep
Continue, st
nst) -> Iterator IO blk b -> Limit -> st -> IO st
go Iterator IO blk b
itr Limit
decreasedLimit st
nst
            (NextStep
Stop, st
nst)     -> st -> IO st
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return st
nst

processAll ::
     forall blk b startFrom st. (HasHeader blk, HasAnnTip blk)
  => ImmutableDB IO blk
  -> ResourceRegistry IO
  -> BlockComponent blk b
  -> AnalysisStartFrom IO blk startFrom
  -> Limit
  -> st
  -> (st -> b -> IO st)
  -> IO st
processAll :: forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> st
-> (st -> b -> IO st)
-> IO st
processAll ImmutableDB IO blk
db ResourceRegistry IO
rr BlockComponent blk b
blockComponent AnalysisStartFrom IO blk startFrom
startFrom Limit
limit st
initSt st -> b -> IO st
cb =
  ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> st
-> (st -> b -> IO (NextStep, st))
-> IO st
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> st
-> (st -> b -> IO (NextStep, st))
-> IO st
processAllUntil ImmutableDB IO blk
db ResourceRegistry IO
rr BlockComponent blk b
blockComponent AnalysisStartFrom IO blk startFrom
startFrom Limit
limit st
initSt st -> b -> IO (NextStep, st)
callback
    where
      callback :: st -> b -> IO (NextStep, st)
callback st
st b
b = (NextStep
Continue, ) (st -> (NextStep, st)) -> IO st -> IO (NextStep, st)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> st -> b -> IO st
cb st
st b
b

processAll_ ::
     forall blk b startFrom. (HasHeader blk, HasAnnTip blk)
  => ImmutableDB IO blk
  -> ResourceRegistry IO
  -> BlockComponent blk b
  -> AnalysisStartFrom IO blk startFrom
  -> Limit
  -> (b -> IO ())
  -> IO ()
processAll_ :: forall blk b (startFrom :: StartFrom).
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> (b -> IO ())
-> IO ()
processAll_ ImmutableDB IO blk
db ResourceRegistry IO
registry BlockComponent blk b
blockComponent AnalysisStartFrom IO blk startFrom
startFrom Limit
limit b -> IO ()
callback =
    ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> ()
-> (() -> b -> IO ())
-> IO ()
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom IO blk startFrom
-> Limit
-> st
-> (st -> b -> IO st)
-> IO st
processAll ImmutableDB IO blk
db ResourceRegistry IO
registry BlockComponent blk b
blockComponent AnalysisStartFrom IO blk startFrom
startFrom Limit
limit () ((b -> IO ()) -> () -> b -> IO ()
forall a b. a -> b -> a
const b -> IO ()
callback)