{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Tools.DBAnalyser.Run (analyse) where

import           Cardano.Ledger.BaseTypes
import           Cardano.Tools.DBAnalyser.Analysis
import           Cardano.Tools.DBAnalyser.HasAnalysis
import           Cardano.Tools.DBAnalyser.Types
import           Control.ResourceRegistry
import           Control.Tracer (Tracer (..), nullTracer)
import           Data.Singletons (Sing, SingI (..))
import qualified Data.SOP.Dict as Dict
import qualified Debug.Trace as Debug
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.HardFork.Abstract
import           Ouroboros.Consensus.Ledger.Basics
import           Ouroboros.Consensus.Ledger.Inspect
import qualified Ouroboros.Consensus.Ledger.SupportsMempool as LedgerSupportsMempool
                     (HasTxs)
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import qualified Ouroboros.Consensus.Node as Node
import qualified Ouroboros.Consensus.Node.InitStorage as Node
import           Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..))
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import qualified Ouroboros.Consensus.Storage.ImmutableDB.Stream as ImmutableDB
import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1 as LedgerDB.V1
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as LedgerDB.V1
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as LedgerDB.V2
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as LedgerDB.V2
import           Ouroboros.Consensus.Util.Args
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.Orphans ()
import           Ouroboros.Network.Block (genesisPoint)
import           System.IO
import           Text.Printf (printf)

{-------------------------------------------------------------------------------
  Analyse
-------------------------------------------------------------------------------}

openLedgerDB ::
     ( LedgerSupportsProtocol blk
     , InspectLedger blk
     , LedgerDB.LedgerDbSerialiseConstraints blk
     , HasHardForkHistory blk
     , LedgerDB.LedgerSupportsLedgerDB blk
     )
  => Complete LedgerDB.LedgerDbArgs IO blk
  -> IO ( LedgerDB.LedgerDB' IO blk
        , LedgerDB.TestInternals' IO blk
        )
openLedgerDB :: forall blk.
(LedgerSupportsProtocol blk, InspectLedger blk,
 LedgerDbSerialiseConstraints blk, HasHardForkHistory blk,
 LedgerSupportsLedgerDB blk) =>
Complete LedgerDbArgs IO blk
-> IO (LedgerDB' IO blk, TestInternals' IO blk)
openLedgerDB lgrDbArgs :: Complete LedgerDbArgs IO blk
lgrDbArgs@LedgerDB.LedgerDbArgs{lgrFlavorArgs :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> LedgerDbFlavorArgs f m
LedgerDB.lgrFlavorArgs=LedgerDB.LedgerDbFlavorArgsV1 LedgerDbFlavorArgs Identity IO
bss} = do
  (ledgerDB, _, intLedgerDB) <-
    Complete LedgerDbArgs IO blk
-> InitDB (DbChangelog' blk, BackingStore' IO blk) IO blk
-> StreamAPI IO blk blk
-> Point blk
-> IO (LedgerDB' IO blk, Word64, TestInternals' IO blk)
forall (m :: * -> *) blk db.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Complete LedgerDbArgs m blk
-> InitDB db m blk
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, Word64, TestInternals' m blk)
LedgerDB.openDBInternal
      Complete LedgerDbArgs IO blk
lgrDbArgs
      (Complete LedgerDbArgs IO blk
-> LedgerDbFlavorArgs Identity IO
-> ResolveBlock IO blk
-> InitDB (DbChangelog' blk, BackingStore' IO blk) IO blk
forall (m :: * -> *) blk.
(LedgerSupportsProtocol blk, IOLike m,
 LedgerDbSerialiseConstraints blk, HasHardForkHistory blk,
 LedgerSupportsLedgerDB blk) =>
Complete LedgerDbArgs m blk
-> Complete LedgerDbFlavorArgs m
-> ResolveBlock m blk
-> InitDB (DbChangelog' blk, BackingStore' m blk) m blk
LedgerDB.V1.mkInitDb
        Complete LedgerDbArgs IO blk
lgrDbArgs
        LedgerDbFlavorArgs Identity IO
bss
        (\RealPoint blk
_ -> [Char] -> IO blk
forall a. HasCallStack => [Char] -> a
error [Char]
"no replay"))
      StreamAPI IO blk blk
forall (m :: * -> *) blk a. Applicative m => StreamAPI m blk a
emptyStream
      Point blk
forall {k} (block :: k). Point block
genesisPoint
  pure (ledgerDB, intLedgerDB)
openLedgerDB lgrDbArgs :: Complete LedgerDbArgs IO blk
lgrDbArgs@LedgerDB.LedgerDbArgs{lgrFlavorArgs :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> LedgerDbFlavorArgs f m
LedgerDB.lgrFlavorArgs=LedgerDB.LedgerDbFlavorArgsV2 LedgerDbFlavorArgs Identity IO
args} = do
  (ledgerDB, _, intLedgerDB) <-
    Complete LedgerDbArgs IO blk
-> InitDB (LedgerSeq' IO blk) IO blk
-> StreamAPI IO blk blk
-> Point blk
-> IO (LedgerDB' IO blk, Word64, TestInternals' IO blk)
forall (m :: * -> *) blk db.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Complete LedgerDbArgs m blk
-> InitDB db m blk
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, Word64, TestInternals' m blk)
LedgerDB.openDBInternal
      Complete LedgerDbArgs IO blk
lgrDbArgs
      (Complete LedgerDbArgs IO blk
-> LedgerDbFlavorArgs Identity IO
-> ResolveBlock IO blk
-> InitDB (LedgerSeq' IO blk) IO blk
forall (m :: * -> *) blk.
(LedgerSupportsProtocol blk, IOLike m,
 LedgerDbSerialiseConstraints blk, HasHardForkHistory blk,
 LedgerSupportsInMemoryLedgerDB blk) =>
Complete LedgerDbArgs m blk
-> Complete LedgerDbFlavorArgs m
-> ResolveBlock m blk
-> InitDB (LedgerSeq' m blk) m blk
LedgerDB.V2.mkInitDb
        Complete LedgerDbArgs IO blk
lgrDbArgs
        LedgerDbFlavorArgs Identity IO
args
        (\RealPoint blk
_ -> [Char] -> IO blk
forall a. HasCallStack => [Char] -> a
error [Char]
"no replay"))
      StreamAPI IO blk blk
forall (m :: * -> *) blk a. Applicative m => StreamAPI m blk a
emptyStream
      Point blk
forall {k} (block :: k). Point block
genesisPoint
  pure (ledgerDB, intLedgerDB)

emptyStream :: Applicative m => ImmutableDB.StreamAPI m blk a
emptyStream :: forall (m :: * -> *) blk a. Applicative m => StreamAPI m blk a
emptyStream = (forall b.
 HasCallStack =>
 Point blk
 -> (Either (RealPoint blk) (m (NextItem a)) -> m b) -> m b)
-> StreamAPI m blk a
forall (m :: * -> *) blk a.
(forall b.
 HasCallStack =>
 Point blk
 -> (Either (RealPoint blk) (m (NextItem a)) -> m b) -> m b)
-> StreamAPI m blk a
ImmutableDB.StreamAPI ((forall b.
  HasCallStack =>
  Point blk
  -> (Either (RealPoint blk) (m (NextItem a)) -> m b) -> m b)
 -> StreamAPI m blk a)
-> (forall b.
    HasCallStack =>
    Point blk
    -> (Either (RealPoint blk) (m (NextItem a)) -> m b) -> m b)
-> StreamAPI m blk a
forall a b. (a -> b) -> a -> b
$ \Point blk
_ Either (RealPoint blk) (m (NextItem a)) -> m b
k -> Either (RealPoint blk) (m (NextItem a)) -> m b
k (Either (RealPoint blk) (m (NextItem a)) -> m b)
-> Either (RealPoint blk) (m (NextItem a)) -> m b
forall a b. (a -> b) -> a -> b
$ m (NextItem a) -> Either (RealPoint blk) (m (NextItem a))
forall a b. b -> Either a b
Right (m (NextItem a) -> Either (RealPoint blk) (m (NextItem a)))
-> m (NextItem a) -> Either (RealPoint blk) (m (NextItem a))
forall a b. (a -> b) -> a -> b
$ NextItem a -> m (NextItem a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NextItem a
forall blk. NextItem blk
ImmutableDB.NoMoreItems

defaultLMDBLimits :: LMDB.LMDBLimits
defaultLMDBLimits :: LMDBLimits
defaultLMDBLimits = LMDB.LMDBLimits
   { lmdbMapSize :: Int
LMDB.lmdbMapSize = Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024
   , lmdbMaxDatabases :: Int
LMDB.lmdbMaxDatabases = Int
10
   , lmdbMaxReaders :: Int
LMDB.lmdbMaxReaders = Int
16
   }

analyse ::
     forall blk .
     ( Node.RunNode blk
     , Show (Header blk)
     , HasAnalysis blk
     , HasProtocolInfo blk
     , LedgerSupportsMempool.HasTxs blk
     , CanStowLedgerTables (LedgerState blk)
     )
  => DBAnalyserConfig
  -> Args blk
  -> IO (Maybe AnalysisResult)
analyse :: forall blk.
(RunNode blk, Show (Header blk), HasAnalysis blk,
 HasProtocolInfo blk, HasTxs blk,
 CanStowLedgerTables (LedgerState blk)) =>
DBAnalyserConfig -> Args blk -> IO (Maybe AnalysisResult)
analyse DBAnalyserConfig
dbaConfig Args blk
args =
    (ResourceRegistry IO -> IO (Maybe AnalysisResult))
-> IO (Maybe AnalysisResult)
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry IO -> IO (Maybe AnalysisResult))
 -> IO (Maybe AnalysisResult))
-> (ResourceRegistry IO -> IO (Maybe AnalysisResult))
-> IO (Maybe AnalysisResult)
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry IO
registry -> do
      lock           <- () -> IO (StrictMVar IO ())
forall (m :: * -> *) a.
(HasCallStack, MonadMVar m, NoThunks a) =>
a -> m (StrictMVar m a)
newMVar ()
      chainDBTracer  <- mkTracer lock verbose
      analysisTracer <- mkTracer lock True
      ProtocolInfo { pInfoInitLedger = genesisLedger, pInfoConfig = cfg } <-
        mkProtocolInfo args
      let shfs = [Char] -> RelativeMountPoint -> SomeHasFS IO
Node.stdMkChainDbHasFS [Char]
dbDir
          chunkInfo  = StorageConfig blk -> ChunkInfo
forall blk. NodeInitStorage blk => StorageConfig blk -> ChunkInfo
Node.nodeImmutableDbChunkInfo (TopLevelConfig blk -> StorageConfig blk
forall blk. TopLevelConfig blk -> StorageConfig blk
configStorage TopLevelConfig blk
cfg)
          flavargs = case LedgerDBBackend
ldbBackend of
            LedgerDBBackend
V1InMem -> LedgerDbFlavorArgs Identity IO -> LedgerDbFlavorArgs Identity IO
forall (f :: * -> *) (m :: * -> *).
LedgerDbFlavorArgs f m -> LedgerDbFlavorArgs f m
LedgerDB.LedgerDbFlavorArgsV1
               ( FlushFrequency
-> BackingStoreArgs Identity IO -> LedgerDbFlavorArgs Identity IO
forall (f :: * -> *) (m :: * -> *).
FlushFrequency -> BackingStoreArgs f m -> LedgerDbFlavorArgs f m
LedgerDB.V1.V1Args
                   FlushFrequency
LedgerDB.V1.DisableFlushing
                   BackingStoreArgs Identity IO
forall (f :: * -> *) (m :: * -> *). BackingStoreArgs f m
LedgerDB.V1.InMemoryBackingStoreArgs
               )
            LedgerDBBackend
V1LMDB  -> LedgerDbFlavorArgs Identity IO -> LedgerDbFlavorArgs Identity IO
forall (f :: * -> *) (m :: * -> *).
LedgerDbFlavorArgs f m -> LedgerDbFlavorArgs f m
LedgerDB.LedgerDbFlavorArgsV1
               ( FlushFrequency
-> BackingStoreArgs Identity IO -> LedgerDbFlavorArgs Identity IO
forall (f :: * -> *) (m :: * -> *).
FlushFrequency -> BackingStoreArgs f m -> LedgerDbFlavorArgs f m
LedgerDB.V1.V1Args
                   FlushFrequency
LedgerDB.V1.DisableFlushing
                   ( [Char]
-> HKD Identity LMDBLimits
-> Dict MonadIOPrim IO
-> BackingStoreArgs Identity IO
forall (f :: * -> *) (m :: * -> *).
[Char]
-> HKD f LMDBLimits -> Dict MonadIOPrim m -> BackingStoreArgs f m
LedgerDB.V1.LMDBBackingStoreArgs
                       [Char]
"lmdb"
                       HKD Identity LMDBLimits
LMDBLimits
defaultLMDBLimits
                       Dict MonadIOPrim IO
forall {k} (c :: k -> Constraint) (a :: k). c a => Dict c a
Dict.Dict
                   )
               )
            LedgerDBBackend
V2InMem -> LedgerDbFlavorArgs Identity IO -> LedgerDbFlavorArgs Identity IO
forall (f :: * -> *) (m :: * -> *).
LedgerDbFlavorArgs f m -> LedgerDbFlavorArgs f m
LedgerDB.LedgerDbFlavorArgsV2
                         (HandleArgs -> LedgerDbFlavorArgs Identity IO
forall {k} {k1} (f :: k) (m :: k1).
HandleArgs -> LedgerDbFlavorArgs f m
LedgerDB.V2.V2Args HandleArgs
LedgerDB.V2.InMemoryHandleArgs)
          args' =
            ResourceRegistry IO
-> TopLevelConfig blk
-> ExtLedgerState blk ValuesMK
-> ChunkInfo
-> (blk -> Bool)
-> (RelativeMountPoint -> SomeHasFS IO)
-> (RelativeMountPoint -> SomeHasFS IO)
-> LedgerDbFlavorArgs Identity IO
-> Incomplete ChainDbArgs IO blk
-> Complete ChainDbArgs IO blk
forall (m :: * -> *) blk.
(ConsensusProtocol (BlockProtocol blk), IOLike m) =>
ResourceRegistry m
-> TopLevelConfig blk
-> ExtLedgerState blk ValuesMK
-> ChunkInfo
-> (blk -> Bool)
-> (RelativeMountPoint -> SomeHasFS m)
-> (RelativeMountPoint -> SomeHasFS m)
-> Complete LedgerDbFlavorArgs m
-> Incomplete ChainDbArgs m blk
-> Complete ChainDbArgs m blk
ChainDB.completeChainDbArgs
              ResourceRegistry IO
registry
              TopLevelConfig blk
cfg
              ExtLedgerState blk ValuesMK
genesisLedger
              ChunkInfo
chunkInfo
              (Bool -> blk -> Bool
forall a b. a -> b -> a
const Bool
True)
              RelativeMountPoint -> SomeHasFS IO
shfs
              RelativeMountPoint -> SomeHasFS IO
shfs
              LedgerDbFlavorArgs Identity IO
flavargs (Incomplete ChainDbArgs IO blk -> Complete ChainDbArgs IO blk)
-> Incomplete ChainDbArgs IO blk -> Complete ChainDbArgs IO blk
forall a b. (a -> b) -> a -> b
$
            Incomplete ChainDbArgs IO blk
forall (m :: * -> *) blk. Monad m => Incomplete ChainDbArgs m blk
ChainDB.defaultArgs
          -- Set @k=1@ to reduce the memory usage of the LedgerDB. We only ever
          -- go forward so we don't need to account for rollbacks.
          args'' =
            Complete ChainDbArgs IO blk
args' {
              ChainDB.cdbLgrDbArgs =
                (\LedgerDbArgs Identity IO blk
x -> LedgerDbArgs Identity IO blk
x
                  { LedgerDB.lgrConfig =
                      LedgerDB.LedgerDbCfg
                        (SecurityParam (knownNonZeroBounded @1))
                        (LedgerDB.ledgerDbCfg $ LedgerDB.lgrConfig x)
                        OmitLedgerEvents
                  }
                )
                (ChainDB.cdbLgrDbArgs args')
              }
          chainDbArgs = Complete ChainDbArgs IO blk -> Complete ChainDbArgs IO blk
maybeValidateAll (Complete ChainDbArgs IO blk -> Complete ChainDbArgs IO blk)
-> Complete ChainDbArgs IO blk -> Complete ChainDbArgs IO blk
forall a b. (a -> b) -> a -> b
$ Tracer IO (TraceEvent blk)
-> Complete ChainDbArgs IO blk -> Complete ChainDbArgs IO blk
forall (m :: * -> *) blk (f :: * -> *).
Tracer m (TraceEvent blk)
-> ChainDbArgs f m blk -> ChainDbArgs f m blk
ChainDB.updateTracer Tracer IO (TraceEvent blk)
chainDBTracer Complete ChainDbArgs IO blk
args''
          immutableDbArgs = Complete ChainDbArgs IO blk -> ImmutableDbArgs Identity IO blk
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> ImmutableDbArgs f m blk
ChainDB.cdbImmDbArgs Complete ChainDbArgs IO blk
chainDbArgs
          ldbArgs = Complete ChainDbArgs IO blk -> LedgerDbArgs Identity IO blk
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> LedgerDbArgs f m blk
ChainDB.cdbLgrDbArgs Complete ChainDbArgs IO blk
args''

      withImmutableDB immutableDbArgs $ \(ImmutableDB IO blk
immutableDB, Internal IO blk
internal) -> do
        SomeAnalysis (Proxy :: Proxy startFrom) ana <- SomeAnalysis blk -> IO (SomeAnalysis blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeAnalysis blk -> IO (SomeAnalysis blk))
-> SomeAnalysis blk -> IO (SomeAnalysis blk)
forall a b. (a -> b) -> a -> b
$ AnalysisName -> SomeAnalysis blk
forall blk.
(HasAnalysis blk, HasTxId (GenTx blk), HasTxs blk,
 LedgerSupportsMempool blk, LedgerSupportsProtocol blk,
 CanStowLedgerTables (LedgerState blk)) =>
AnalysisName -> SomeAnalysis blk
runAnalysis AnalysisName
analysis
        startFrom <- case sing :: Sing startFrom of
          Sing startFrom
SStartFrom startFrom
SStartFromPoint       -> Point blk -> AnalysisStartFrom IO blk startFrom
Point blk -> AnalysisStartFrom IO blk 'StartFromPoint
forall blk (m :: * -> *).
Point blk -> AnalysisStartFrom m blk 'StartFromPoint
FromPoint (Point blk -> AnalysisStartFrom IO blk startFrom)
-> IO (Point blk) -> IO (AnalysisStartFrom IO blk startFrom)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case WithOrigin SlotNo
startSlot of
            WithOrigin SlotNo
Origin         -> Point blk -> IO (Point blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Point blk
forall {k} (block :: k). Point block
GenesisPoint
            NotOrigin SlotNo
slot -> Internal IO blk -> SlotNo -> IO (Maybe (HeaderHash blk))
forall (m :: * -> *) blk.
HasCallStack =>
Internal m blk -> SlotNo -> m (Maybe (HeaderHash blk))
ImmutableDB.getHashForSlot Internal IO blk
internal SlotNo
slot IO (Maybe (HeaderHash blk))
-> (Maybe (HeaderHash blk) -> IO (Point blk)) -> IO (Point blk)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Just HeaderHash blk
hash -> Point blk -> IO (Point blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Point blk -> IO (Point blk)) -> Point blk -> IO (Point blk)
forall a b. (a -> b) -> a -> b
$ SlotNo -> HeaderHash blk -> Point blk
forall {k} (block :: k). SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
slot HeaderHash blk
hash
              Maybe (HeaderHash blk)
Nothing   -> [Char] -> IO (Point blk)
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO (Point blk)) -> [Char] -> IO (Point blk)
forall a b. (a -> b) -> a -> b
$ [Char]
"No block with given slot in the ImmutableDB: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> SlotNo -> [Char]
forall a. Show a => a -> [Char]
show SlotNo
slot
          Sing startFrom
SStartFrom startFrom
SStartFromLedgerState -> do

            (ledgerDB, intLedgerDB) <- LedgerDbArgs Identity IO blk
-> IO (LedgerDB' IO blk, TestInternals' IO blk)
forall blk.
(LedgerSupportsProtocol blk, InspectLedger blk,
 LedgerDbSerialiseConstraints blk, HasHardForkHistory blk,
 LedgerSupportsLedgerDB blk) =>
Complete LedgerDbArgs IO blk
-> IO (LedgerDB' IO blk, TestInternals' IO blk)
openLedgerDB LedgerDbArgs Identity IO blk
ldbArgs
            -- This marker divides the "loading" phase of the program, where the
            -- system is principally occupied with reading snapshot data from
            -- disk, from the "processing" phase, where we are streaming blocks
            -- and running the ledger processing on them.
            Debug.traceMarkerIO "SNAPSHOT_LOADED"
            pure $ FromLedgerState ledgerDB intLedgerDB

        result <- ana AnalysisEnv {
            cfg
          , startFrom
          , db = immutableDB
          , registry
          , limit = confLimit
          , tracer = analysisTracer
          }
        tipPoint <- atomically $ ImmutableDB.getTipPoint immutableDB
        putStrLn $ "ImmutableDB tip: " ++ show tipPoint
        pure result
  where
    DBAnalyserConfig{
        AnalysisName
analysis :: AnalysisName
analysis :: DBAnalyserConfig -> AnalysisName
analysis
      , Limit
confLimit :: Limit
confLimit :: DBAnalyserConfig -> Limit
confLimit
      , [Char]
dbDir :: [Char]
dbDir :: DBAnalyserConfig -> [Char]
dbDir
      , SelectDB
selectDB :: SelectDB
selectDB :: DBAnalyserConfig -> SelectDB
selectDB
      , Maybe ValidateBlocks
validation :: Maybe ValidateBlocks
validation :: DBAnalyserConfig -> Maybe ValidateBlocks
validation
      , Bool
verbose :: Bool
verbose :: DBAnalyserConfig -> Bool
verbose
      , LedgerDBBackend
ldbBackend :: LedgerDBBackend
ldbBackend :: DBAnalyserConfig -> LedgerDBBackend
ldbBackend
      } = DBAnalyserConfig
dbaConfig

    SelectImmutableDB WithOrigin SlotNo
startSlot = SelectDB
selectDB

    withImmutableDB :: Complete ImmutableDbArgs m blk
-> ((ImmutableDB m blk, Internal m blk) -> m c) -> m c
withImmutableDB Complete ImmutableDbArgs m blk
immutableDbArgs =
        m (ImmutableDB m blk, Internal m blk)
-> ((ImmutableDB m blk, Internal m blk) -> m ())
-> ((ImmutableDB m blk, Internal m blk) -> m c)
-> m c
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
          (Complete ImmutableDbArgs m blk
-> (forall h.
    WithTempRegistry
      (OpenState m blk h)
      m
      ((ImmutableDB m blk, Internal m blk), OpenState m blk h)
    -> m (ImmutableDB m blk, Internal m blk))
-> m (ImmutableDB m blk, Internal m blk)
forall (m :: * -> *) blk ans.
(IOLike m, GetPrevHash blk, ConvertRawHash blk,
 ImmutableDbSerialiseConstraints blk, HasCallStack) =>
Complete ImmutableDbArgs m blk
-> (forall h.
    WithTempRegistry
      (OpenState m blk h)
      m
      ((ImmutableDB m blk, Internal m blk), OpenState m blk h)
    -> ans)
-> ans
ImmutableDB.openDBInternal Complete ImmutableDbArgs m blk
immutableDbArgs WithTempRegistry
  (OpenState m blk h)
  m
  ((ImmutableDB m blk, Internal m blk), OpenState m blk h)
-> m (ImmutableDB m blk, Internal m blk)
forall h.
WithTempRegistry
  (OpenState m blk h)
  m
  ((ImmutableDB m blk, Internal m blk), OpenState m blk h)
-> m (ImmutableDB m blk, Internal m blk)
forall (m :: * -> *) st a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
WithTempRegistry st m (a, st) -> m a
runWithTempRegistry)
          (ImmutableDB m blk -> m ()
forall (m :: * -> *) blk. HasCallStack => ImmutableDB m blk -> m ()
ImmutableDB.closeDB (ImmutableDB m blk -> m ())
-> ((ImmutableDB m blk, Internal m blk) -> ImmutableDB m blk)
-> (ImmutableDB m blk, Internal m blk)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImmutableDB m blk, Internal m blk) -> ImmutableDB m blk
forall a b. (a, b) -> a
fst)

    mkTracer :: StrictMVar IO () -> Bool -> m (Tracer IO a)
mkTracer StrictMVar IO ()
_    Bool
False = Tracer IO a -> m (Tracer IO a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Tracer IO a
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    mkTracer StrictMVar IO ()
lock Bool
True  = do
      startTime <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
      return $ Tracer $ \a
ev -> IO () -> IO ()
withLock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        traceTime <- IO Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
        let diff = Time -> Time -> DiffTime
diffTime Time
traceTime Time
startTime
        hPutStrLn stderr $ printf "[%.6fs] %s" (realToFrac diff :: Double) (show ev)
        hFlush stderr
      where
        withLock :: IO () -> IO ()
withLock = IO () -> IO () -> IO () -> IO ()
forall a b c. IO a -> IO b -> IO c -> IO c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> m b -> m c -> m c
bracket_ (StrictMVar IO () -> IO ()
forall (m :: * -> *) a. MonadMVar m => StrictMVar m a -> m a
takeMVar StrictMVar IO ()
lock) (StrictMVar IO () -> () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadMVar m) =>
StrictMVar m a -> a -> m ()
putMVar StrictMVar IO ()
lock ())

    maybeValidateAll :: Complete ChainDbArgs IO blk -> Complete ChainDbArgs IO blk
maybeValidateAll = case (AnalysisName
analysis, Maybe ValidateBlocks
validation) of
      (AnalysisName
_, Just ValidateBlocks
ValidateAllBlocks)      -> Complete ChainDbArgs IO blk -> Complete ChainDbArgs IO blk
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> ChainDbArgs f m blk
ChainDB.ensureValidateAll
      (AnalysisName
_, Just ValidateBlocks
MinimumBlockValidation) -> Complete ChainDbArgs IO blk -> Complete ChainDbArgs IO blk
forall a. a -> a
id
      (AnalysisName
OnlyValidation, Maybe ValidateBlocks
_ )             -> Complete ChainDbArgs IO blk -> Complete ChainDbArgs IO blk
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> ChainDbArgs f m blk
ChainDB.ensureValidateAll
      (AnalysisName, Maybe ValidateBlocks)
_                                -> Complete ChainDbArgs IO blk -> Complete ChainDbArgs IO blk
forall a. a -> a
id