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

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

import           Cardano.Tools.DBAnalyser.Analysis
import           Cardano.Tools.DBAnalyser.HasAnalysis
import           Cardano.Tools.DBAnalyser.Types
import           Codec.Serialise (Serialise (decode))
import           Control.Monad.Except (runExceptT)
import           Control.ResourceRegistry
import           Control.Tracer (Tracer (..), nullTracer)
import           Data.Singletons (Sing, SingI (..))
import qualified Debug.Trace as Debug
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Ledger.Extended
import qualified Ouroboros.Consensus.Ledger.SupportsMempool as LedgerSupportsMempool
                     (HasTxs)
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           Ouroboros.Consensus.Storage.ChainDB.Impl.Args
import           Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB (lgrHasFS)
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import           Ouroboros.Consensus.Storage.LedgerDB (DiskSnapshot (..),
                     readSnapshot)
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.Orphans ()
import           System.IO
import           Text.Printf (printf)


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

analyse ::
     forall blk .
     ( Node.RunNode blk
     , Show (Header blk)
     , HasAnalysis blk
     , HasProtocolInfo blk
     , LedgerSupportsMempool.HasTxs blk
     )
  => DBAnalyserConfig
  -> Args blk
  -> IO (Maybe AnalysisResult)
analyse :: forall blk.
(RunNode blk, Show (Header blk), HasAnalysis blk,
 HasProtocolInfo blk, HasTxs blk) =>
DBAnalyserConfig -> Args blk -> IO (Maybe AnalysisResult)
analyse DBAnalyserConfig{AnalysisName
analysis :: AnalysisName
analysis :: DBAnalyserConfig -> AnalysisName
analysis, Limit
confLimit :: Limit
confLimit :: DBAnalyserConfig -> Limit
confLimit, FilePath
dbDir :: FilePath
dbDir :: DBAnalyserConfig -> FilePath
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} 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
      StrictMVar IO ()
lock           <- () -> IO (StrictMVar IO ())
forall (m :: * -> *) a.
(HasCallStack, MonadMVar m, NoThunks a) =>
a -> m (StrictMVar m a)
newMVar ()
      Tracer IO (TraceEvent blk)
chainDBTracer  <- StrictMVar IO () -> Bool -> IO (Tracer IO (TraceEvent blk))
forall {m :: * -> *} {a}.
(MonadMonotonicTime m, Show a) =>
StrictMVar IO () -> Bool -> m (Tracer IO a)
mkTracer StrictMVar IO ()
lock Bool
verbose
      Tracer IO (TraceEvent blk)
analysisTracer <- StrictMVar IO () -> Bool -> IO (Tracer IO (TraceEvent blk))
forall {m :: * -> *} {a}.
(MonadMonotonicTime m, Show a) =>
StrictMVar IO () -> Bool -> m (Tracer IO a)
mkTracer StrictMVar IO ()
lock Bool
True
      ProtocolInfo { pInfoInitLedger :: forall b. ProtocolInfo b -> ExtLedgerState b
pInfoInitLedger = ExtLedgerState blk
genesisLedger, pInfoConfig :: forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig = TopLevelConfig blk
cfg } <-
        Args blk -> IO (ProtocolInfo blk)
forall blk.
HasProtocolInfo blk =>
Args blk -> IO (ProtocolInfo blk)
mkProtocolInfo Args blk
args
      let chunkInfo :: ChunkInfo
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)
          chainDbArgs :: ChainDbArgs Identity IO blk
chainDbArgs =
                ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
maybeValidateAll
              (ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk)
-> ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
forall a b. (a -> b) -> a -> b
$ Tracer IO (TraceEvent blk)
-> ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
forall (m :: * -> *) blk (f :: * -> *).
Tracer m (TraceEvent blk)
-> ChainDbArgs f m blk -> ChainDbArgs f m blk
updateTracer Tracer IO (TraceEvent blk)
chainDBTracer
              (ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk)
-> ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
forall a b. (a -> b) -> a -> b
$ ResourceRegistry IO
-> TopLevelConfig blk
-> ExtLedgerState blk
-> ChunkInfo
-> (blk -> Bool)
-> (RelativeMountPoint -> SomeHasFS IO)
-> (RelativeMountPoint -> SomeHasFS IO)
-> Incomplete ChainDbArgs IO blk
-> ChainDbArgs Identity IO blk
forall (m :: * -> *) blk.
(ConsensusProtocol (BlockProtocol blk), IOLike m) =>
ResourceRegistry m
-> TopLevelConfig blk
-> ExtLedgerState blk
-> ChunkInfo
-> (blk -> Bool)
-> (RelativeMountPoint -> SomeHasFS m)
-> (RelativeMountPoint -> SomeHasFS m)
-> Incomplete ChainDbArgs m blk
-> Complete ChainDbArgs m blk
completeChainDbArgs
                  ResourceRegistry IO
registry
                  TopLevelConfig blk
cfg
                  ExtLedgerState blk
genesisLedger
                  ChunkInfo
chunkInfo
                  (Bool -> blk -> Bool
forall a b. a -> b -> a
const Bool
True)
                  (FilePath -> RelativeMountPoint -> SomeHasFS IO
Node.stdMkChainDbHasFS FilePath
dbDir)
                  (FilePath -> RelativeMountPoint -> SomeHasFS IO
Node.stdMkChainDbHasFS FilePath
dbDir)
              (Incomplete ChainDbArgs IO blk -> ChainDbArgs Identity IO blk)
-> Incomplete ChainDbArgs IO blk -> ChainDbArgs Identity IO blk
forall a b. (a -> b) -> a -> b
$ Incomplete ChainDbArgs IO blk
forall (m :: * -> *) blk. Monad m => Incomplete ChainDbArgs m blk
defaultArgs
          immutableDbArgs :: ImmutableDbArgs Identity IO blk
immutableDbArgs = ChainDbArgs Identity IO blk -> ImmutableDbArgs Identity IO blk
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> ImmutableDbArgs f m blk
ChainDB.cdbImmDbArgs ChainDbArgs Identity IO blk
chainDbArgs
          ledgerDbFS :: HKD Identity (SomeHasFS IO)
ledgerDbFS = LgrDbArgs Identity IO blk -> HKD Identity (SomeHasFS IO)
forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> HKD f (SomeHasFS m)
lgrHasFS (LgrDbArgs Identity IO blk -> HKD Identity (SomeHasFS IO))
-> LgrDbArgs Identity IO blk -> HKD Identity (SomeHasFS IO)
forall a b. (a -> b) -> a -> b
$ ChainDbArgs Identity IO blk -> LgrDbArgs Identity IO blk
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> LgrDbArgs f m blk
ChainDB.cdbLgrDbArgs ChainDbArgs Identity IO blk
chainDbArgs

      ImmutableDbArgs Identity IO blk
-> ((ImmutableDB IO blk, Internal IO blk)
    -> IO (Maybe AnalysisResult))
-> IO (Maybe AnalysisResult)
forall {m :: * -> *} {blk} {c}.
(IOLike m, GetPrevHash blk, ConvertRawHash blk, EncodeDisk blk blk,
 DecodeDisk blk (ByteString -> blk),
 DecodeDiskDep (NestedCtxt Header) blk,
 ReconstructNestedCtxt Header blk, HasBinaryBlockInfo blk) =>
Complete ImmutableDbArgs m blk
-> ((ImmutableDB m blk, Internal m blk) -> m c) -> m c
withImmutableDB ImmutableDbArgs Identity IO blk
immutableDbArgs (((ImmutableDB IO blk, Internal IO blk)
  -> IO (Maybe AnalysisResult))
 -> IO (Maybe AnalysisResult))
-> ((ImmutableDB IO blk, Internal IO blk)
    -> IO (Maybe AnalysisResult))
-> IO (Maybe AnalysisResult)
forall a b. (a -> b) -> a -> b
$ \(ImmutableDB IO blk
immutableDB, Internal IO blk
internal) -> do
        SomeAnalysis (Proxy startFrom
Proxy :: Proxy startFrom) Analysis blk 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,
 LgrDbSerialiseConstraints blk) =>
AnalysisName -> SomeAnalysis blk
runAnalysis AnalysisName
analysis
        AnalysisStartFrom blk startFrom
startFrom <- case Sing startFrom
forall {k} (a :: k). SingI a => Sing a
sing :: Sing startFrom of
          Sing startFrom
SStartFrom startFrom
SStartFromPoint       -> Point blk -> AnalysisStartFrom blk startFrom
Point blk -> AnalysisStartFrom blk 'StartFromPoint
forall blk. Point blk -> AnalysisStartFrom blk 'StartFromPoint
FromPoint (Point blk -> AnalysisStartFrom blk startFrom)
-> IO (Point blk) -> IO (AnalysisStartFrom 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   -> FilePath -> IO (Point blk)
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO (Point blk)) -> FilePath -> IO (Point blk)
forall a b. (a -> b) -> a -> b
$ FilePath
"No block with given slot in the ImmutableDB: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> SlotNo -> FilePath
forall a. Show a => a -> FilePath
show SlotNo
slot
          Sing startFrom
SStartFrom startFrom
SStartFromLedgerState -> do
            -- TODO we need to check if the snapshot exists. If not, print an
            -- error and ask the user if she wanted to create a snapshot first and
            -- how to do it.
            Either ReadIncrementalErr (ExtLedgerState blk)
initLedgerErr <- ExceptT ReadIncrementalErr IO (ExtLedgerState blk)
-> IO (Either ReadIncrementalErr (ExtLedgerState blk))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ReadIncrementalErr IO (ExtLedgerState blk)
 -> IO (Either ReadIncrementalErr (ExtLedgerState blk)))
-> ExceptT ReadIncrementalErr IO (ExtLedgerState blk)
-> IO (Either ReadIncrementalErr (ExtLedgerState blk))
forall a b. (a -> b) -> a -> b
$ case WithOrigin SlotNo
startSlot of
              WithOrigin SlotNo
Origin                  -> ExtLedgerState blk
-> ExceptT ReadIncrementalErr IO (ExtLedgerState blk)
forall a. a -> ExceptT ReadIncrementalErr IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExtLedgerState blk
genesisLedger
              NotOrigin (SlotNo Word64
slot) -> SomeHasFS IO
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (HeaderHash blk))
-> DiskSnapshot
-> ExceptT ReadIncrementalErr IO (ExtLedgerState blk)
forall (m :: * -> *) blk.
IOLike m =>
SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (HeaderHash blk))
-> DiskSnapshot
-> ExceptT ReadIncrementalErr m (ExtLedgerState blk)
readSnapshot
                SomeHasFS IO
HKD Identity (SomeHasFS IO)
ledgerDbFS
                (CodecConfig blk -> forall s. Decoder s (ExtLedgerState blk)
forall blk.
(DecodeDisk blk (LedgerState blk),
 DecodeDisk blk (ChainDepState (BlockProtocol blk)),
 DecodeDisk blk (AnnTip blk)) =>
CodecConfig blk -> forall s. Decoder s (ExtLedgerState blk)
decodeDiskExtLedgerState (CodecConfig blk -> forall s. Decoder s (ExtLedgerState blk))
-> CodecConfig blk -> forall s. Decoder s (ExtLedgerState blk)
forall a b. (a -> b) -> a -> b
$ TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec TopLevelConfig blk
cfg)
                Decoder s (HeaderHash blk)
forall s. Decoder s (HeaderHash blk)
forall a s. Serialise a => Decoder s a
decode
                (Word64 -> Maybe FilePath -> DiskSnapshot
DiskSnapshot Word64
slot (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"db-analyser"))
                -- TODO @readSnapshot@ has type @ExceptT ReadIncrementalErr m
                -- (ExtLedgerState blk)@ but it also throws exceptions! This makes
                -- error handling more challenging than it ought to be. Maybe we
                -- can enrich the error that @readSnapthot@ return, so that it can
                -- contain the @HasFS@ errors as well.
            ExtLedgerState blk
initLedger <- (ReadIncrementalErr -> IO (ExtLedgerState blk))
-> (ExtLedgerState blk -> IO (ExtLedgerState blk))
-> Either ReadIncrementalErr (ExtLedgerState blk)
-> IO (ExtLedgerState blk)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> IO (ExtLedgerState blk)
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO (ExtLedgerState blk))
-> (ReadIncrementalErr -> FilePath)
-> ReadIncrementalErr
-> IO (ExtLedgerState blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadIncrementalErr -> FilePath
forall a. Show a => a -> FilePath
show) ExtLedgerState blk -> IO (ExtLedgerState blk)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ReadIncrementalErr (ExtLedgerState blk)
initLedgerErr
            -- 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.
            FilePath -> IO ()
Debug.traceMarkerIO FilePath
"SNAPSHOT_LOADED"
            AnalysisStartFrom blk startFrom
-> IO (AnalysisStartFrom blk startFrom)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnalysisStartFrom blk startFrom
 -> IO (AnalysisStartFrom blk startFrom))
-> AnalysisStartFrom blk startFrom
-> IO (AnalysisStartFrom blk startFrom)
forall a b. (a -> b) -> a -> b
$ ExtLedgerState blk -> AnalysisStartFrom blk 'StartFromLedgerState
forall blk.
ExtLedgerState blk -> AnalysisStartFrom blk 'StartFromLedgerState
FromLedgerState ExtLedgerState blk
initLedger

        Maybe AnalysisResult
result <- Analysis blk startFrom
ana AnalysisEnv {
            TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg
          , AnalysisStartFrom blk startFrom
startFrom :: AnalysisStartFrom blk startFrom
startFrom :: AnalysisStartFrom blk startFrom
startFrom
          , db :: ImmutableDB IO blk
db = ImmutableDB IO blk
immutableDB
          , ResourceRegistry IO
registry :: ResourceRegistry IO
registry :: ResourceRegistry IO
registry
          , ledgerDbFS :: SomeHasFS IO
ledgerDbFS = SomeHasFS IO
HKD Identity (SomeHasFS IO)
ledgerDbFS
          , limit :: Limit
limit = Limit
confLimit
          , tracer :: Tracer IO (TraceEvent blk)
tracer = Tracer IO (TraceEvent blk)
analysisTracer
          }
        Point blk
tipPoint <- STM IO (Point blk) -> IO (Point blk)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (Point blk) -> IO (Point blk))
-> STM IO (Point blk) -> IO (Point blk)
forall a b. (a -> b) -> a -> b
$ ImmutableDB IO blk -> STM IO (Point blk)
forall (m :: * -> *) blk.
(MonadSTM m, HasCallStack) =>
ImmutableDB m blk -> STM m (Point blk)
ImmutableDB.getTipPoint ImmutableDB IO blk
immutableDB
        FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"ImmutableDB tip: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Point blk -> FilePath
forall a. Show a => a -> FilePath
show Point blk
tipPoint
        Maybe AnalysisResult -> IO (Maybe AnalysisResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AnalysisResult
result
  where
    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
      Time
startTime <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
      Tracer IO a -> m (Tracer IO a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tracer IO a -> m (Tracer IO a)) -> Tracer IO a -> m (Tracer IO a)
forall a b. (a -> b) -> a -> b
$ (a -> IO ()) -> Tracer IO a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((a -> IO ()) -> Tracer IO a) -> (a -> IO ()) -> Tracer IO a
forall a b. (a -> b) -> a -> b
$ \a
ev -> IO () -> IO ()
withLock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Time
traceTime <- IO Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
        let diff :: DiffTime
diff = Time -> Time -> DiffTime
diffTime Time
traceTime Time
startTime
        Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Double -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"[%.6fs] %s" (DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
diff :: Double) (a -> FilePath
forall a. Show a => a -> FilePath
show a
ev)
        Handle -> IO ()
hFlush Handle
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 :: ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
maybeValidateAll = case (AnalysisName
analysis, Maybe ValidateBlocks
validation) of
      (AnalysisName
_, Just ValidateBlocks
ValidateAllBlocks)      -> ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> ChainDbArgs f m blk
ensureValidateAll
      (AnalysisName
_, Just ValidateBlocks
MinimumBlockValidation) -> ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
forall a. a -> a
id
      (AnalysisName
OnlyValidation, Maybe ValidateBlocks
_ )             -> ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> ChainDbArgs f m blk
ensureValidateAll
      (AnalysisName, Maybe ValidateBlocks)
_                                -> ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
forall a. a -> a
id