{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# 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.Monad (unless)
import Control.Monad.Trans.Class
import Control.ResourceRegistry
import Control.Tracer (mkTracer, nullTracer, (>$<))
import Data.SOP (All, Top)
import Data.Singletons (Sing, SingI (..))
import qualified Debug.Trace as Debug
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..))
import Ouroboros.Consensus.Ledger.Abstract
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 Ouroboros.Consensus.Peras.Context (StateSupportsPerasEpochContext)
import Ouroboros.Consensus.Protocol.Abstract
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
import Ouroboros.Consensus.Storage.Common (BlockComponent (..))
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 Ouroboros.Consensus.Storage.LedgerDB.Snapshots
  ( DiskSnapshot (..)
  , listSnapshots
  )
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.FilePath (splitDirectories)
import System.IO
import System.Random (genWord64, newStdGen)
import Text.Printf (printf)

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

openLedgerDB ::
  forall blk.
  ( All Top (HardForkIndices blk)
  , LedgerSupportsProtocol blk
  , BlockSupportsPeras blk
  , StateSupportsPerasEpochContext blk
  , InspectLedger blk
  ) =>
  Complete LedgerDB.LedgerDbArgs IO blk ->
  ImmutableDB.ImmutableDB IO blk ->
  -- | The replay goal, i.e. the point up to which blocks from the ImmutableDB
  -- are replayed on top of the chosen snapshot. The chosen snapshot is the
  -- newest one that is not more recent than this point, and blocks are replayed
  -- on top of it until the ledger state is exactly at this point. For
  -- db-analyser this is the @--analyse-from@ point, so that an analysis
  -- starting from a ledger state begins exactly there, regardless of which
  -- snapshots happen to exist on disk.
  Point blk ->
  IO
    ( LedgerDB.LedgerDB' IO blk
    , LedgerDB.TestInternals' IO blk
    )
openLedgerDB :: forall blk.
(All Top (HardForkIndices blk), LedgerSupportsProtocol blk,
 BlockSupportsPeras blk, StateSupportsPerasEpochContext blk,
 InspectLedger blk) =>
Complete LedgerDbArgs IO blk
-> ImmutableDB IO blk
-> Point blk
-> IO (LedgerDB' IO blk, TestInternals' IO blk)
openLedgerDB Complete LedgerDbArgs IO blk
args ImmutableDB IO blk
immutableDB Point blk
replayGoal =
  WithTempRegistry
  () IO ((LedgerDB' IO blk, TestInternals' IO blk), ())
-> IO (LedgerDB' IO blk, TestInternals' IO blk)
forall (m :: * -> *) st a.
(MonadSTM m, MonadMask m, MonadThread m, MonadEvaluate m,
 HasCallStack) =>
WithTempRegistry st m (a, st) -> m a
runWithTempRegistry (WithTempRegistry
   () IO ((LedgerDB' IO blk, TestInternals' IO blk), ())
 -> IO (LedgerDB' IO blk, TestInternals' IO blk))
-> WithTempRegistry
     () IO ((LedgerDB' IO blk, TestInternals' IO blk), ())
-> IO (LedgerDB' IO blk, TestInternals' IO blk)
forall a b. (a -> b) -> a -> b
$
    (,()) ((LedgerDB' IO blk, TestInternals' IO blk)
 -> ((LedgerDB' IO blk, TestInternals' IO blk), ()))
-> WithTempRegistry () IO (LedgerDB' IO blk, TestInternals' IO blk)
-> WithTempRegistry
     () IO ((LedgerDB' IO blk, TestInternals' IO blk), ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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.LedgerDbBackendArgsV2 (LedgerDB.V2.SomeBackendArgs Args IO backend
bArgs) -> do
          res <-
            Proxy blk
-> Tracer IO LedgerDBV2Trace
-> Args IO backend
-> SomeHasFS IO
-> WithTempRegistry () IO (Resources IO backend)
forall fState.
Proxy blk
-> Tracer IO LedgerDBV2Trace
-> Args IO backend
-> SomeHasFS IO
-> WithTempRegistry fState IO (Resources IO backend)
forall (m :: * -> *) backend blk fState.
Backend m backend blk =>
Proxy blk
-> Tracer m LedgerDBV2Trace
-> Args m backend
-> SomeHasFS m
-> WithTempRegistry fState 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 (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 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 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 :: StateKind) blk.
LedgerDbCfgF f l blk -> HKD f (LedgerCfg l blk)
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 blk (StateRef IO ExtLedgerState blk)
-> GetVolatileSuffix IO blk
-> Resources IO backend
-> InitDB (LedgerSeq' IO blk) IO blk
forall (m :: * -> *) blk backend.
(All Top (HardForkIndices blk), LedgerSupportsProtocol blk,
 BlockSupportsPeras blk, StateSupportsPerasEpochContext 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 (String -> blk
forall a. HasCallStack => String -> a
error String
"no stream"))
                  SnapshotManager 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 :: StateKind) blk.
LedgerDbCfgF f l blk -> 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
          lift $ do
            warnUnlessSnapshotAtGoal snapManager
            -- The replay goal is the @--analyse-from@ point, which is not
            -- necessarily the ImmutableDB tip, so we do not know whether it
            -- is an EBB. Assume it is not, like the vast majority of blocks.
            LedgerDB.openDBInternal args initDb snapManager replayStream replayGoal IsNotEBB
      pure (ldb, od)
 where
  -- Stream blocks from the ImmutableDB, stopping as soon as we reach a block
  -- that is more recent than the replay goal. As a result, the replay leaves
  -- the ledger state exactly at the replay goal (the last block at or before
  -- it), rather than streaming all the way to the ImmutableDB tip.
  replayStream :: StreamAPI IO blk blk
replayStream = (blk -> IO (NextItem blk))
-> BlockComponent blk blk
-> ImmutableDB IO blk
-> StreamAPI IO blk blk
forall (m :: * -> *) blk a.
(IOLike m, HasHeader blk) =>
(a -> m (NextItem a))
-> BlockComponent blk a -> ImmutableDB m blk -> StreamAPI m blk a
ImmutableDB.streamAPI' blk -> IO (NextItem blk)
shouldStop BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock ImmutableDB IO blk
immutableDB
   where
    shouldStop :: blk -> IO (NextItem blk)
shouldStop blk
blk
      | SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk) WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
replayGoal = NextItem blk -> IO (NextItem blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NextItem blk
forall blk. NextItem blk
ImmutableDB.NoMoreItems
      | Bool
otherwise = NextItem blk -> IO (NextItem blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NextItem blk -> IO (NextItem blk))
-> NextItem blk -> IO (NextItem blk)
forall a b. (a -> b) -> a -> b
$ blk -> NextItem blk
forall blk. blk -> NextItem blk
ImmutableDB.NextItem blk
blk

  -- Warn when there is no snapshot exactly at the requested replay goal. In
  -- that case the LedgerDB is initialised from the newest older snapshot and
  -- blocks are replayed up to the goal, which can be considerably slower than
  -- starting from a snapshot that already sits at the requested slot.
  warnUnlessSnapshotAtGoal :: SnapshotManager IO blk (StateRef IO ExtLedgerState blk) -> IO ()
warnUnlessSnapshotAtGoal SnapshotManager IO blk (StateRef IO ExtLedgerState blk)
snapManager =
    case Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
replayGoal of
      WithOrigin SlotNo
Origin -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      NotOrigin SlotNo
slot -> do
        snapshots <- SnapshotManager IO blk (StateRef IO ExtLedgerState blk)
-> IO [DiskSnapshot]
forall (m :: * -> *) blk st.
SnapshotManager m blk st -> m [DiskSnapshot]
listSnapshots SnapshotManager IO blk (StateRef IO ExtLedgerState blk)
snapManager
        unless (any ((== unSlotNo slot) . dsNumber) snapshots) $
          hPutStrLn stderr $
            "Warning: no ledger snapshot exists exactly at slot "
              <> show (unSlotNo slot)
              <> "; starting from the newest older snapshot and replaying blocks up to that slot."

analyse ::
  forall blk.
  ( Node.RunNode blk
  , Show (Header blk)
  , Show (ReasonForSwitch (TiebreakerView (BlockProtocol blk)))
  , Show (TxIn blk)
  , Show (TxOut 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),
 Show (ReasonForSwitch (TiebreakerView (BlockProtocol blk))),
 Show (TxIn blk), Show (TxOut 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, MonadEvaluate 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 <- mkVerboseTracer lock verbose
    analysisTracer <- mkVerboseTracer lock True
    LSMConfig{lsmConfigExportPath} <- mkLSMConfig args
    lsmSalt <- fst . genWord64 <$> newStdGen
    ProtocolInfo{pInfoInitLedger = genesisLedger, pInfoConfig = cfg} <-
      mkProtocolInfo args
    snapshotDelayRng <- newStdGen
    let shfs = String -> RelativeMountPoint -> SomeHasFS IO
Node.stdMkChainDbHasFS String
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
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
          V2LSM Bool
lsmNoDiskCache ->
            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
-> Maybe FsPath
-> Word64
-> DiskCachePolicy
-> (forall st. WithTempRegistry st IO (SomeHasFSAndBlockIO IO))
-> Args IO LSM
forall (m :: * -> *).
FsPath
-> Maybe FsPath
-> Word64
-> DiskCachePolicy
-> (forall st. WithTempRegistry st m (SomeHasFSAndBlockIO m))
-> Args m LSM
LSM.LSMArgs
                  ([String] -> FsPath
mkFsPath [String
"lsm"])
                  ([String] -> FsPath
mkFsPath ([String] -> FsPath) -> (String -> [String]) -> String -> FsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories (String -> FsPath) -> Maybe String -> Maybe FsPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
lsmConfigExportPath)
                  Word64
lsmSalt
                  (if Bool
lsmNoDiskCache then DiskCachePolicy
LSM.DiskCacheNone else DiskCachePolicy
LSM.DiskCacheAll)
                  (String -> WithTempRegistry st IO (SomeHasFSAndBlockIO IO)
forall st.
String -> WithTempRegistry st IO (SomeHasFSAndBlockIO IO)
LSM.stdMkBlockIOFS String
dbDir)

        args' =
          ResourceRegistry IO
-> TopLevelConfig blk
-> ExtLedgerState blk ValuesMK
-> ChunkInfo
-> (blk -> Bool)
-> (RelativeMountPoint -> SomeHasFS IO)
-> (RelativeMountPoint -> SomeHasFS IO)
-> StdGen
-> LedgerDbBackendArgs IO blk
-> Incomplete ChainDbArgs IO blk
-> Complete ChainDbArgs IO blk
forall blk (m :: * -> *).
(ConsensusProtocol (BlockProtocol blk), IOLike m) =>
ResourceRegistry m
-> TopLevelConfig blk
-> ExtLedgerState blk ValuesMK
-> ChunkInfo
-> (blk -> Bool)
-> (RelativeMountPoint -> SomeHasFS m)
-> (RelativeMountPoint -> SomeHasFS m)
-> StdGen
-> 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
            StdGen
snapshotDelayRng
            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,
 CanUpgradeLedgerTables 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 :: * -> *).
Monad m =>
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, All Top (HardForkIndices blk),
 HasTxId (GenTx blk), HasTxs blk, LedgerSupportsMempool blk,
 LedgerSupportsProtocol blk, BlockSupportsPeras blk,
 StateSupportsPerasEpochContext blk,
 CanStowLedgerTables (LedgerState blk), Show (TxIn blk),
 Show (TxOut blk)) =>
AnalysisName -> SomeAnalysis blk
runAnalysis AnalysisName
analysis

      let getPointForSlot :: SlotNo -> IO (Point blk)
          getPointForSlot 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 -> String -> IO (Point blk)
forall a. HasCallStack => String -> IO a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail (String -> IO (Point blk)) -> String -> IO (Point blk)
forall a b. (a -> b) -> a -> b
$ String
"No block with given slot in the ImmutableDB: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SlotNo -> String
forall a. Show a => a -> String
show SlotNo
slot

      startFrom <- case sing :: Sing startFrom of
        Sing startFrom
SStartFrom startFrom
SStartFromPoint -> do
          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 -> SlotNo -> IO (Point blk)
getPointForSlot SlotNo
slot
        Sing startFrom
SStartFrom startFrom
SStartFromLedgerState -> do
          (ledgerDB, intLedgerDB) <-
            LedgerDbArgs Identity IO blk
-> ImmutableDB IO blk
-> Point blk
-> IO (LedgerDB' IO blk, TestInternals' IO blk)
forall blk.
(All Top (HardForkIndices blk), LedgerSupportsProtocol blk,
 BlockSupportsPeras blk, StateSupportsPerasEpochContext blk,
 InspectLedger blk) =>
Complete LedgerDbArgs IO blk
-> ImmutableDB IO blk
-> Point blk
-> IO (LedgerDB' IO blk, TestInternals' IO blk)
openLedgerDB LedgerDbArgs Identity IO blk
ldbArgs ImmutableDB IO blk
immutableDB (Point blk -> IO (LedgerDB' IO blk, TestInternals' IO blk))
-> IO (Point blk) -> IO (LedgerDB' IO blk, TestInternals' IO blk)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m 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 -> SlotNo -> IO (Point blk)
getPointForSlot SlotNo
slot
          -- 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
    , String
dbDir :: String
dbDir :: DBAnalyserConfig -> String
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 :: ImmutableDbArgs Identity m blk
-> ((ImmutableDB m blk, Internal m blk) -> m c) -> m c
withImmutableDB ImmutableDbArgs Identity 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
      (ImmutableDbArgs Identity m blk
-> m (ImmutableDB m blk, Internal m blk)
forall (m :: * -> *) blk.
(IOLike m, GetPrevHash blk, ConvertRawHash blk,
 ImmutableDbSerialiseConstraints blk, HasCallStack) =>
Complete ImmutableDbArgs m blk
-> m (ImmutableDB m blk, Internal m blk)
ImmutableDB.openDBInternal ImmutableDbArgs Identity m blk
immutableDbArgs)
      (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)

  mkVerboseTracer :: StrictMVar IO () -> Bool -> m (Tracer IO a)
mkVerboseTracer 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. Monad m => Tracer m a
nullTracer
  mkVerboseTracer StrictMVar IO ()
lock Bool
True = do
    startTime <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
    return $ mkTracer $ \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