{-# 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.Functor.Contravariant ((>$<))
import qualified Data.SOP.Dict as Dict
import Data.Singletons (Sing, SingI (..))
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.Extended
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 Ouroboros.Consensus.Storage.LedgerDB (TraceEvent (..))
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 as LedgerDB.V1
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as LedgerDB.V1
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as LedgerDB.V2
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as LedgerDB.V2
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM
import Ouroboros.Consensus.Util.Args
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.Orphans ()
import Ouroboros.Network.Block (genesisPoint)
import System.FS.API
import System.IO
import System.Random
import Text.Printf (printf)

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

openLedgerDB ::
  forall blk.
  ( LedgerSupportsProtocol blk
  , InspectLedger 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,
 HasHardForkHistory blk, LedgerSupportsLedgerDB blk) =>
Complete LedgerDbArgs IO blk
-> IO (LedgerDB' IO blk, TestInternals' IO blk)
openLedgerDB Complete LedgerDbArgs IO blk
args = do
  (ldb, _, od) <- case Complete LedgerDbArgs IO blk -> LedgerDbBackendArgs IO blk
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> LedgerDbBackendArgs m blk
LedgerDB.lgrBackendArgs Complete LedgerDbArgs IO blk
args of
    LedgerDB.LedgerDbBackendArgsV1 LedgerDbBackendArgs IO (ExtLedgerState blk)
bss ->
      let snapManager :: SnapshotManager
  IO
  (ReadLocked IO)
  blk
  (StrictTVar IO (DbChangelog' blk), BackingStore' IO blk)
snapManager = Complete LedgerDbArgs IO blk
-> SnapshotManager
     IO
     (ReadLocked IO)
     blk
     (StrictTVar IO (DbChangelog' blk), BackingStore' IO blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk) =>
Complete LedgerDbArgs m blk
-> SnapshotManager
     m
     (ReadLocked m)
     blk
     (StrictTVar m (DbChangelog' blk), BackingStore' m blk)
LedgerDB.V1.snapshotManager Complete LedgerDbArgs IO blk
args
          initDb :: InitDB
  (DbChangelog' blk, ResourceKey IO, BackingStore' IO blk) IO blk
initDb =
            Complete LedgerDbArgs IO blk
-> LedgerDbBackendArgs IO (ExtLedgerState blk)
-> ResolveBlock IO blk
-> SnapshotManager
     IO
     (ReadLocked IO)
     blk
     (StrictTVar IO (DbChangelog' blk), BackingStore' IO blk)
-> GetVolatileSuffix IO blk
-> InitDB
     (DbChangelog' blk, ResourceKey IO, BackingStore' IO blk) IO blk
forall (m :: * -> *) blk.
(LedgerSupportsProtocol blk, IOLike m, HasHardForkHistory blk,
 LedgerSupportsLedgerDB blk) =>
Complete LedgerDbArgs m blk
-> LedgerDbBackendArgs m (ExtLedgerState blk)
-> ResolveBlock m blk
-> SnapshotManagerV1 m blk
-> GetVolatileSuffix m blk
-> InitDB
     (DbChangelog' blk, ResourceKey m, BackingStore' m blk) m blk
LedgerDB.V1.mkInitDb
              Complete LedgerDbArgs IO blk
args
              LedgerDbBackendArgs IO (ExtLedgerState blk)
bss
              (\RealPoint blk
_ -> blk -> IO blk
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> blk
forall a. HasCallStack => [Char] -> a
error [Char]
"no stream"))
              SnapshotManager
  IO
  (ReadLocked IO)
  blk
  (StrictTVar IO (DbChangelog' blk), BackingStore' IO blk)
snapManager
              (SecurityParam -> GetVolatileSuffix IO blk
forall (m :: * -> *) blk.
IOLike m =>
SecurityParam -> GetVolatileSuffix m blk
LedgerDB.praosGetVolatileSuffix (SecurityParam -> GetVolatileSuffix IO blk)
-> SecurityParam -> GetVolatileSuffix IO blk
forall a b. (a -> b) -> a -> b
$ LedgerDbCfgF Identity (ExtLedgerState blk)
-> HKD Identity SecurityParam
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f SecurityParam
LedgerDB.ledgerDbCfgSecParam (LedgerDbCfgF Identity (ExtLedgerState blk)
 -> HKD Identity SecurityParam)
-> LedgerDbCfgF Identity (ExtLedgerState blk)
-> HKD Identity SecurityParam
forall a b. (a -> b) -> a -> b
$ Complete LedgerDbArgs IO blk
-> LedgerDbCfgF Identity (ExtLedgerState blk)
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> LedgerDbCfgF f (ExtLedgerState blk)
LedgerDB.lgrConfig Complete LedgerDbArgs IO blk
args)
       in Complete LedgerDbArgs IO blk
-> InitDB
     (DbChangelog' blk, ResourceKey IO,
      BackingStore
        IO
        (LedgerTables (ExtLedgerState blk) KeysMK)
        (TxIn (LedgerState blk))
        (LedgerTables (ExtLedgerState blk) ValuesMK)
        (LedgerTables (ExtLedgerState blk) DiffMK))
     IO
     blk
-> SnapshotManager
     IO
     (ReadLocked IO)
     blk
     (StrictTVar IO (DbChangelog' blk),
      BackingStore
        IO
        (LedgerTables (ExtLedgerState blk) KeysMK)
        (TxIn (LedgerState blk))
        (LedgerTables (ExtLedgerState blk) ValuesMK)
        (LedgerTables (ExtLedgerState blk) DiffMK))
-> StreamAPI IO blk blk
-> Point blk
-> IO (LedgerDB' IO blk, Word64, TestInternals' IO blk)
forall (m :: * -> *) blk db (n :: * -> *) st.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Complete LedgerDbArgs m blk
-> InitDB db m blk
-> SnapshotManager m n blk st
-> StreamAPI m blk blk
-> Point blk
-> m (LedgerDB' m blk, Word64, TestInternals' m blk)
LedgerDB.openDBInternal Complete LedgerDbArgs IO blk
args InitDB
  (DbChangelog' blk, ResourceKey IO,
   BackingStore
     IO
     (LedgerTables (ExtLedgerState blk) KeysMK)
     (TxIn (LedgerState blk))
     (LedgerTables (ExtLedgerState blk) ValuesMK)
     (LedgerTables (ExtLedgerState blk) DiffMK))
  IO
  blk
InitDB
  (DbChangelog' blk, ResourceKey IO, BackingStore' IO blk) IO blk
initDb SnapshotManager
  IO
  (ReadLocked IO)
  blk
  (StrictTVar IO (DbChangelog' blk),
   BackingStore
     IO
     (LedgerTables (ExtLedgerState blk) KeysMK)
     (TxIn (LedgerState blk))
     (LedgerTables (ExtLedgerState blk) ValuesMK)
     (LedgerTables (ExtLedgerState blk) DiffMK))
SnapshotManager
  IO
  (ReadLocked IO)
  blk
  (StrictTVar IO (DbChangelog' blk), BackingStore' IO blk)
snapManager StreamAPI IO blk blk
forall (m :: * -> *) blk a. Applicative m => StreamAPI m blk a
emptyStream Point blk
forall {k} (block :: k). Point block
genesisPoint
    LedgerDB.LedgerDbBackendArgsV2 (LedgerDB.V2.SomeBackendArgs Args IO backend
bArgs) -> do
      res <-
        Proxy blk
-> Tracer IO LedgerDBV2Trace
-> Args IO backend
-> ResourceRegistry IO
-> SomeHasFS IO
-> IO (Resources IO backend)
forall (m :: * -> *) backend blk.
Backend m backend blk =>
Proxy blk
-> Tracer m LedgerDBV2Trace
-> Args m backend
-> ResourceRegistry m
-> SomeHasFS m
-> m (Resources m backend)
LedgerDB.V2.mkResources
          (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)
          (FlavorImplSpecificTrace -> TraceEvent blk
forall blk. FlavorImplSpecificTrace -> TraceEvent blk
LedgerDBFlavorImplEvent (FlavorImplSpecificTrace -> TraceEvent blk)
-> (LedgerDBV2Trace -> FlavorImplSpecificTrace)
-> LedgerDBV2Trace
-> TraceEvent blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBV2Trace -> FlavorImplSpecificTrace
LedgerDB.FlavorImplSpecificTraceV2 (LedgerDBV2Trace -> TraceEvent blk)
-> Tracer IO (TraceEvent blk) -> Tracer IO LedgerDBV2Trace
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Complete LedgerDbArgs IO blk -> Tracer IO (TraceEvent blk)
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> Tracer m (TraceEvent blk)
LedgerDB.lgrTracer Complete LedgerDbArgs IO blk
args)
          Args IO backend
bArgs
          (Complete LedgerDbArgs IO blk -> HKD Identity (ResourceRegistry IO)
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (ResourceRegistry m)
LedgerDB.lgrRegistry Complete LedgerDbArgs IO blk
args)
          (Complete LedgerDbArgs IO blk -> HKD Identity (SomeHasFS IO)
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (SomeHasFS m)
LedgerDB.lgrHasFS Complete LedgerDbArgs IO blk
args)
      let snapManager =
            Proxy blk
-> Resources IO backend
-> CodecConfig blk
-> Tracer IO (TraceSnapshotEvent blk)
-> SomeHasFS IO
-> SnapshotManager IO IO blk (StateRef IO (ExtLedgerState blk))
forall (m :: * -> *) backend blk.
Backend m backend blk =>
Proxy blk
-> Resources m backend
-> CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> SnapshotManager m m blk (StateRef m (ExtLedgerState blk))
LedgerDB.V2.snapshotManager
              (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)
              Resources IO backend
res
              (TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec (TopLevelConfig blk -> CodecConfig blk)
-> (LedgerDbCfgF Identity (ExtLedgerState blk)
    -> TopLevelConfig blk)
-> LedgerDbCfgF Identity (ExtLedgerState blk)
-> CodecConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg (ExtLedgerCfg blk -> TopLevelConfig blk)
-> (LedgerDbCfgF Identity (ExtLedgerState blk) -> ExtLedgerCfg blk)
-> LedgerDbCfgF Identity (ExtLedgerState blk)
-> TopLevelConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDbCfgF Identity (ExtLedgerState blk)
-> HKD Identity (LedgerCfg (ExtLedgerState blk))
LedgerDbCfgF Identity (ExtLedgerState blk) -> ExtLedgerCfg blk
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
LedgerDB.ledgerDbCfg (LedgerDbCfgF Identity (ExtLedgerState blk) -> CodecConfig blk)
-> LedgerDbCfgF Identity (ExtLedgerState blk) -> CodecConfig blk
forall a b. (a -> b) -> a -> b
$ Complete LedgerDbArgs IO blk
-> LedgerDbCfgF Identity (ExtLedgerState blk)
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> LedgerDbCfgF f (ExtLedgerState blk)
LedgerDB.lgrConfig Complete LedgerDbArgs IO blk
args)
              (TraceSnapshotEvent blk -> TraceEvent blk
forall blk. TraceSnapshotEvent blk -> TraceEvent blk
LedgerDBSnapshotEvent (TraceSnapshotEvent blk -> TraceEvent blk)
-> Tracer IO (TraceEvent blk) -> Tracer IO (TraceSnapshotEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Complete LedgerDbArgs IO blk -> Tracer IO (TraceEvent blk)
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> Tracer m (TraceEvent blk)
LedgerDB.lgrTracer Complete LedgerDbArgs IO blk
args)
              (Complete LedgerDbArgs IO blk -> HKD Identity (SomeHasFS IO)
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (SomeHasFS m)
LedgerDB.lgrHasFS Complete LedgerDbArgs IO blk
args)
      let initDb =
            Complete LedgerDbArgs IO blk
-> ResolveBlock IO blk
-> SnapshotManager IO IO blk (StateRef IO (ExtLedgerState blk))
-> GetVolatileSuffix IO blk
-> Resources IO backend
-> InitDB (LedgerSeq' IO blk) IO blk
forall (m :: * -> *) blk backend.
(LedgerSupportsProtocol blk, LedgerDbSerialiseConstraints blk,
 HasHardForkHistory blk, Backend m backend blk, IOLike m) =>
Complete LedgerDbArgs m blk
-> ResolveBlock m blk
-> SnapshotManagerV2 m blk
-> GetVolatileSuffix m blk
-> Resources m backend
-> InitDB (LedgerSeq' m blk) m blk
LedgerDB.V2.mkInitDb
              Complete LedgerDbArgs IO blk
args
              (\RealPoint blk
_ -> blk -> IO blk
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> blk
forall a. HasCallStack => [Char] -> a
error [Char]
"no stream"))
              SnapshotManager IO IO blk (StateRef IO (ExtLedgerState blk))
snapManager
              (SecurityParam -> GetVolatileSuffix IO blk
forall (m :: * -> *) blk.
IOLike m =>
SecurityParam -> GetVolatileSuffix m blk
LedgerDB.praosGetVolatileSuffix (SecurityParam -> GetVolatileSuffix IO blk)
-> SecurityParam -> GetVolatileSuffix IO blk
forall a b. (a -> b) -> a -> b
$ LedgerDbCfgF Identity (ExtLedgerState blk)
-> HKD Identity SecurityParam
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f SecurityParam
LedgerDB.ledgerDbCfgSecParam (LedgerDbCfgF Identity (ExtLedgerState blk)
 -> HKD Identity SecurityParam)
-> LedgerDbCfgF Identity (ExtLedgerState blk)
-> HKD Identity SecurityParam
forall a b. (a -> b) -> a -> b
$ Complete LedgerDbArgs IO blk
-> LedgerDbCfgF Identity (ExtLedgerState blk)
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> LedgerDbCfgF f (ExtLedgerState blk)
LedgerDB.lgrConfig Complete LedgerDbArgs IO blk
args)
              Resources IO backend
res
      LedgerDB.openDBInternal args initDb snapManager emptyStream genesisPoint
  pure (ldb, od)

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
    lsmSalt <- fst . genWord64 <$> newStdGen
    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
V1LMDB ->
            LedgerDbBackendArgs IO (ExtLedgerState blk)
-> LedgerDbBackendArgs IO blk
forall (m :: * -> *) blk.
LedgerDbBackendArgs m (ExtLedgerState blk)
-> LedgerDbBackendArgs m blk
LedgerDB.LedgerDbBackendArgsV1
              (LedgerDbBackendArgs IO (ExtLedgerState blk)
 -> LedgerDbBackendArgs IO blk)
-> LedgerDbBackendArgs IO (ExtLedgerState blk)
-> LedgerDbBackendArgs IO blk
forall a b. (a -> b) -> a -> b
$ FlushFrequency
-> SomeBackendArgs IO (ExtLedgerState blk)
-> LedgerDbBackendArgs IO (ExtLedgerState blk)
forall (m :: * -> *) (l :: LedgerStateKind).
FlushFrequency -> SomeBackendArgs m l -> LedgerDbBackendArgs m l
LedgerDB.V1.V1Args
                FlushFrequency
LedgerDB.V1.DisableFlushing
              (SomeBackendArgs IO (ExtLedgerState blk)
 -> LedgerDbBackendArgs IO (ExtLedgerState blk))
-> SomeBackendArgs IO (ExtLedgerState blk)
-> LedgerDbBackendArgs IO (ExtLedgerState blk)
forall a b. (a -> b) -> a -> b
$ Args IO LMDB -> SomeBackendArgs IO (ExtLedgerState blk)
forall (m :: * -> *) backend (l :: LedgerStateKind).
Backend m backend l =>
Args m backend -> SomeBackendArgs m l
LedgerDB.V1.SomeBackendArgs
              (Args IO LMDB -> SomeBackendArgs IO (ExtLedgerState blk))
-> Args IO LMDB -> SomeBackendArgs IO (ExtLedgerState blk)
forall a b. (a -> b) -> a -> b
$ [Char] -> LMDBLimits -> Dict MonadIOPrim IO -> Args IO LMDB
forall (m :: * -> *).
[Char] -> LMDBLimits -> Dict MonadIOPrim m -> Args m LMDB
LMDB.LMDBBackingStoreArgs
                [Char]
"lmdb"
                LMDBLimits
defaultLMDBLimits
                Dict MonadIOPrim IO
forall {k} (c :: k -> Constraint) (a :: k). c a => Dict c a
Dict.Dict
          LedgerDBBackend
V2InMem ->
            SomeBackendArgs IO blk -> LedgerDbBackendArgs IO blk
forall (m :: * -> *) blk.
SomeBackendArgs m blk -> LedgerDbBackendArgs m blk
LedgerDB.LedgerDbBackendArgsV2 (SomeBackendArgs IO blk -> LedgerDbBackendArgs IO blk)
-> SomeBackendArgs IO blk -> LedgerDbBackendArgs IO blk
forall a b. (a -> b) -> a -> b
$
              Args IO Mem -> SomeBackendArgs IO blk
forall (m :: * -> *) backend blk.
Backend m backend blk =>
Args m backend -> SomeBackendArgs m blk
LedgerDB.V2.SomeBackendArgs Args IO Mem
forall (m :: * -> *). Args m Mem
InMemory.InMemArgs
          LedgerDBBackend
V2LSM ->
            SomeBackendArgs IO blk -> LedgerDbBackendArgs IO blk
forall (m :: * -> *) blk.
SomeBackendArgs m blk -> LedgerDbBackendArgs m blk
LedgerDB.LedgerDbBackendArgsV2 (SomeBackendArgs IO blk -> LedgerDbBackendArgs IO blk)
-> SomeBackendArgs IO blk -> LedgerDbBackendArgs IO blk
forall a b. (a -> b) -> a -> b
$
              Args IO LSM -> SomeBackendArgs IO blk
forall (m :: * -> *) backend blk.
Backend m backend blk =>
Args m backend -> SomeBackendArgs m blk
LedgerDB.V2.SomeBackendArgs (Args IO LSM -> SomeBackendArgs IO blk)
-> Args IO LSM -> SomeBackendArgs IO blk
forall a b. (a -> b) -> a -> b
$
                FsPath
-> Word64
-> (ResourceRegistry IO
    -> IO (ResourceKey IO, SomeHasFSAndBlockIO IO))
-> Args IO LSM
forall (m :: * -> *).
FsPath
-> Word64
-> (ResourceRegistry m -> m (ResourceKey m, SomeHasFSAndBlockIO m))
-> Args m LSM
LSM.LSMArgs ([[Char]] -> FsPath
mkFsPath [[Char]
"lsm"]) Word64
lsmSalt ([Char]
-> ResourceRegistry IO
-> IO (ResourceKey IO, SomeHasFSAndBlockIO IO)
LSM.stdMkBlockIOFS [Char]
dbDir)

        args' =
          ResourceRegistry IO
-> TopLevelConfig blk
-> ExtLedgerState blk ValuesMK
-> ChunkInfo
-> (blk -> Bool)
-> (RelativeMountPoint -> SomeHasFS IO)
-> (RelativeMountPoint -> SomeHasFS IO)
-> LedgerDbBackendArgs IO blk
-> 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)
-> LedgerDbBackendArgs m blk
-> 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
            LedgerDbBackendArgs IO blk
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.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk,
 LedgerSupportsInMemoryLedgerDB (LedgerState blk)) =>
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,
 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