{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# 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           Codec.CBOR.Encoding (Encoding)
import           Control.Monad (unless, void, when)
import           Control.Monad.Except (runExcept)
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 (reapplyBlockLedgerResult), LedgerCfg,
                     LedgerConfig, applyBlockLedgerResult, applyChainTick,
                     tickThenApply, tickThenApplyLedgerResult, tickThenReapply)
import           Ouroboros.Consensus.Ledger.Basics (LedgerResult (..),
                     LedgerState, getTipSlot)
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 qualified Ouroboros.Consensus.Mempool as Mempool
import           Ouroboros.Consensus.Protocol.Abstract (LedgerView)
import           Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB
                     (LgrDbSerialiseConstraints)
import           Ouroboros.Consensus.Storage.Common (BlockComponent (..))
import           Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB)
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import           Ouroboros.Consensus.Storage.LedgerDB (DiskSnapshot (..),
                     writeSnapshot)
import           Ouroboros.Consensus.Storage.Serialisation (encodeDisk)
import           Ouroboros.Consensus.Util ((..:))
import qualified Ouroboros.Consensus.Util.IOLike as IOLike
import           Ouroboros.Consensus.Util.ResourceRegistry
import           Ouroboros.Network.SizeInBytes
import           System.FS.API (SomeHasFS (..))
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
     , LgrDbSerialiseConstraints blk
     )
  => AnalysisName -> SomeAnalysis blk
runAnalysis :: forall blk.
(HasAnalysis blk, HasTxId (GenTx blk), HasTxs blk,
 LedgerSupportsMempool blk, LedgerSupportsProtocol blk,
 LgrDbSerialiseConstraints 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)
      Maybe AnalysisResult
result <- Analysis blk startFrom
analysis AnalysisEnv IO blk startFrom
env
      Tracer IO (TraceEvent blk) -> TraceEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (TraceEvent blk)
tracer TraceEvent blk
forall blk. TraceEvent blk
DoneEvent
      Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AnalysisResult
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.
(LgrDbSerialiseConstraints blk, HasAnalysis blk,
 LedgerSupportsProtocol 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) =>
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.
(HasAnalysis blk, LedgerSupportsProtocol 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 blk startFrom
startFrom  :: AnalysisStartFrom 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 -> SomeHasFS IO
ledgerDbFS :: SomeHasFS 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 blk startFrom where
  FromPoint ::
    Point blk -> AnalysisStartFrom blk StartFromPoint
  FromLedgerState ::
    ExtLedgerState blk -> AnalysisStartFrom blk StartFromLedgerState

startFromPoint :: HasAnnTip blk => AnalysisStartFrom blk startFrom -> Point blk
startFromPoint :: forall blk (startFrom :: StartFrom).
HasAnnTip blk =>
AnalysisStartFrom blk startFrom -> Point blk
startFromPoint = \case
  FromPoint Point blk
pt       -> Point blk
pt
  FromLedgerState ExtLedgerState blk
st -> 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 -> HeaderState blk
forall blk. ExtLedgerState blk -> HeaderState blk
headerState ExtLedgerState 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 blk 'StartFromPoint
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom blk startFrom
startFrom :: AnalysisStartFrom 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 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 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 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 blk 'StartFromPoint
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom blk startFrom
startFrom :: AnalysisStartFrom 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 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 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 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 blk 'StartFromPoint
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom blk startFrom
startFrom :: AnalysisStartFrom 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
    Word16
maxHeaderSize <-
      ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk (Header blk, Word16, SizeInBytes)
-> AnalysisStartFrom 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 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 blk 'StartFromPoint
startFrom Limit
limit Word16
0 Word16 -> (Header blk, Word16, SizeInBytes) -> IO Word16
process
    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
$ Word16 -> TraceEvent blk
forall blk. Word16 -> TraceEvent blk
MaxHeaderSizeEvent Word16
maxHeaderSize
    Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe AnalysisResult -> IO (Maybe AnalysisResult))
-> Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a b. (a -> b) -> a -> b
$ AnalysisResult -> Maybe AnalysisResult
forall a. a -> Maybe a
Just (AnalysisResult -> Maybe AnalysisResult)
-> AnalysisResult -> Maybe AnalysisResult
forall a b. (a -> b) -> a -> b
$ Word16 -> AnalysisResult
ResultMaxHeaderSize Word16
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 blk 'StartFromPoint
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom blk startFrom
startFrom :: AnalysisStartFrom 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 blk 'StartFromPoint
-> Limit
-> (blk -> IO ())
-> IO ()
forall blk b (startFrom :: StartFrom).
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom blk startFrom
-> Limit
-> (b -> IO ())
-> IO ()
processAll_ ImmutableDB IO blk
db ResourceRegistry IO
registry BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock AnalysisStartFrom 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 blk 'StartFromPoint
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom blk startFrom
startFrom :: AnalysisStartFrom 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 blk 'StartFromPoint
-> Limit
-> (blk -> IO ())
-> IO ()
forall blk b (startFrom :: StartFrom).
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom blk startFrom
-> Limit
-> (b -> IO ())
-> IO ()
processAll_ ImmutableDB IO blk
db ResourceRegistry IO
registry BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock AnalysisStartFrom 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 .
     ( LgrDbSerialiseConstraints blk
     , HasAnalysis blk
     , LedgerSupportsProtocol blk
     )
  => SlotNo
  -> LedgerApplicationMode
  -> Analysis blk StartFromLedgerState
storeLedgerStateAt :: forall blk.
(LgrDbSerialiseConstraints blk, HasAnalysis blk,
 LedgerSupportsProtocol blk) =>
SlotNo
-> LedgerApplicationMode -> Analysis blk 'StartFromLedgerState
storeLedgerStateAt SlotNo
slotNo LedgerApplicationMode
ledgerAppMode AnalysisEnv IO blk 'StartFromLedgerState
env = do
    IO (ExtLedgerState blk) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ExtLedgerState blk) -> IO ())
-> IO (ExtLedgerState blk) -> IO ()
forall a b. (a -> b) -> a -> b
$ ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk blk
-> AnalysisStartFrom blk 'StartFromLedgerState
-> Limit
-> ExtLedgerState blk
-> (ExtLedgerState blk -> blk -> IO (NextStep, ExtLedgerState blk))
-> IO (ExtLedgerState blk)
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom 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 blk 'StartFromLedgerState
startFrom Limit
limit ExtLedgerState blk
initLedger ExtLedgerState blk -> blk -> IO (NextStep, ExtLedgerState blk)
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 blk 'StartFromLedgerState
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom blk startFrom
startFrom :: AnalysisStartFrom 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, SomeHasFS IO
ledgerDbFS :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> SomeHasFS IO
ledgerDbFS :: SomeHasFS IO
ledgerDbFS, 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 ExtLedgerState blk
initLedger = AnalysisStartFrom blk 'StartFromLedgerState
startFrom

    process :: ExtLedgerState blk -> blk -> IO (NextStep, ExtLedgerState blk)
    process :: ExtLedgerState blk -> blk -> IO (NextStep, ExtLedgerState blk)
process ExtLedgerState blk
oldLedger blk
blk = do
      let ledgerCfg :: ExtLedgerCfg blk
ledgerCfg = TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
cfg
      case Except (ExtValidationError blk) (ExtLedgerState blk)
-> Either (ExtValidationError blk) (ExtLedgerState blk)
forall e a. Except e a -> Either e a
runExcept (Except (ExtValidationError blk) (ExtLedgerState blk)
 -> Either (ExtValidationError blk) (ExtLedgerState blk))
-> Except (ExtValidationError blk) (ExtLedgerState blk)
-> Either (ExtValidationError blk) (ExtLedgerState blk)
forall a b. (a -> b) -> a -> b
$ ExtLedgerCfg blk
-> blk
-> ExtLedgerState blk
-> Except (ExtValidationError blk) (ExtLedgerState blk)
tickThenXApply ExtLedgerCfg blk
ledgerCfg blk
blk ExtLedgerState blk
oldLedger of
        Right ExtLedgerState blk
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 -> IO ()
storeLedgerState ExtLedgerState blk
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
          (NextStep, ExtLedgerState blk) -> IO (NextStep, ExtLedgerState blk)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (blk -> NextStep
continue blk
blk, ExtLedgerState blk
newLedger)
        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 -> IO ()
storeLedgerState ExtLedgerState blk
oldLedger
          (NextStep, ExtLedgerState blk) -> IO (NextStep, ExtLedgerState blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NextStep
Stop, ExtLedgerState blk
oldLedger)

    tickThenXApply :: ExtLedgerCfg blk
-> blk
-> ExtLedgerState blk
-> Except (ExtValidationError blk) (ExtLedgerState blk)
tickThenXApply = case LedgerApplicationMode
ledgerAppMode of
        LedgerApplicationMode
LedgerReapply -> ExtLedgerState blk
-> Except (ExtValidationError blk) (ExtLedgerState blk)
forall a. a -> ExceptT (ExtValidationError blk) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExtLedgerState blk
 -> Except (ExtValidationError blk) (ExtLedgerState blk))
-> (ExtLedgerCfg blk
    -> blk -> ExtLedgerState blk -> ExtLedgerState blk)
-> ExtLedgerCfg blk
-> blk
-> ExtLedgerState blk
-> Except (ExtValidationError blk) (ExtLedgerState blk)
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: LedgerCfg (ExtLedgerState blk)
-> blk -> ExtLedgerState blk -> ExtLedgerState blk
ExtLedgerCfg blk -> blk -> ExtLedgerState blk -> ExtLedgerState blk
forall l blk. ApplyBlock l blk => LedgerCfg l -> blk -> l -> l
tickThenReapply
        LedgerApplicationMode
LedgerApply   -> LedgerCfg (ExtLedgerState blk)
-> blk
-> ExtLedgerState blk
-> Except (LedgerErr (ExtLedgerState blk)) (ExtLedgerState blk)
ExtLedgerCfg blk
-> blk
-> ExtLedgerState blk
-> Except (ExtValidationError blk) (ExtLedgerState blk)
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
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 -> IO ()
    storeLedgerState :: ExtLedgerState blk -> IO ()
storeLedgerState ExtLedgerState blk
ledgerState = case Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
pt of
        NotOrigin SlotNo
slot -> do
          let snapshot :: DiskSnapshot
snapshot = Word64 -> Maybe FilePath -> DiskSnapshot
DiskSnapshot (SlotNo -> Word64
unSlotNo SlotNo
slot) (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"db-analyser")
          SomeHasFS IO
-> (ExtLedgerState blk -> Encoding)
-> DiskSnapshot
-> ExtLedgerState blk
-> IO ()
forall (m :: * -> *) blk.
MonadThrow m =>
SomeHasFS m
-> (ExtLedgerState blk -> Encoding)
-> DiskSnapshot
-> ExtLedgerState blk
-> m ()
writeSnapshot SomeHasFS IO
ledgerDbFS ExtLedgerState blk -> Encoding
encLedger DiskSnapshot
snapshot ExtLedgerState blk
ledgerState
          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 -> HeaderState blk
forall blk. ExtLedgerState blk -> HeaderState blk
headerState ExtLedgerState blk
ledgerState

    encLedger :: ExtLedgerState blk -> Encoding
    encLedger :: ExtLedgerState blk -> Encoding
encLedger =
      let ccfg :: CodecConfig blk
ccfg = TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec TopLevelConfig blk
cfg
      in (LedgerState blk -> Encoding)
-> (ChainDepState (BlockProtocol blk) -> Encoding)
-> (AnnTip blk -> Encoding)
-> ExtLedgerState blk
-> Encoding
forall blk.
(LedgerState blk -> Encoding)
-> (ChainDepState (BlockProtocol blk) -> Encoding)
-> (AnnTip blk -> Encoding)
-> ExtLedgerState blk
-> Encoding
encodeExtLedgerState
           (CodecConfig blk -> LedgerState blk -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig blk
ccfg)
           (CodecConfig blk -> ChainDepState (BlockProtocol blk) -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig blk
ccfg)
           (CodecConfig blk -> AnnTip blk -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig blk
ccfg)

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 blk 'StartFromPoint
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom blk startFrom
startFrom :: AnalysisStartFrom 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
    Int
counted <- ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk ()
-> AnalysisStartFrom 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 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 blk 'StartFromPoint
startFrom Limit
limit Int
0 Int -> () -> IO Int
process
    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
$ Int -> TraceEvent blk
forall blk. Int -> TraceEvent blk
CountedBlocksEvent Int
counted
    Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe AnalysisResult -> IO (Maybe AnalysisResult))
-> Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a b. (a -> b) -> a -> b
$ AnalysisResult -> Maybe AnalysisResult
forall a. a -> Maybe a
Just (AnalysisResult -> Maybe AnalysisResult)
-> AnalysisResult -> Maybe AnalysisResult
forall a b. (a -> b) -> a -> b
$ Int -> AnalysisResult
ResultCountBlock Int
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
  ) =>
  Word64 ->
  Analysis blk StartFromLedgerState
checkNoThunksEvery :: forall blk.
(HasAnalysis blk, LedgerSupportsProtocol 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 blk 'StartFromLedgerState
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom blk startFrom
startFrom :: AnalysisStartFrom 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 (ExtLedgerState blk) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ExtLedgerState blk) -> IO ())
-> IO (ExtLedgerState blk) -> IO ()
forall a b. (a -> b) -> a -> b
$ ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk blk
-> AnalysisStartFrom blk 'StartFromLedgerState
-> Limit
-> ExtLedgerState blk
-> (ExtLedgerState blk -> blk -> IO (ExtLedgerState blk))
-> IO (ExtLedgerState blk)
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom 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 blk 'StartFromLedgerState
startFrom Limit
limit ExtLedgerState blk
initLedger ExtLedgerState blk -> blk -> IO (ExtLedgerState blk)
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 ExtLedgerState blk
initLedger = AnalysisStartFrom blk 'StartFromLedgerState
startFrom

    process :: ExtLedgerState blk -> blk -> IO (ExtLedgerState blk)
    process :: ExtLedgerState blk -> blk -> IO (ExtLedgerState blk)
process ExtLedgerState blk
oldLedger blk
blk = do
      let ledgerCfg :: ExtLedgerCfg blk
ledgerCfg     = TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
cfg
          appliedResult :: Except
  (LedgerErr (ExtLedgerState blk))
  (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
appliedResult = LedgerCfg (ExtLedgerState blk)
-> blk
-> ExtLedgerState blk
-> Except
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) (LedgerResult l l)
tickThenApplyLedgerResult LedgerCfg (ExtLedgerState blk)
ExtLedgerCfg blk
ledgerCfg blk
blk ExtLedgerState blk
oldLedger
          newLedger :: ExtLedgerState blk
newLedger     = (ExtValidationError blk -> ExtLedgerState blk)
-> (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk)
    -> ExtLedgerState blk)
-> Either
     (ExtValidationError blk)
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
-> ExtLedgerState blk
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> ExtLedgerState blk
forall a. HasCallStack => FilePath -> a
error (FilePath -> ExtLedgerState blk)
-> (ExtValidationError blk -> FilePath)
-> ExtValidationError blk
-> ExtLedgerState blk
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)
-> ExtLedgerState blk
forall l a. LedgerResult l a -> a
lrResult (Either
   (ExtValidationError blk)
   (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
 -> ExtLedgerState blk)
-> Either
     (ExtValidationError blk)
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
-> ExtLedgerState blk
forall a b. (a -> b) -> a -> b
$ Except
  (LedgerErr (ExtLedgerState blk))
  (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
-> Either
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
forall e a. Except e a -> Either e a
runExcept (Except
   (LedgerErr (ExtLedgerState blk))
   (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
 -> Either
      (LedgerErr (ExtLedgerState blk))
      (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk)))
-> Except
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
-> Either
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
forall a b. (a -> b) -> a -> b
$ Except
  (LedgerErr (ExtLedgerState blk))
  (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
appliedResult
          bn :: BlockNo
bn            = blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo blk
blk
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockNo -> Word64
unBlockNo BlockNo
bn Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
nBlocks Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 ) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LedgerState blk -> IO (LedgerState blk)
forall a. a -> IO a
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
IOLike.evaluate (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
newLedger) IO (LedgerState blk) -> (LedgerState blk -> 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
>>= BlockNo -> LedgerState blk -> IO ()
checkNoThunks BlockNo
bn
      ExtLedgerState blk -> IO (ExtLedgerState blk)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExtLedgerState blk
newLedger

    checkNoThunks :: BlockNo -> LedgerState blk -> IO ()
    checkNoThunks :: BlockNo -> LedgerState blk -> IO ()
checkNoThunks BlockNo
bn LedgerState blk
ls =
      [FilePath] -> LedgerState blk -> IO (Maybe ThunkInfo)
forall a. NoThunks a => [FilePath] -> a -> IO (Maybe ThunkInfo)
noThunks [FilePath
"--checkThunks"] LedgerState blk
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 blk 'StartFromLedgerState
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom blk startFrom
startFrom :: AnalysisStartFrom 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 (ExtLedgerState blk) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ExtLedgerState blk) -> IO ())
-> IO (ExtLedgerState blk) -> IO ()
forall a b. (a -> b) -> a -> b
$ ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk blk
-> AnalysisStartFrom blk 'StartFromLedgerState
-> Limit
-> ExtLedgerState blk
-> (ExtLedgerState blk -> blk -> IO (ExtLedgerState blk))
-> IO (ExtLedgerState blk)
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom 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 blk 'StartFromLedgerState
startFrom Limit
limit ExtLedgerState blk
initLedger ExtLedgerState blk -> blk -> IO (ExtLedgerState blk)
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 ExtLedgerState blk
initLedger = AnalysisStartFrom blk 'StartFromLedgerState
startFrom

    process
      :: ExtLedgerState blk
      -> blk
      -> IO (ExtLedgerState blk)
    process :: ExtLedgerState blk -> blk -> IO (ExtLedgerState blk)
process ExtLedgerState blk
oldLedger blk
blk = do
      let ledgerCfg :: ExtLedgerCfg blk
ledgerCfg     = TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
cfg
          appliedResult :: Except
  (LedgerErr (ExtLedgerState blk))
  (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
appliedResult = LedgerCfg (ExtLedgerState blk)
-> blk
-> ExtLedgerState blk
-> Except
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) (LedgerResult l l)
tickThenApplyLedgerResult LedgerCfg (ExtLedgerState blk)
ExtLedgerCfg blk
ledgerCfg blk
blk ExtLedgerState blk
oldLedger
          newLedger :: ExtLedgerState blk
newLedger     = (ExtValidationError blk -> ExtLedgerState blk)
-> (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk)
    -> ExtLedgerState blk)
-> Either
     (ExtValidationError blk)
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
-> ExtLedgerState blk
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> ExtLedgerState blk
forall a. HasCallStack => FilePath -> a
error (FilePath -> ExtLedgerState blk)
-> (ExtValidationError blk -> FilePath)
-> ExtValidationError blk
-> ExtLedgerState blk
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)
-> ExtLedgerState blk
forall l a. LedgerResult l a -> a
lrResult (Either
   (ExtValidationError blk)
   (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
 -> ExtLedgerState blk)
-> Either
     (ExtValidationError blk)
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
-> ExtLedgerState blk
forall a b. (a -> b) -> a -> b
$ Except
  (LedgerErr (ExtLedgerState blk))
  (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
-> Either
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
forall e a. Except e a -> Either e a
runExcept (Except
   (LedgerErr (ExtLedgerState blk))
   (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
 -> Either
      (LedgerErr (ExtLedgerState blk))
      (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk)))
-> Except
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
-> Either
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
forall a b. (a -> b) -> a -> b
$ Except
  (LedgerErr (ExtLedgerState blk))
  (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
appliedResult
          traces :: [FilePath]
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 -> LedgerState blk -> WithLedgerState blk
forall blk.
blk -> LedgerState blk -> LedgerState blk -> WithLedgerState blk
HasAnalysis.WithLedgerState blk
blk (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
oldLedger) (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
newLedger))
      (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
Debug.traceMarkerIO [FilePath]
traces
      ExtLedgerState blk -> IO (ExtLedgerState blk)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExtLedgerState blk -> IO (ExtLedgerState blk))
-> ExtLedgerState blk -> IO (ExtLedgerState blk)
forall a b. (a -> b) -> a -> b
$ ExtLedgerState blk
newLedger

{-------------------------------------------------------------------------------
  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.
     ( HasAnalysis blk
     , LedgerSupportsProtocol blk
     )
  => Maybe FilePath
  -> LedgerApplicationMode
  -> Analysis blk StartFromLedgerState
benchmarkLedgerOps :: forall blk.
(HasAnalysis blk, LedgerSupportsProtocol 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 blk 'StartFromLedgerState
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom blk startFrom
startFrom :: AnalysisStartFrom 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).
    OutputFormat
outFormat <- Maybe FilePath -> IO OutputFormat
F.getOutputFormat Maybe FilePath
mOutfile

    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 -> OutputFormat -> LedgerApplicationMode -> IO ()
F.writeMetadata Handle
outFileHandle OutputFormat
outFormat LedgerApplicationMode
ledgerAppMode
      Handle -> OutputFormat -> IO ()
F.writeHeader   Handle
outFileHandle OutputFormat
outFormat

      IO (ExtLedgerState blk) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ExtLedgerState blk) -> IO ())
-> IO (ExtLedgerState blk) -> IO ()
forall a b. (a -> b) -> a -> b
$ ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk (blk, SizeInBytes)
-> AnalysisStartFrom blk 'StartFromLedgerState
-> Limit
-> ExtLedgerState blk
-> (ExtLedgerState blk
    -> (blk, SizeInBytes) -> IO (ExtLedgerState blk))
-> IO (ExtLedgerState blk)
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom 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 blk 'StartFromLedgerState
startFrom
        Limit
limit
        ExtLedgerState blk
initLedger
        (Handle
-> OutputFormat
-> ExtLedgerState blk
-> (blk, SizeInBytes)
-> IO (ExtLedgerState blk)
process 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 ExtLedgerState blk
initLedger = AnalysisStartFrom blk 'StartFromLedgerState
startFrom

    process ::
         IO.Handle
      -> F.OutputFormat
      -> ExtLedgerState blk
      -> (blk, SizeInBytes)
      -> IO (ExtLedgerState blk)
    process :: Handle
-> OutputFormat
-> ExtLedgerState blk
-> (blk, SizeInBytes)
-> IO (ExtLedgerState blk)
process Handle
outFileHandle OutputFormat
outFormat ExtLedgerState blk
prevLedgerState (blk
blk, SizeInBytes
sz)  = do
        RTSStats
prevRtsStats <- IO RTSStats
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 -> IO (a, Int64)
time IO a
act = do
              Int64
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
              !a
r <- IO a
act
              Int64
tNow <- 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
              (a, Int64) -> IO (a, Int64)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
r, Int64
tNow Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
tPrev)

        let slot :: SlotNo
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.
        (LedgerView (BlockProtocol blk)
ldgrView, Int64
tForecast) <- IO (LedgerView (BlockProtocol blk))
-> IO (LedgerView (BlockProtocol blk), Int64)
forall {a}. IO a -> IO (a, Int64)
time (IO (LedgerView (BlockProtocol blk))
 -> IO (LedgerView (BlockProtocol blk), Int64))
-> IO (LedgerView (BlockProtocol blk))
-> IO (LedgerView (BlockProtocol blk), Int64)
forall a b. (a -> b) -> a -> b
$ SlotNo -> ExtLedgerState blk -> IO (LedgerView (BlockProtocol blk))
forecast            SlotNo
slot ExtLedgerState blk
prevLedgerState
        (Ticked (HeaderState blk)
tkHdrSt,  Int64
tHdrTick)  <- IO (Ticked (HeaderState blk))
-> IO (Ticked (HeaderState blk), Int64)
forall {a}. IO a -> IO (a, Int64)
time (IO (Ticked (HeaderState blk))
 -> IO (Ticked (HeaderState blk), Int64))
-> IO (Ticked (HeaderState blk))
-> IO (Ticked (HeaderState blk), Int64)
forall a b. (a -> b) -> a -> b
$ SlotNo
-> ExtLedgerState blk
-> LedgerView (BlockProtocol blk)
-> IO (Ticked (HeaderState blk))
tickTheHeaderState  SlotNo
slot ExtLedgerState blk
prevLedgerState LedgerView (BlockProtocol blk)
ldgrView
        (HeaderState blk
hdrSt',   Int64
tHdrApp)   <- IO (HeaderState blk) -> IO (HeaderState blk, Int64)
forall {a}. IO a -> IO (a, Int64)
time (IO (HeaderState blk) -> IO (HeaderState blk, Int64))
-> IO (HeaderState blk) -> IO (HeaderState blk, Int64)
forall a b. (a -> b) -> a -> b
$ LedgerView (BlockProtocol blk)
-> Ticked (HeaderState blk) -> IO (HeaderState blk)
applyTheHeader                           LedgerView (BlockProtocol blk)
ldgrView Ticked (HeaderState blk)
tkHdrSt
        (Ticked (LedgerState blk)
tkLdgrSt, Int64
tBlkTick)  <- IO (Ticked (LedgerState blk))
-> IO (Ticked (LedgerState blk), Int64)
forall {a}. IO a -> IO (a, Int64)
time (IO (Ticked (LedgerState blk))
 -> IO (Ticked (LedgerState blk), Int64))
-> IO (Ticked (LedgerState blk))
-> IO (Ticked (LedgerState blk), Int64)
forall a b. (a -> b) -> a -> b
$ SlotNo -> ExtLedgerState blk -> IO (Ticked (LedgerState blk))
tickTheLedgerState  SlotNo
slot ExtLedgerState blk
prevLedgerState
        (LedgerState blk
ldgrSt',  Int64
tBlkApp)   <- IO (LedgerState blk) -> IO (LedgerState blk, Int64)
forall {a}. IO a -> IO (a, Int64)
time (IO (LedgerState blk) -> IO (LedgerState blk, Int64))
-> IO (LedgerState blk) -> IO (LedgerState blk, Int64)
forall a b. (a -> b) -> a -> b
$ Ticked (LedgerState blk) -> IO (LedgerState blk)
applyTheBlock                                     Ticked (LedgerState blk)
tkLdgrSt

        RTSStats
currentRtsStats <- IO RTSStats
GC.getRTSStats
        let
          currentMinusPrevious :: Num a => (GC.RTSStats -> a) -> a
          currentMinusPrevious :: forall a. Num a => (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 :: Word32
major_gcs              = (RTSStats -> Word32) -> Word32
forall a. Num a => (RTSStats -> a) -> a
currentMinusPrevious RTSStats -> Word32
GC.major_gcs
          slotDataPoint :: SlotDataPoint
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 -> WithOrigin SlotNo
forall l. GetTip l => l -> WithOrigin SlotNo
getTipSlot ExtLedgerState blk
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      = [Builder] -> BlockStats
DP.BlockStats ([Builder] -> BlockStats) -> [Builder] -> BlockStats
forall a b. (a -> b) -> a -> b
$ blk -> [Builder]
forall blk. HasAnalysis blk => blk -> [Builder]
HasAnalysis.blockStats blk
blk
            }

          slotCount :: SlotNo -> WithOrigin SlotNo -> Word64
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

        Handle -> OutputFormat -> SlotDataPoint -> IO ()
F.writeDataPoint Handle
outFileHandle OutputFormat
outFormat SlotDataPoint
slotDataPoint

        ExtLedgerState blk -> IO (ExtLedgerState blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExtLedgerState blk -> IO (ExtLedgerState blk))
-> ExtLedgerState blk -> IO (ExtLedgerState blk)
forall a b. (a -> b) -> a -> b
$ LedgerState blk -> HeaderState blk -> ExtLedgerState blk
forall blk.
LedgerState blk -> HeaderState blk -> ExtLedgerState blk
ExtLedgerState LedgerState blk
ldgrSt' HeaderState blk
hdrSt'
      where
        rp :: RealPoint blk
rp = blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
blk

        forecast ::
             SlotNo
          -> ExtLedgerState blk
          -> IO (LedgerView (BlockProtocol blk))
        forecast :: SlotNo -> ExtLedgerState blk -> IO (LedgerView (BlockProtocol blk))
forecast SlotNo
slot ExtLedgerState blk
st = do
            let forecaster :: Forecast (LedgerView (BlockProtocol blk))
forecaster = LedgerConfig blk
-> LedgerState blk -> Forecast (LedgerView (BlockProtocol blk))
forall blk.
(LedgerSupportsProtocol blk, HasCallStack) =>
LedgerConfig blk
-> LedgerState blk -> Forecast (LedgerView (BlockProtocol blk))
ledgerViewForecastAt LedgerConfig blk
lcfg (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
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
          -> LedgerView (BlockProtocol blk)
          -> IO (Ticked (HeaderState blk))
        tickTheHeaderState :: SlotNo
-> ExtLedgerState blk
-> LedgerView (BlockProtocol blk)
-> IO (Ticked (HeaderState blk))
tickTheHeaderState SlotNo
slot ExtLedgerState blk
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 -> HeaderState blk
forall blk. ExtLedgerState blk -> HeaderState blk
headerState ExtLedgerState blk
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
          -> IO (Ticked (LedgerState blk))
        tickTheLedgerState :: SlotNo -> ExtLedgerState blk -> IO (Ticked (LedgerState blk))
tickTheLedgerState SlotNo
slot ExtLedgerState blk
st =
            Ticked (LedgerState blk) -> IO (Ticked (LedgerState blk))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ticked (LedgerState blk) -> IO (Ticked (LedgerState blk)))
-> Ticked (LedgerState blk) -> IO (Ticked (LedgerState blk))
forall a b. (a -> b) -> a -> b
$ LedgerConfig blk
-> SlotNo -> LedgerState blk -> Ticked (LedgerState blk)
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick LedgerConfig blk
lcfg SlotNo
slot (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
st)

        applyTheBlock ::
             Ticked (LedgerState blk)
          -> IO (LedgerState blk)
        applyTheBlock :: Ticked (LedgerState blk) -> IO (LedgerState blk)
applyTheBlock Ticked (LedgerState blk)
tickedLedgerSt = case LedgerApplicationMode
ledgerAppMode of
          LedgerApplicationMode
LedgerApply ->
            case Except (LedgerErr (LedgerState blk)) (LedgerState blk)
-> Either (LedgerErr (LedgerState blk)) (LedgerState blk)
forall e a. Except e a -> Either e a
runExcept (LedgerResult (LedgerState blk) (LedgerState blk) -> LedgerState blk
forall l a. LedgerResult l a -> a
lrResult (LedgerResult (LedgerState blk) (LedgerState blk)
 -> LedgerState blk)
-> ExceptT
     (LedgerErr (LedgerState blk))
     Identity
     (LedgerResult (LedgerState blk) (LedgerState blk))
-> Except (LedgerErr (LedgerState blk)) (LedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerConfig blk
-> blk
-> Ticked (LedgerState blk)
-> ExceptT
     (LedgerErr (LedgerState blk))
     Identity
     (LedgerResult (LedgerState blk) (LedgerState blk))
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l
-> blk -> Ticked l -> Except (LedgerErr l) (LedgerResult l l)
applyBlockLedgerResult LedgerConfig blk
lcfg blk
blk Ticked (LedgerState blk)
tickedLedgerSt) of
              Left LedgerErr (LedgerState blk)
err -> FilePath -> IO (LedgerState blk)
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO (LedgerState blk))
-> FilePath -> IO (LedgerState blk)
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
x  -> LedgerState blk -> IO (LedgerState blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerState blk
x
          LedgerApplicationMode
LedgerReapply ->
            LedgerState blk -> IO (LedgerState blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LedgerState blk -> IO (LedgerState blk))
-> LedgerState blk -> IO (LedgerState blk)
forall a b. (a -> b) -> a -> b
$! LedgerResult (LedgerState blk) (LedgerState blk) -> LedgerState blk
forall l a. LedgerResult l a -> a
lrResult (LedgerResult (LedgerState blk) (LedgerState blk)
 -> LedgerState blk)
-> LedgerResult (LedgerState blk) (LedgerState blk)
-> LedgerState blk
forall a b. (a -> b) -> a -> b
$ LedgerConfig blk
-> blk
-> Ticked (LedgerState blk)
-> LedgerResult (LedgerState blk) (LedgerState blk)
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l -> blk -> Ticked l -> LedgerResult l l
reapplyBlockLedgerResult LedgerConfig blk
lcfg blk
blk Ticked (LedgerState blk)
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
-> [(Builder, WithLedgerState blk -> IO Builder)]
-> IO ()
forall a. Handle -> Separator -> [(Builder, a)] -> IO ()
writeHeaderLine Handle
outFileHandle Separator
separator (forall blk.
HasAnalysis blk =>
[(Builder, WithLedgerState blk -> IO Builder)]
HasAnalysis.blockApplicationMetrics @blk)
        IO (ExtLedgerState blk) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ExtLedgerState blk) -> IO ())
-> IO (ExtLedgerState blk) -> IO ()
forall a b. (a -> b) -> a -> b
$ ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk blk
-> AnalysisStartFrom blk 'StartFromLedgerState
-> Limit
-> ExtLedgerState blk
-> (ExtLedgerState blk -> blk -> IO (ExtLedgerState blk))
-> IO (ExtLedgerState blk)
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom 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 blk 'StartFromLedgerState
startFrom Limit
limit ExtLedgerState blk
initLedger (Handle -> ExtLedgerState blk -> blk -> IO (ExtLedgerState blk)
process 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 blk 'StartFromLedgerState
startFrom :: forall (m :: * -> *) blk (startFrom :: StartFrom).
AnalysisEnv m blk startFrom -> AnalysisStartFrom blk startFrom
startFrom :: AnalysisStartFrom 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 ExtLedgerState blk
initLedger = AnalysisStartFrom blk 'StartFromLedgerState
startFrom

    process :: IO.Handle -> ExtLedgerState blk -> blk -> IO (ExtLedgerState blk)
    process :: Handle -> ExtLedgerState blk -> blk -> IO (ExtLedgerState blk)
process Handle
outFileHandle ExtLedgerState blk
currLedgerSt blk
blk = do
      let nextLedgerSt :: ExtLedgerState blk
nextLedgerSt = LedgerCfg (ExtLedgerState blk)
-> blk -> ExtLedgerState blk -> ExtLedgerState blk
forall l blk. ApplyBlock l blk => LedgerCfg l -> blk -> l -> l
tickThenReapply (TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
cfg) blk
blk ExtLedgerState blk
currLedgerSt
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockNo -> Word64
unBlockNo (blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo blk
blk) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
nrBlocks Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          let blockApplication :: WithLedgerState blk
blockApplication =
                blk -> LedgerState blk -> LedgerState blk -> WithLedgerState blk
forall blk.
blk -> LedgerState blk -> LedgerState blk -> WithLedgerState blk
HasAnalysis.WithLedgerState blk
blk
                                            (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
currLedgerSt)
                                            (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
nextLedgerSt)

          Handle
-> Separator
-> [(Builder, WithLedgerState blk -> IO Builder)]
-> WithLedgerState blk
-> IO ()
forall a b.
Handle -> Separator -> [(a, b -> IO Builder)] -> b -> IO ()
computeAndWriteLine Handle
outFileHandle
                              Separator
separator
                              (forall blk.
HasAnalysis blk =>
[(Builder, WithLedgerState blk -> IO Builder)]
HasAnalysis.blockApplicationMetrics @blk)
                              WithLedgerState blk
blockApplication

          Handle -> IO ()
IO.hFlush Handle
outFileHandle

      ExtLedgerState blk -> IO (ExtLedgerState blk)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExtLedgerState blk
nextLedgerSt

{-------------------------------------------------------------------------------
  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
    ReproMempoolForgeHowManyBlks
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

    StrictTVar IO (ExtLedgerState blk)
ref <- ExtLedgerState blk -> IO (StrictTVar IO (ExtLedgerState blk))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
IOLike.newTVarIO ExtLedgerState blk
initLedger
    Mempool IO blk
mempool <- LedgerInterface IO blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer IO (TraceEventMempool blk)
-> IO (Mempool IO blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> m (Mempool m blk)
Mempool.openMempoolWithoutSyncThread
      Mempool.LedgerInterface {
        getCurrentLedgerState :: STM IO (LedgerState blk)
Mempool.getCurrentLedgerState = ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> STM (ExtLedgerState blk) -> STM (LedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar IO (ExtLedgerState blk) -> STM IO (ExtLedgerState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
IOLike.readTVar StrictTVar IO (ExtLedgerState blk)
ref
      }
      LedgerConfig blk
lCfg
      -- one mebibyte should generously accomodate two blocks' worth of txs
      ( ByteSize32 -> MempoolCapacityBytesOverride
Mempool.MempoolCapacityBytesOverride
      (ByteSize32 -> MempoolCapacityBytesOverride)
-> ByteSize32 -> MempoolCapacityBytesOverride
forall a b. (a -> b) -> a -> b
$ Word32 -> ByteSize32
LedgerSupportsMempool.ByteSize32
      (Word32 -> ByteSize32) -> Word32 -> ByteSize32
forall a b. (a -> b) -> a -> b
$ Word32
1024Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
*Word32
1024
      )
      Tracer IO (TraceEventMempool blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer

    IO (Maybe blk) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe blk) -> IO ()) -> IO (Maybe blk) -> IO ()
forall a b. (a -> b) -> a -> b
$ ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk blk
-> AnalysisStartFrom blk 'StartFromLedgerState
-> Limit
-> Maybe blk
-> (Maybe blk -> blk -> IO (Maybe blk))
-> IO (Maybe blk)
forall blk b (startFrom :: StartFrom) st.
(HasHeader blk, HasAnnTip blk) =>
ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom 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 blk 'StartFromLedgerState
startFrom Limit
limit Maybe blk
forall a. Maybe a
Nothing (ReproMempoolForgeHowManyBlks
-> StrictTVar IO (ExtLedgerState blk)
-> Mempool IO blk
-> Maybe blk
-> blk
-> IO (Maybe blk)
process ReproMempoolForgeHowManyBlks
howManyBlocks StrictTVar IO (ExtLedgerState blk)
ref Mempool IO blk
mempool)
    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 {
      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 blk startFrom
startFrom = startFrom :: AnalysisStartFrom blk 'StartFromLedgerState
startFrom@(FromLedgerState ExtLedgerState blk
initLedger)
    , 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

    elCfg :: LedgerCfg (ExtLedgerState blk)
    elCfg :: LedgerCfg (ExtLedgerState blk)
elCfg = TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg 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
      Time
before <- IO Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
IOLike.getMonotonicTime
      RTSStats
prevRtsStats <- IO RTSStats
GC.getRTSStats
      !a
x <- IO a
m
      RTSStats
newRtsStats <- IO RTSStats
GC.getRTSStats
      Time
after <- IO Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
IOLike.getMonotonicTime
      (a, DiffTime, Int64, Int64) -> IO (a, DiffTime, Int64, Int64)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( a
x
           , Time
after Time -> Time -> DiffTime
`IOLike.diffTime` Time
before
           , (RTSStats -> Int64
GC.mutator_elapsed_ns RTSStats
newRtsStats Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- RTSStats -> Int64
GC.mutator_elapsed_ns RTSStats
prevRtsStats) Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
1000
           , (RTSStats -> Int64
GC.gc_elapsed_ns RTSStats
newRtsStats Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- RTSStats -> Int64
GC.gc_elapsed_ns RTSStats
prevRtsStats) Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
1000
           )

    process
      :: ReproMempoolForgeHowManyBlks
      -> IOLike.StrictTVar IO (ExtLedgerState blk)
      -> Mempool.Mempool IO blk
      -> Maybe blk
      -> blk
      -> IO (Maybe blk)
    process :: ReproMempoolForgeHowManyBlks
-> StrictTVar IO (ExtLedgerState blk)
-> Mempool IO blk
-> Maybe blk
-> blk
-> IO (Maybe blk)
process ReproMempoolForgeHowManyBlks
howManyBlocks StrictTVar IO (ExtLedgerState blk)
ref 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
        [MempoolAddTxResult blk]
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 :: [(TxId (GenTx blk), MempoolAddTxResult blk)]
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
              ]
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(TxId (GenTx blk), MempoolAddTxResult blk)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TxId (GenTx blk), MempoolAddTxResult blk)]
rejs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          FilePath -> IO ()
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
               [FilePath
"Mempool rejected some of the on-chain txs: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [(TxId (GenTx blk), MempoolAddTxResult blk)] -> FilePath
forall a. Show a => a -> FilePath
show [(TxId (GenTx blk), MempoolAddTxResult blk)]
rejs]
            [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> case ReproMempoolForgeHowManyBlks
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
          ExtLedgerState blk
st <- StrictTVar IO (ExtLedgerState blk) -> IO (ExtLedgerState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
IOLike.readTVarIO StrictTVar IO (ExtLedgerState blk)
ref

          -- 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.
          do
            let slot :: SlotNo
slot = blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk
            (Ticked (LedgerState blk)
ticked, DiffTime
durTick, Int64
mutTick, Int64
gcTick) <- IO (Ticked (LedgerState blk))
-> IO (Ticked (LedgerState blk), DiffTime, Int64, Int64)
forall a. IO a -> IO (a, DiffTime, Int64, Int64)
timed (IO (Ticked (LedgerState blk))
 -> IO (Ticked (LedgerState blk), DiffTime, Int64, Int64))
-> IO (Ticked (LedgerState blk))
-> IO (Ticked (LedgerState blk), DiffTime, Int64, Int64)
forall a b. (a -> b) -> a -> b
$ Ticked (LedgerState blk) -> IO (Ticked (LedgerState blk))
forall a. a -> IO a
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
IOLike.evaluate (Ticked (LedgerState blk) -> IO (Ticked (LedgerState blk)))
-> Ticked (LedgerState blk) -> IO (Ticked (LedgerState blk))
forall a b. (a -> b) -> a -> b
$
              LedgerConfig blk
-> SlotNo -> LedgerState blk -> Ticked (LedgerState blk)
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick LedgerConfig blk
lCfg SlotNo
slot (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
st)
            ((), DiffTime
durSnap, Int64
mutSnap, Int64
gcSnap) <- IO () -> IO ((), DiffTime, Int64, Int64)
forall a. IO a -> IO (a, DiffTime, Int64, Int64)
timed (IO () -> IO ((), DiffTime, Int64, Int64))
-> IO () -> IO ((), DiffTime, Int64, Int64)
forall a b. (a -> b) -> a -> b
$ STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
IOLike.atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              MempoolSnapshot blk
snap <- Mempool IO blk
-> ForgeLedgerState blk -> STM IO (MempoolSnapshot blk)
forall (m :: * -> *) blk.
Mempool m blk
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk)
Mempool.getSnapshotFor Mempool IO blk
mempool (ForgeLedgerState blk -> STM IO (MempoolSnapshot blk))
-> ForgeLedgerState blk -> STM IO (MempoolSnapshot blk)
forall a b. (a -> b) -> a -> b
$ SlotNo -> Ticked (LedgerState blk) -> ForgeLedgerState blk
forall blk. SlotNo -> TickedLedgerState blk -> ForgeLedgerState blk
Mempool.ForgeInKnownSlot SlotNo
slot Ticked (LedgerState blk)
ticked

              () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> STM ()) -> () -> STM ()
forall a b. (a -> b) -> a -> b
$ [(Validated (GenTx blk), TicketNo, ByteSize32)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
Mempool.snapshotTxs MempoolSnapshot blk
snap) Int -> () -> ()
forall a b. a -> b -> b
`seq` MempoolSnapshot blk -> Ticked (LedgerState blk)
forall blk. MempoolSnapshot blk -> TickedLedgerState blk
Mempool.snapshotLedgerState MempoolSnapshot blk
snap Ticked (LedgerState blk) -> () -> ()
forall a b. a -> b -> b
`seq` ()

            let sizes :: [SizeInBytes]
sizes = blk -> [SizeInBytes]
forall blk. HasAnalysis blk => blk -> [SizeInBytes]
HasAnalysis.blockTxSizes 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
$
              BlockNo
-> SlotNo
-> Int
-> SizeInBytes
-> DiffTime
-> Int64
-> Int64
-> DiffTime
-> Int64
-> Int64
-> TraceEvent blk
forall blk.
BlockNo
-> SlotNo
-> Int
-> SizeInBytes
-> DiffTime
-> Int64
-> Int64
-> DiffTime
-> Int64
-> Int64
-> TraceEvent blk
BlockMempoolAndForgeRepro
                (blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo blk
blk)
                SlotNo
slot
                ([SizeInBytes] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SizeInBytes]
sizes)
                ([SizeInBytes] -> SizeInBytes
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [SizeInBytes]
sizes)
                DiffTime
durTick
                Int64
mutTick
                Int64
gcTick
                DiffTime
durSnap
                Int64
mutSnap
                Int64
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?
          STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
IOLike.atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ StrictTVar IO (ExtLedgerState blk)
-> ExtLedgerState blk -> STM IO ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
IOLike.writeTVar StrictTVar IO (ExtLedgerState blk)
ref (ExtLedgerState blk -> STM ()) -> ExtLedgerState blk -> STM ()
forall a b. (a -> b) -> a -> b
$! LedgerCfg (ExtLedgerState blk)
-> blk -> ExtLedgerState blk -> ExtLedgerState blk
forall l blk. ApplyBlock l blk => LedgerCfg l -> blk -> l -> l
tickThenReapply LedgerCfg (ExtLedgerState blk)
elCfg blk
blk ExtLedgerState blk
st

          -- 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 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 blk startFrom
-> Limit
-> st
-> (st -> b -> IO (NextStep, st))
-> IO st
processAllUntil ImmutableDB IO blk
immutableDB ResourceRegistry IO
registry BlockComponent blk b
blockComponent AnalysisStartFrom blk startFrom
startFrom Limit
limit st
initState st -> b -> IO (NextStep, st)
callback = do
    Iterator IO blk b
itr <- ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> Point blk
-> IO (Iterator IO blk b)
forall (m :: * -> *) blk b.
(MonadSTM m, MonadThrow m, HasHeader blk, HasCallStack) =>
ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> Point blk
-> m (Iterator m blk b)
ImmutableDB.streamAfterKnownPoint
      ImmutableDB IO blk
immutableDB
      ResourceRegistry IO
registry
      BlockComponent blk b
blockComponent
      (AnalysisStartFrom blk startFrom -> Point blk
forall blk (startFrom :: StartFrom).
HasAnnTip blk =>
AnalysisStartFrom blk startFrom -> Point blk
startFromPoint AnalysisStartFrom blk startFrom
startFrom)
    Iterator IO blk b -> Limit -> st -> IO st
go Iterator IO blk b
itr Limit
limit st
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
        IteratorResult b
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 IteratorResult b
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 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 blk startFrom
-> Limit
-> st
-> (st -> b -> IO st)
-> IO st
processAll ImmutableDB IO blk
db ResourceRegistry IO
rr BlockComponent blk b
blockComponent AnalysisStartFrom blk startFrom
startFrom Limit
limit st
initSt st -> b -> IO st
cb =
  ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom 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 blk startFrom
-> Limit
-> st
-> (st -> b -> IO (NextStep, st))
-> IO st
processAllUntil ImmutableDB IO blk
db ResourceRegistry IO
rr BlockComponent blk b
blockComponent AnalysisStartFrom 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 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 blk startFrom
-> Limit
-> (b -> IO ())
-> IO ()
processAll_ ImmutableDB IO blk
db ResourceRegistry IO
registry BlockComponent blk b
blockComponent AnalysisStartFrom blk startFrom
startFrom Limit
limit b -> IO ()
callback =
    ImmutableDB IO blk
-> ResourceRegistry IO
-> BlockComponent blk b
-> AnalysisStartFrom 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 blk startFrom
-> Limit
-> st
-> (st -> b -> IO st)
-> IO st
processAll ImmutableDB IO blk
db ResourceRegistry IO
registry BlockComponent blk b
blockComponent AnalysisStartFrom blk startFrom
startFrom Limit
limit () ((b -> IO ()) -> () -> b -> IO ()
forall a b. a -> b -> a
const b -> IO ()
callback)