{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | The Ledger DB is responsible for the following tasks:
--
-- - __Maintaining the in-memory ledger state at the tip__: When we try to
--     extend our chain with a new block fitting onto our tip, the block must
--     first be validated using the right ledger state, i.e., the ledger state
--     corresponding to the tip.
--
-- - __Maintaining the past \(k\) in-memory ledger states__: we might roll back
--     up to \(k\) blocks when switching to a more preferable fork. Consider the
--     example below:
--
--     <<docs/haddocks/ledgerdb-switch.svg>>
--
--     Our current chain's tip is \(C_2\), but the fork containing blocks
--      \(F_1\), \(F_2\), and \(F_3\) is more preferable. We roll back our chain
--     to the intersection point of the two chains, \(I\), which must be not
--     more than \(k\) blocks back from our current tip. Next, we must validate
--     block \(F_1\) using the ledger state at block \(I\), after which we can
--     validate \(F_2\) using the resulting ledger state, and so on.
--
--     This means that we need access to all ledger states of the past \(k\)
--     blocks, i.e., the ledger states corresponding to the volatile part of the
--     current chain. Note that applying a block to a ledger state is not an
--     invertible operation, so it is not possible to simply /unapply/ \(C_1\)
--     and \(C_2\) to obtain \(I\).
--
--     Access to the last \(k\) ledger states is not only needed for validating
--     candidate chains, but also by the:
--
--     - __Local state query server__: To query any of the past \(k\) ledger
--       states.
--
--     - __Chain sync client__: To validate headers of a chain that intersects
--        with any of the past \(k\) blocks.
--
-- - __Providing 'Ouroboros.Consensus.Ledger.Tables.Basics.LedgerTable's at any of the last \(k\) ledger states__: To apply blocks or transactions on top
--     of ledger states, the LedgerDB must be able to provide the appropriate
--     ledger tables at any of those ledger states.
--
-- - __Storing snapshots on disk__: To obtain a ledger state for the current tip
--     of the chain, one has to apply /all blocks in the chain/ one-by-one to
--     the initial ledger state. When starting up the system with an on-disk
--     chain containing millions of blocks, all of them would have to be read
--     from disk and applied. This process can take hours, depending on the
--     storage and CPU speed, and is thus too costly to perform on each startup.
--
--     For this reason, a recent snapshot of the ledger state should be
--     periodically written to disk. Upon the next startup, that snapshot can be
--     read and used to restore the current ledger state, as well as the past
--      \(k\) ledger states.
--
-- - __Flushing 'LedgerTable' differences__: The running Consensus has to
--     periodically flush chunks of [differences]("Data.Map.Diff.Strict")
--     from the 'DbChangelog' to the 'BackingStore', so that memory is
--     off-loaded to the backing store, and if the backing store is an on-disk
--     implementation, reduce the memory usage.
--
-- Note that whenever we say /ledger state/ we mean the @'ExtLedgerState' blk
-- mk@ type described in "Ouroboros.Consensus.Ledger.Basics".
--
-- === __(image code)__
-- >>> import Image.LaTeX.Render
-- >>> import Control.Monad
-- >>> import System.Directory
-- >>>
-- >>> createDirectoryIfMissing True "docs/haddocks/"
-- >>> :{
-- >>> either (error . show) pure =<<
-- >>>  renderToFile "docs/haddocks/ledgerdb-switch.svg" defaultEnv (tikz ["positioning", "arrows"]) "\
-- >>> \ \\draw (0, 0) -- (50pt, 0) coordinate (I);\
-- >>> \  \\draw (I) -- ++(20pt,  20pt) coordinate (C1) -- ++(20pt, 0) coordinate (C2);\
-- >>> \  \\draw (I) -- ++(20pt, -20pt) coordinate (F1) -- ++(20pt, 0) coordinate (F2) -- ++(20pt, 0) coordinate (F3);\
-- >>> \  \\node at (I)  {$\\bullet$};\
-- >>> \  \\node at (C1) {$\\bullet$};\
-- >>> \  \\node at (C2) {$\\bullet$};\
-- >>> \  \\node at (F1) {$\\bullet$};\
-- >>> \  \\node at (F2) {$\\bullet$};\
-- >>> \  \\node at (F3) {$\\bullet$};\
-- >>> \  \\node at (I) [above left] {$I$};\
-- >>> \  \\node at (C1) [above] {$C_1$};\
-- >>> \  \\node at (C2) [above] {$C_2$};\
-- >>> \  \\node at (F1) [below] {$F_1$};\
-- >>> \  \\node at (F2) [below] {$F_2$};\
-- >>> \  \\node at (F3) [below] {$F_3$};\
-- >>> \  \\draw (60pt, 50pt) node {$\\overbrace{\\hspace{60pt}}$};\
-- >>> \  \\draw (60pt, 60pt) node[fill=white] {$k$};\
-- >>> \  \\draw [dashed] (30pt, -40pt) -- (30pt, 45pt);"
-- >>> :}
--
module Ouroboros.Consensus.Storage.LedgerDB.API (
    -- * Main API
    CanUpgradeLedgerTables (..)
  , LedgerDB (..)
  , LedgerDB'
  , LedgerDbPrune (..)
  , LedgerDbSerialiseConstraints
  , LedgerSupportsInMemoryLedgerDB
  , LedgerSupportsLedgerDB
  , LedgerSupportsOnDiskLedgerDB
  , ResolveBlock
  , currentPoint
    -- * Initialization
  , InitDB (..)
  , InitLog (..)
  , initialize
    -- ** Tracing
  , ReplayGoal (..)
  , ReplayStart (..)
  , TraceReplayEvent (..)
  , TraceReplayProgressEvent (..)
  , TraceReplayStartEvent (..)
  , decorateReplayTracerWithGoal
  , decorateReplayTracerWithStart
    -- * Configuration
  , LedgerDbCfg
  , LedgerDbCfgF (..)
  , configLedgerDb
    -- * Exceptions
  , LedgerDbError (..)
    -- * Forker
  , getReadOnlyForker
  , getTipStatistics
  , readLedgerTablesAtFor
  , withPrivateTipForker
  , withTipForker
    -- * Snapshots
  , SnapCounters (..)
    -- * Testing
  , TestInternals (..)
  , TestInternals'
  , WhereToTakeSnapshot (..)
  ) where

import           Codec.Serialise
import qualified Control.Monad as Monad
import           Control.Monad.Class.MonadTime.SI
import           Control.Monad.Except
import           Control.ResourceRegistry
import           Control.Tracer
import           Data.Functor.Contravariant ((>$<))
import           Data.Kind
import qualified Data.Map.Strict as Map
import           Data.MemPack
import           Data.Set (Set)
import           Data.Void (absurd)
import           Data.Word
import           GHC.Generics (Generic)
import           NoThunks.Class
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.HeaderStateHistory
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.Inspect
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache
import           Ouroboros.Consensus.Storage.ImmutableDB.Stream
import           Ouroboros.Consensus.Storage.LedgerDB.Forker
import           Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import           Ouroboros.Consensus.Storage.Serialisation
import           Ouroboros.Consensus.Util.Args
import           Ouroboros.Consensus.Util.CallStack
import           Ouroboros.Consensus.Util.IndexedMemPack
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Network.Block
import           Ouroboros.Network.Protocol.LocalStateQuery.Type
import           System.FS.API

{-------------------------------------------------------------------------------
  Main API
-------------------------------------------------------------------------------}

-- | Serialization constraints required by the 'LedgerDB' to be properly
-- instantiated with a @blk@.
type LedgerDbSerialiseConstraints blk =
  ( Serialise      (HeaderHash  blk)
  , EncodeDisk blk (LedgerState blk EmptyMK)
  , DecodeDisk blk (LedgerState blk EmptyMK)
  , EncodeDisk blk (AnnTip      blk)
  , DecodeDisk blk (AnnTip      blk)
  , EncodeDisk blk (ChainDepState (BlockProtocol blk))
  , DecodeDisk blk (ChainDepState (BlockProtocol blk))
    -- For InMemory LedgerDBs
  , MemPack (TxIn (LedgerState blk))
  , SerializeTablesWithHint (LedgerState blk)
    -- For OnDisk LedgerDBs
  , IndexedMemPack (LedgerState blk EmptyMK) (TxOut (LedgerState blk))
  )

-- | The core API of the LedgerDB component
type LedgerDB :: (Type -> Type) -> LedgerStateKind -> Type -> Type
data LedgerDB m l blk = LedgerDB {
    -- | Get the empty ledger state at the (volatile) tip of the LedgerDB.
    forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk -> STM m (l EmptyMK)
getVolatileTip         ::              STM m (l EmptyMK)

    -- | Get the empty ledger state at the immutable tip of the LedgerDB.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk -> STM m (l EmptyMK)
getImmutableTip        ::              STM m (l EmptyMK)

    -- | Get an empty ledger state at a requested point in the LedgerDB, if it
    -- exists.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk -> Point blk -> STM m (Maybe (l EmptyMK))
getPastLedgerState     :: Point blk -> STM m (Maybe (l EmptyMK))

    -- | Get the header state history for all ledger states in the LedgerDB.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk
-> (l ~ ExtLedgerState blk) => STM m (HeaderStateHistory blk)
getHeaderStateHistory  ::
         (l ~ ExtLedgerState blk)
      => STM m (HeaderStateHistory blk)

    -- | Acquire a 'Forker' at the requested point. If a ledger state associated
    -- with the requested point does not exist in the LedgerDB, it will return a
    -- 'GetForkerError'.
    --
    -- We pass in the producer/consumer registry.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
getForkerAtTarget  ::
         ResourceRegistry m
      -> Target (Point blk)
      -> m (Either GetForkerError (Forker m l blk))

    -- | Try to apply a sequence of blocks on top of the LedgerDB, first rolling
    -- back as many blocks as the passed @Word64@.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk
-> (l ~ ExtLedgerState blk) =>
   ResourceRegistry m
   -> (TraceValidateEvent blk -> m ())
   -> BlockCache blk
   -> Word64
   -> [Header blk]
   -> m (ValidateResult m l blk)
validateFork ::
         (l ~ ExtLedgerState blk)
      => ResourceRegistry m
      -> (TraceValidateEvent blk -> m ())
      -> BlockCache blk
      -> Word64
      -> [Header blk]
      -> m (ValidateResult m l blk)

    -- | Get the references to blocks that have previously been applied.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk -> STM m (Set (RealPoint blk))
getPrevApplied :: STM m (Set (RealPoint blk))

    -- | Garbage collect references to old blocks that have been previously
    -- applied and committed.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk -> SlotNo -> STM m ()
garbageCollect :: SlotNo -> STM m ()

    -- | If the provided arguments indicate so (based on the SnapshotPolicy with
    -- which this LedgerDB was opened), take a snapshot and delete stale ones.
    --
    -- The arguments are:
    --
    -- - If a snapshot has been taken already, the time at which it was taken
    --   and the current time.
    --
    -- - How many blocks have been processed since the last snapshot.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk
-> (l ~ ExtLedgerState blk) =>
   Maybe (Time, Time) -> Word64 -> m SnapCounters
tryTakeSnapshot ::
         (l ~ ExtLedgerState blk)
      => Maybe (Time, Time)
      -> Word64
      -> m SnapCounters

    -- | Flush V1 in-memory LedgerDB state to disk, if possible. This is a no-op
    -- for implementations that do not need an explicit flush function.
    --
    -- Note that this is rate-limited by 'ldbShouldFlush'.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk -> m ()
tryFlush :: m ()

      -- | Close the LedgerDB
      --
      -- Idempotent.
      --
      -- Should only be called on shutdown.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk -> m ()
closeDB :: m ()
  }
  deriving Context -> LedgerDB m l blk -> IO (Maybe ThunkInfo)
Proxy (LedgerDB m l blk) -> String
(Context -> LedgerDB m l blk -> IO (Maybe ThunkInfo))
-> (Context -> LedgerDB m l blk -> IO (Maybe ThunkInfo))
-> (Proxy (LedgerDB m l blk) -> String)
-> NoThunks (LedgerDB m l blk)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Context -> LedgerDB m l blk -> IO (Maybe ThunkInfo)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Proxy (LedgerDB m l blk) -> String
$cnoThunks :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
Context -> LedgerDB m l blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> LedgerDB m l blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
Context -> LedgerDB m l blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> LedgerDB m l blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
Proxy (LedgerDB m l blk) -> String
showTypeOf :: Proxy (LedgerDB m l blk) -> String
NoThunks via OnlyCheckWhnfNamed "LedgerDB" (LedgerDB m l blk)

type instance HeaderHash (LedgerDB m l blk) = HeaderHash blk

type LedgerDB' m blk = LedgerDB m (ExtLedgerState blk) blk

currentPoint ::
     (GetTip l, HeaderHash l ~ HeaderHash blk, Functor (STM m))
  => LedgerDB m l blk
  -> STM m (Point blk)
currentPoint :: forall (l :: LedgerStateKind) blk (m :: * -> *).
(GetTip l, HeaderHash l ~ HeaderHash blk, Functor (STM m)) =>
LedgerDB m l blk -> STM m (Point blk)
currentPoint LedgerDB m l blk
ldb = Point l -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point l -> Point blk)
-> (l EmptyMK -> Point l) -> l EmptyMK -> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l EmptyMK -> Point l
forall (mk :: MapKind). l mk -> Point l
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip (l EmptyMK -> Point blk) -> STM m (l EmptyMK) -> STM m (Point blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerDB m l blk -> STM m (l EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk -> STM m (l EmptyMK)
getVolatileTip LedgerDB m l blk
ldb

data WhereToTakeSnapshot = TakeAtImmutableTip | TakeAtVolatileTip deriving WhereToTakeSnapshot -> WhereToTakeSnapshot -> Bool
(WhereToTakeSnapshot -> WhereToTakeSnapshot -> Bool)
-> (WhereToTakeSnapshot -> WhereToTakeSnapshot -> Bool)
-> Eq WhereToTakeSnapshot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WhereToTakeSnapshot -> WhereToTakeSnapshot -> Bool
== :: WhereToTakeSnapshot -> WhereToTakeSnapshot -> Bool
$c/= :: WhereToTakeSnapshot -> WhereToTakeSnapshot -> Bool
/= :: WhereToTakeSnapshot -> WhereToTakeSnapshot -> Bool
Eq

data TestInternals m l blk = TestInternals {
    forall {k} (m :: * -> *) (l :: k) blk.
TestInternals m l blk -> m ()
wipeLedgerDB       :: m ()
  , forall {k} (m :: * -> *) (l :: k) blk.
TestInternals m l blk
-> WhereToTakeSnapshot -> Maybe String -> m ()
takeSnapshotNOW    :: WhereToTakeSnapshot -> Maybe String -> m ()
  , forall {k} (m :: * -> *) (l :: k) blk.
TestInternals m l blk -> ExtLedgerState blk DiffMK -> m ()
push               :: ExtLedgerState blk DiffMK -> m ()
  , forall {k} (m :: * -> *) (l :: k) blk.
TestInternals m l blk -> blk -> m ()
reapplyThenPushNOW :: blk -> m ()
  , forall {k} (m :: * -> *) (l :: k) blk.
TestInternals m l blk -> m ()
truncateSnapshots  :: m ()
  , forall {k} (m :: * -> *) (l :: k) blk.
TestInternals m l blk -> m ()
closeLedgerDB      :: m ()
  }
  deriving Context -> TestInternals m l blk -> IO (Maybe ThunkInfo)
Proxy (TestInternals m l blk) -> String
(Context -> TestInternals m l blk -> IO (Maybe ThunkInfo))
-> (Context -> TestInternals m l blk -> IO (Maybe ThunkInfo))
-> (Proxy (TestInternals m l blk) -> String)
-> NoThunks (TestInternals m l blk)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) k (l :: k) blk.
Context -> TestInternals m l blk -> IO (Maybe ThunkInfo)
forall (m :: * -> *) k (l :: k) blk.
Proxy (TestInternals m l blk) -> String
$cnoThunks :: forall (m :: * -> *) k (l :: k) blk.
Context -> TestInternals m l blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> TestInternals m l blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) k (l :: k) blk.
Context -> TestInternals m l blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TestInternals m l blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *) k (l :: k) blk.
Proxy (TestInternals m l blk) -> String
showTypeOf :: Proxy (TestInternals m l blk) -> String
NoThunks via OnlyCheckWhnfNamed "TestInternals" (TestInternals m l blk)

type TestInternals' m blk = TestInternals m (ExtLedgerState blk) blk

{-------------------------------------------------------------------------------
  Config
-------------------------------------------------------------------------------}

data LedgerDbCfgF f l = LedgerDbCfg {
      forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f SecurityParam
ledgerDbCfgSecParam            :: !(HKD f SecurityParam)
    , forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
ledgerDbCfg                    :: !(HKD f (LedgerCfg l))
    , forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> ComputeLedgerEvents
ledgerDbCfgComputeLedgerEvents :: !ComputeLedgerEvents
    }
  deriving ((forall x. LedgerDbCfgF f l -> Rep (LedgerDbCfgF f l) x)
-> (forall x. Rep (LedgerDbCfgF f l) x -> LedgerDbCfgF f l)
-> Generic (LedgerDbCfgF f l)
forall x. Rep (LedgerDbCfgF f l) x -> LedgerDbCfgF f l
forall x. LedgerDbCfgF f l -> Rep (LedgerDbCfgF f l) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) (l :: LedgerStateKind) x.
Rep (LedgerDbCfgF f l) x -> LedgerDbCfgF f l
forall (f :: * -> *) (l :: LedgerStateKind) x.
LedgerDbCfgF f l -> Rep (LedgerDbCfgF f l) x
$cfrom :: forall (f :: * -> *) (l :: LedgerStateKind) x.
LedgerDbCfgF f l -> Rep (LedgerDbCfgF f l) x
from :: forall x. LedgerDbCfgF f l -> Rep (LedgerDbCfgF f l) x
$cto :: forall (f :: * -> *) (l :: LedgerStateKind) x.
Rep (LedgerDbCfgF f l) x -> LedgerDbCfgF f l
to :: forall x. Rep (LedgerDbCfgF f l) x -> LedgerDbCfgF f l
Generic)

type LedgerDbCfg l = Complete LedgerDbCfgF l

deriving instance NoThunks (LedgerCfg l) => NoThunks (LedgerDbCfg l)

configLedgerDb ::
     ConsensusProtocol (BlockProtocol blk)
  => TopLevelConfig blk
  -> ComputeLedgerEvents
  -> LedgerDbCfg (ExtLedgerState blk)
configLedgerDb :: forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk
-> ComputeLedgerEvents -> LedgerDbCfg (ExtLedgerState blk)
configLedgerDb TopLevelConfig blk
config ComputeLedgerEvents
evs = LedgerDbCfg {
      ledgerDbCfgSecParam :: HKD Identity SecurityParam
ledgerDbCfgSecParam            = TopLevelConfig blk -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig blk
config
    , ledgerDbCfg :: HKD Identity (LedgerCfg (ExtLedgerState blk))
ledgerDbCfg                    = TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
config
    , ledgerDbCfgComputeLedgerEvents :: ComputeLedgerEvents
ledgerDbCfgComputeLedgerEvents = ComputeLedgerEvents
evs
    }

{-------------------------------------------------------------------------------
  Exceptions
-------------------------------------------------------------------------------}

-- | Database error
--
-- Thrown upon incorrect use: invalid input.
data LedgerDbError blk =
      -- | The LedgerDB is closed.
      --
      -- This will be thrown when performing some operations on the LedgerDB. The
      -- 'CallStack' of the operation on the LedgerDB is included in the error.
      ClosedDBError PrettyCallStack
      -- | A Forker is closed.
    | ClosedForkerError ForkerKey PrettyCallStack
    deriving (Int -> LedgerDbError blk -> ShowS
[LedgerDbError blk] -> ShowS
LedgerDbError blk -> String
(Int -> LedgerDbError blk -> ShowS)
-> (LedgerDbError blk -> String)
-> ([LedgerDbError blk] -> ShowS)
-> Show (LedgerDbError blk)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (blk :: k). Int -> LedgerDbError blk -> ShowS
forall k (blk :: k). [LedgerDbError blk] -> ShowS
forall k (blk :: k). LedgerDbError blk -> String
$cshowsPrec :: forall k (blk :: k). Int -> LedgerDbError blk -> ShowS
showsPrec :: Int -> LedgerDbError blk -> ShowS
$cshow :: forall k (blk :: k). LedgerDbError blk -> String
show :: LedgerDbError blk -> String
$cshowList :: forall k (blk :: k). [LedgerDbError blk] -> ShowS
showList :: [LedgerDbError blk] -> ShowS
Show)
    deriving anyclass (Show (LedgerDbError blk)
Typeable (LedgerDbError blk)
(Typeable (LedgerDbError blk), Show (LedgerDbError blk)) =>
(LedgerDbError blk -> SomeException)
-> (SomeException -> Maybe (LedgerDbError blk))
-> (LedgerDbError blk -> String)
-> (LedgerDbError blk -> Bool)
-> Exception (LedgerDbError blk)
SomeException -> Maybe (LedgerDbError blk)
LedgerDbError blk -> Bool
LedgerDbError blk -> String
LedgerDbError blk -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
forall k (blk :: k).
(Typeable blk, Typeable k) =>
Show (LedgerDbError blk)
forall k (blk :: k).
(Typeable blk, Typeable k) =>
Typeable (LedgerDbError blk)
forall k (blk :: k).
(Typeable blk, Typeable k) =>
SomeException -> Maybe (LedgerDbError blk)
forall k (blk :: k).
(Typeable blk, Typeable k) =>
LedgerDbError blk -> Bool
forall k (blk :: k).
(Typeable blk, Typeable k) =>
LedgerDbError blk -> String
forall k (blk :: k).
(Typeable blk, Typeable k) =>
LedgerDbError blk -> SomeException
$ctoException :: forall k (blk :: k).
(Typeable blk, Typeable k) =>
LedgerDbError blk -> SomeException
toException :: LedgerDbError blk -> SomeException
$cfromException :: forall k (blk :: k).
(Typeable blk, Typeable k) =>
SomeException -> Maybe (LedgerDbError blk)
fromException :: SomeException -> Maybe (LedgerDbError blk)
$cdisplayException :: forall k (blk :: k).
(Typeable blk, Typeable k) =>
LedgerDbError blk -> String
displayException :: LedgerDbError blk -> String
$cbacktraceDesired :: forall k (blk :: k).
(Typeable blk, Typeable k) =>
LedgerDbError blk -> Bool
backtraceDesired :: LedgerDbError blk -> Bool
Exception)

{-------------------------------------------------------------------------------
  Forker
-------------------------------------------------------------------------------}

-- | 'bracket'-style usage of a forker at the LedgerDB tip.
withTipForker ::
     IOLike m
  => LedgerDB m l blk
  -> ResourceRegistry m
  -> (Forker m l blk -> m a)
  -> m a
withTipForker :: forall (m :: * -> *) (l :: LedgerStateKind) blk a.
IOLike m =>
LedgerDB m l blk
-> ResourceRegistry m -> (Forker m l blk -> m a) -> m a
withTipForker LedgerDB m l blk
ldb ResourceRegistry m
rr =
  m (Forker m l blk)
-> (Forker m l blk -> m ()) -> (Forker m l blk -> m a) -> m a
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
    (do
        eFrk <- LedgerDB m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
getForkerAtTarget LedgerDB m l blk
ldb ResourceRegistry m
rr Target (Point blk)
forall point. Target point
VolatileTip
        case eFrk of
          Left {}   -> String -> m (Forker m l blk)
forall a. HasCallStack => String -> a
error String
"Unreachable, volatile tip MUST be in the LedgerDB"
          Right Forker m l blk
frk -> Forker m l blk -> m (Forker m l blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Forker m l blk
frk
    )
    Forker m l blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> m ()
forkerClose

-- | Like 'withTipForker', but it uses a private registry to allocate and
-- de-allocate the forker.
withPrivateTipForker ::
     IOLike m
  => LedgerDB m l blk
  -> (Forker m l blk -> m a) -> m a
withPrivateTipForker :: forall (m :: * -> *) (l :: LedgerStateKind) blk a.
IOLike m =>
LedgerDB m l blk -> (Forker m l blk -> m a) -> m a
withPrivateTipForker LedgerDB m l blk
ldb =
  (ResourceRegistry m -> m (Forker m l blk))
-> (Forker m l blk -> m ()) -> (Forker m l blk -> m a) -> m a
forall (m :: * -> *) a r.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> (a -> m ()) -> (a -> m r) -> m r
bracketWithPrivateRegistry
    (\ResourceRegistry m
rr -> do
        eFrk <- LedgerDB m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
getForkerAtTarget LedgerDB m l blk
ldb ResourceRegistry m
rr Target (Point blk)
forall point. Target point
VolatileTip
        case eFrk of
          Left {}   -> String -> m (Forker m l blk)
forall a. HasCallStack => String -> a
error String
"Unreachable, volatile tip MUST be in the LedgerDB"
          Right Forker m l blk
frk -> Forker m l blk -> m (Forker m l blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Forker m l blk
frk
    )
    Forker m l blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> m ()
forkerClose

-- | Get statistics from the tip of the LedgerDB.
getTipStatistics ::
     IOLike m
  => LedgerDB m l blk
  -> m (Maybe Statistics)
getTipStatistics :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDB m l blk -> m (Maybe Statistics)
getTipStatistics LedgerDB m l blk
ldb = LedgerDB m l blk
-> (Forker m l blk -> m (Maybe Statistics)) -> m (Maybe Statistics)
forall (m :: * -> *) (l :: LedgerStateKind) blk a.
IOLike m =>
LedgerDB m l blk -> (Forker m l blk -> m a) -> m a
withPrivateTipForker LedgerDB m l blk
ldb Forker m l blk -> m (Maybe Statistics)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> m (Maybe Statistics)
forkerReadStatistics

getReadOnlyForker ::
     MonadSTM m
  => LedgerDB m l blk
  -> ResourceRegistry m
  -> Target (Point blk)
  -> m (Either GetForkerError (ReadOnlyForker m l blk))
getReadOnlyForker :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
MonadSTM m =>
LedgerDB m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (ReadOnlyForker m l blk))
getReadOnlyForker LedgerDB m l blk
ldb ResourceRegistry m
rr Target (Point blk)
pt = (Forker m l blk -> ReadOnlyForker m l blk)
-> Either GetForkerError (Forker m l blk)
-> Either GetForkerError (ReadOnlyForker m l blk)
forall a b.
(a -> b) -> Either GetForkerError a -> Either GetForkerError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Forker m l blk -> ReadOnlyForker m l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> ReadOnlyForker m l blk
readOnlyForker (Either GetForkerError (Forker m l blk)
 -> Either GetForkerError (ReadOnlyForker m l blk))
-> m (Either GetForkerError (Forker m l blk))
-> m (Either GetForkerError (ReadOnlyForker m l blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerDB m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
getForkerAtTarget LedgerDB m l blk
ldb ResourceRegistry m
rr Target (Point blk)
pt

-- | Read a table of values at the requested point via a 'ReadOnlyForker'
readLedgerTablesAtFor ::
     IOLike m
  => LedgerDB m l blk
  -> Point blk
  -> LedgerTables l KeysMK
  -> m (Either GetForkerError (LedgerTables l ValuesMK))
readLedgerTablesAtFor :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDB m l blk
-> Point blk
-> LedgerTables l KeysMK
-> m (Either GetForkerError (LedgerTables l ValuesMK))
readLedgerTablesAtFor LedgerDB m l blk
ldb Point blk
p LedgerTables l KeysMK
ks =
    (ResourceRegistry m
 -> m (Either GetForkerError (ReadOnlyForker m l blk)))
-> (Either GetForkerError (ReadOnlyForker m l blk) -> m ())
-> (Either GetForkerError (ReadOnlyForker m l blk)
    -> m (Either GetForkerError (LedgerTables l ValuesMK)))
-> m (Either GetForkerError (LedgerTables l ValuesMK))
forall (m :: * -> *) a r.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> (a -> m ()) -> (a -> m r) -> m r
bracketWithPrivateRegistry
      (\ResourceRegistry m
rr -> (Forker m l blk -> ReadOnlyForker m l blk)
-> Either GetForkerError (Forker m l blk)
-> Either GetForkerError (ReadOnlyForker m l blk)
forall a b.
(a -> b) -> Either GetForkerError a -> Either GetForkerError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Forker m l blk -> ReadOnlyForker m l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> ReadOnlyForker m l blk
readOnlyForker (Either GetForkerError (Forker m l blk)
 -> Either GetForkerError (ReadOnlyForker m l blk))
-> m (Either GetForkerError (Forker m l blk))
-> m (Either GetForkerError (ReadOnlyForker m l blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerDB m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDB m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
getForkerAtTarget LedgerDB m l blk
ldb ResourceRegistry m
rr (Point blk -> Target (Point blk)
forall point. point -> Target point
SpecificPoint Point blk
p))
      ((ReadOnlyForker m l blk -> m ())
-> Either GetForkerError (ReadOnlyForker m l blk) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ReadOnlyForker m l blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> m ()
roforkerClose)
      ((Either GetForkerError (ReadOnlyForker m l blk)
  -> m (Either GetForkerError (LedgerTables l ValuesMK)))
 -> m (Either GetForkerError (LedgerTables l ValuesMK)))
-> (Either GetForkerError (ReadOnlyForker m l blk)
    -> m (Either GetForkerError (LedgerTables l ValuesMK)))
-> m (Either GetForkerError (LedgerTables l ValuesMK))
forall a b. (a -> b) -> a -> b
$ \Either GetForkerError (ReadOnlyForker m l blk)
foEith -> Either GetForkerError (ReadOnlyForker m l blk)
-> (ReadOnlyForker m l blk -> m (LedgerTables l ValuesMK))
-> m (Either GetForkerError (LedgerTables l ValuesMK))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
Monad.forM Either GetForkerError (ReadOnlyForker m l blk)
foEith (ReadOnlyForker m l blk
-> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk
-> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
`roforkerReadTables` LedgerTables l KeysMK
ks)

{-------------------------------------------------------------------------------
  Snapshots
-------------------------------------------------------------------------------}

-- | Counters to keep track of when we made the last snapshot.
data SnapCounters = SnapCounters {
    -- | When was the last time we made a snapshot
    SnapCounters -> Maybe Time
prevSnapshotTime      :: !(Maybe Time)
    -- | How many blocks have we processed since the last snapshot
  , SnapCounters -> Word64
ntBlocksSinceLastSnap :: !Word64
  }

{-------------------------------------------------------------------------------
  Initialization
-------------------------------------------------------------------------------}

-- | Initialization log
--
-- The initialization log records which snapshots from disk were considered,
-- in which order, and why some snapshots were rejected. It is primarily useful
-- for monitoring purposes.
data InitLog blk =
    -- | Defaulted to initialization from genesis
    --
    -- NOTE: Unless the blockchain is near genesis, or this is the first time we
    -- boot the node, we should see this /only/ if data corruption occurred.
    InitFromGenesis

    -- | Used a snapshot corresponding to the specified tip
  | InitFromSnapshot DiskSnapshot (RealPoint blk)

    -- | Initialization skipped a snapshot
    --
    -- We record the reason why it was skipped.
    --
    -- NOTE: We should /only/ see this if data corruption occurred or codecs
    -- for snapshots changed.
  | InitFailure DiskSnapshot (SnapshotFailure blk) (InitLog blk)
  deriving (Int -> InitLog blk -> ShowS
[InitLog blk] -> ShowS
InitLog blk -> String
(Int -> InitLog blk -> ShowS)
-> (InitLog blk -> String)
-> ([InitLog blk] -> ShowS)
-> Show (InitLog blk)
forall blk. StandardHash blk => Int -> InitLog blk -> ShowS
forall blk. StandardHash blk => [InitLog blk] -> ShowS
forall blk. StandardHash blk => InitLog blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. StandardHash blk => Int -> InitLog blk -> ShowS
showsPrec :: Int -> InitLog blk -> ShowS
$cshow :: forall blk. StandardHash blk => InitLog blk -> String
show :: InitLog blk -> String
$cshowList :: forall blk. StandardHash blk => [InitLog blk] -> ShowS
showList :: [InitLog blk] -> ShowS
Show, InitLog blk -> InitLog blk -> Bool
(InitLog blk -> InitLog blk -> Bool)
-> (InitLog blk -> InitLog blk -> Bool) -> Eq (InitLog blk)
forall blk. StandardHash blk => InitLog blk -> InitLog blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk. StandardHash blk => InitLog blk -> InitLog blk -> Bool
== :: InitLog blk -> InitLog blk -> Bool
$c/= :: forall blk. StandardHash blk => InitLog blk -> InitLog blk -> Bool
/= :: InitLog blk -> InitLog blk -> Bool
Eq, (forall x. InitLog blk -> Rep (InitLog blk) x)
-> (forall x. Rep (InitLog blk) x -> InitLog blk)
-> Generic (InitLog blk)
forall x. Rep (InitLog blk) x -> InitLog blk
forall x. InitLog blk -> Rep (InitLog blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (InitLog blk) x -> InitLog blk
forall blk x. InitLog blk -> Rep (InitLog blk) x
$cfrom :: forall blk x. InitLog blk -> Rep (InitLog blk) x
from :: forall x. InitLog blk -> Rep (InitLog blk) x
$cto :: forall blk x. Rep (InitLog blk) x -> InitLog blk
to :: forall x. Rep (InitLog blk) x -> InitLog blk
Generic)

-- | Functions required to initialize a LedgerDB
type InitDB :: Type -> (Type -> Type) -> Type -> Type
data InitDB db m blk = InitDB {
    forall db (m :: * -> *) blk. InitDB db m blk -> m db
initFromGenesis  :: !(m db)
    -- ^ Create a DB from the genesis state
  , forall db (m :: * -> *) blk.
InitDB db m blk
-> DiskSnapshot
-> m (Either (SnapshotFailure blk) (db, RealPoint blk))
initFromSnapshot :: !(DiskSnapshot -> m (Either (SnapshotFailure blk) (db, RealPoint blk)))
    -- ^ Create a DB from a Snapshot
  , forall db (m :: * -> *) blk. InitDB db m blk -> db -> m ()
closeDb          :: !(db -> m ())
    -- ^ Closing the database, to be reopened again with a different snapshot or
    -- with the genesis state.
  , forall db (m :: * -> *) blk.
InitDB db m blk
-> LedgerDbCfg (ExtLedgerState blk) -> blk -> db -> m db
initReapplyBlock :: !(LedgerDbCfg (ExtLedgerState blk) -> blk -> db -> m db)
    -- ^ Reapply a block from the immutable DB when initializing the DB.
  , forall db (m :: * -> *) blk.
InitDB db m blk -> db -> LedgerState blk EmptyMK
currentTip       :: !(db -> LedgerState blk EmptyMK)
    -- ^ Getting the current tip for tracing the Ledger Events.
  , forall db (m :: * -> *) blk. InitDB db m blk -> db -> m db
pruneDb          :: !(db -> m db)
    -- ^ Prune the database so that no immutable states are considered volatile.
  , forall db (m :: * -> *) blk.
InitDB db m blk
-> db
-> m (LedgerDB m (ExtLedgerState blk) blk,
      TestInternals m (ExtLedgerState blk) blk)
mkLedgerDb       :: !(db -> m (LedgerDB m (ExtLedgerState blk) blk, TestInternals m (ExtLedgerState blk) blk))
    -- ^ Create a LedgerDB from the initialized data structures from previous
    -- steps.
  }

-- | Initialize the ledger DB from the most recent snapshot on disk
--
-- If no such snapshot can be found, use the genesis ledger DB. Returns the
-- initialized DB as well as a log of the initialization and the number of
-- blocks replayed between the snapshot and the tip of the immutable DB.
--
-- We do /not/ catch any exceptions thrown during streaming; should any be
-- thrown, it is the responsibility of the 'ChainDB' to catch these
-- and trigger (further) validation. We only discard snapshots if
--
-- * We cannot deserialise them, or
--
-- * they are /ahead/ of the chain, they refer to a slot which is later than the
--     last slot in the immutable db.
--
-- We do /not/ attempt to use multiple ledger states from disk to construct the
-- ledger DB. Instead we load only a /single/ ledger state from disk, and
-- /compute/ all subsequent ones. This is important, because the ledger states
-- obtained in this way will (hopefully) share much of their memory footprint
-- with their predecessors.
initialize ::
     forall m blk db.
     ( IOLike m
     , LedgerSupportsProtocol blk
     , InspectLedger blk
     , HasCallStack
     )
  => Tracer m (TraceReplayEvent blk)
  -> Tracer m (TraceSnapshotEvent blk)
  -> SomeHasFS m
  -> LedgerDbCfg (ExtLedgerState blk)
  -> StreamAPI m blk blk
  -> Point blk
  -> InitDB db m blk
  -> Maybe DiskSnapshot
  -> m (InitLog blk, db, Word64)
initialize :: forall (m :: * -> *) blk db.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Tracer m (TraceReplayEvent blk)
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk blk
-> Point blk
-> InitDB db m blk
-> Maybe DiskSnapshot
-> m (InitLog blk, db, Word64)
initialize Tracer m (TraceReplayEvent blk)
replayTracer
           Tracer m (TraceSnapshotEvent blk)
snapTracer
           SomeHasFS m
hasFS
           LedgerDbCfg (ExtLedgerState blk)
cfg
           StreamAPI m blk blk
stream
           Point blk
replayGoal
           InitDB db m blk
dbIface
           Maybe DiskSnapshot
fromSnapshot =
    case Maybe DiskSnapshot
fromSnapshot of
      Maybe DiskSnapshot
Nothing   -> SomeHasFS m -> m [DiskSnapshot]
forall (m :: * -> *). Monad m => SomeHasFS m -> m [DiskSnapshot]
listSnapshots SomeHasFS m
hasFS m [DiskSnapshot]
-> ([DiskSnapshot] -> m (InitLog blk, db, Word64))
-> m (InitLog blk, db, Word64)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (InitLog blk -> InitLog blk)
-> [DiskSnapshot] -> m (InitLog blk, db, Word64)
tryNewestFirst InitLog blk -> InitLog blk
forall a. a -> a
id
      Just DiskSnapshot
snap -> (InitLog blk -> InitLog blk)
-> [DiskSnapshot] -> m (InitLog blk, db, Word64)
tryNewestFirst InitLog blk -> InitLog blk
forall a. a -> a
id [DiskSnapshot
snap]
  where
    InitDB {m db
initFromGenesis :: forall db (m :: * -> *) blk. InitDB db m blk -> m db
initFromGenesis :: m db
initFromGenesis, DiskSnapshot
-> m (Either (SnapshotFailure blk) (db, RealPoint blk))
initFromSnapshot :: forall db (m :: * -> *) blk.
InitDB db m blk
-> DiskSnapshot
-> m (Either (SnapshotFailure blk) (db, RealPoint blk))
initFromSnapshot :: DiskSnapshot
-> m (Either (SnapshotFailure blk) (db, RealPoint blk))
initFromSnapshot, db -> m ()
closeDb :: forall db (m :: * -> *) blk. InitDB db m blk -> db -> m ()
closeDb :: db -> m ()
closeDb} = InitDB db m blk
dbIface

    tryNewestFirst :: (InitLog blk -> InitLog blk)
                   -> [DiskSnapshot]
                   -> m ( InitLog   blk
                        , db
                        , Word64
                        )
    tryNewestFirst :: (InitLog blk -> InitLog blk)
-> [DiskSnapshot] -> m (InitLog blk, db, Word64)
tryNewestFirst InitLog blk -> InitLog blk
acc [] = do
      -- We're out of snapshots. Start at genesis
      Tracer m (TraceReplayStartEvent blk)
-> TraceReplayStartEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (TraceReplayStartEvent blk -> TraceReplayEvent blk
forall blk. TraceReplayStartEvent blk -> TraceReplayEvent blk
TraceReplayStartEvent (TraceReplayStartEvent blk -> TraceReplayEvent blk)
-> Tracer m (TraceReplayEvent blk)
-> Tracer m (TraceReplayStartEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m (TraceReplayEvent blk)
replayTracer) TraceReplayStartEvent blk
forall {k} (blk :: k). TraceReplayStartEvent blk
ReplayFromGenesis
      let replayTracer'' :: Tracer
  m
  (ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
replayTracer'' = Point blk
-> Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk)
-> Tracer
     m
     (ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
forall blk (m :: * -> *).
Point blk
-> Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk)
-> Tracer
     m
     (ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
decorateReplayTracerWithStart (WithOrigin (Block SlotNo (HeaderHash blk)) -> Point blk
forall {k} (block :: k).
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point WithOrigin (Block SlotNo (HeaderHash blk))
forall t. WithOrigin t
Origin) Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk)
replayTracer'
      initDb <- m db
initFromGenesis
      eDB <- runExceptT $ replayStartingWith
                            replayTracer''
                            cfg
                            stream
                            initDb
                            (Point Origin)
                            dbIface

      case eDB of
        Left SnapshotFailure blk
err -> do
          db -> m ()
closeDb db
initDb
          String -> m (InitLog blk, db, Word64)
forall a. HasCallStack => String -> a
error (String -> m (InitLog blk, db, Word64))
-> String -> m (InitLog blk, db, Word64)
forall a b. (a -> b) -> a -> b
$ String
"Invariant violation: invalid immutable chain " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SnapshotFailure blk -> String
forall a. Show a => a -> String
show SnapshotFailure blk
err
        Right (db
db, Word64
replayed) -> do
          db' <- InitDB db m blk -> db -> m db
forall db (m :: * -> *) blk. InitDB db m blk -> db -> m db
pruneDb InitDB db m blk
dbIface db
db
          return ( acc InitFromGenesis
                 , db'
                 , replayed
                 )

    tryNewestFirst InitLog blk -> InitLog blk
acc (DiskSnapshot
s:[DiskSnapshot]
ss) = do
      eInitDb <- DiskSnapshot
-> m (Either (SnapshotFailure blk) (db, RealPoint blk))
initFromSnapshot DiskSnapshot
s
      case eInitDb of
        -- If the snapshot is missing a metadata file, issue a warning and try
        -- the next oldest snapshot
        Left err :: SnapshotFailure blk
err@(InitFailureRead (ReadMetadataError FsPath
_ MetadataErr
MetadataFileDoesNotExist)) -> do
          Tracer m (TraceSnapshotEvent blk) -> TraceSnapshotEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSnapshotEvent blk)
snapTracer (TraceSnapshotEvent blk -> m ()) -> TraceSnapshotEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ DiskSnapshot -> SnapshotFailure blk -> TraceSnapshotEvent blk
forall blk.
DiskSnapshot -> SnapshotFailure blk -> TraceSnapshotEvent blk
InvalidSnapshot DiskSnapshot
s SnapshotFailure blk
err
          (InitLog blk -> InitLog blk)
-> [DiskSnapshot] -> m (InitLog blk, db, Word64)
tryNewestFirst (InitLog blk -> InitLog blk
acc (InitLog blk -> InitLog blk)
-> (InitLog blk -> InitLog blk) -> InitLog blk -> InitLog blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> SnapshotFailure blk -> InitLog blk -> InitLog blk
forall blk.
DiskSnapshot -> SnapshotFailure blk -> InitLog blk -> InitLog blk
InitFailure DiskSnapshot
s SnapshotFailure blk
err) [DiskSnapshot]
ss

        -- If the snapshot's backend is incorrect, issue a warning and try
        -- the next oldest snapshot
        Left err :: SnapshotFailure blk
err@(InitFailureRead (ReadMetadataError FsPath
_ MetadataErr
MetadataBackendMismatch)) -> do
          Tracer m (TraceSnapshotEvent blk) -> TraceSnapshotEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSnapshotEvent blk)
snapTracer (TraceSnapshotEvent blk -> m ()) -> TraceSnapshotEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ DiskSnapshot -> SnapshotFailure blk -> TraceSnapshotEvent blk
forall blk.
DiskSnapshot -> SnapshotFailure blk -> TraceSnapshotEvent blk
InvalidSnapshot DiskSnapshot
s SnapshotFailure blk
err
          (InitLog blk -> InitLog blk)
-> [DiskSnapshot] -> m (InitLog blk, db, Word64)
tryNewestFirst (InitLog blk -> InitLog blk
acc (InitLog blk -> InitLog blk)
-> (InitLog blk -> InitLog blk) -> InitLog blk -> InitLog blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> SnapshotFailure blk -> InitLog blk -> InitLog blk
forall blk.
DiskSnapshot -> SnapshotFailure blk -> InitLog blk -> InitLog blk
InitFailure DiskSnapshot
s SnapshotFailure blk
err) [DiskSnapshot]
ss

        -- If the snapshot has a checksum that doesn't match the actual data,
        -- issue a warning, delete it, and try the next oldest snapshot
        Left err :: SnapshotFailure blk
err@(InitFailureRead ReadSnapshotErr
ReadSnapshotDataCorruption) -> do
          Tracer m (TraceSnapshotEvent blk) -> TraceSnapshotEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSnapshotEvent blk)
snapTracer (TraceSnapshotEvent blk -> m ()) -> TraceSnapshotEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ DiskSnapshot -> SnapshotFailure blk -> TraceSnapshotEvent blk
forall blk.
DiskSnapshot -> SnapshotFailure blk -> TraceSnapshotEvent blk
InvalidSnapshot DiskSnapshot
s SnapshotFailure blk
err
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when (DiskSnapshot -> Bool
diskSnapshotIsTemporary DiskSnapshot
s) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            Tracer m (TraceSnapshotEvent blk) -> TraceSnapshotEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSnapshotEvent blk)
snapTracer (TraceSnapshotEvent blk -> m ()) -> TraceSnapshotEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ DiskSnapshot -> TraceSnapshotEvent blk
forall blk. DiskSnapshot -> TraceSnapshotEvent blk
DeletedSnapshot DiskSnapshot
s
            SomeHasFS m -> DiskSnapshot -> m ()
forall (m :: * -> *).
(Monad m, HasCallStack) =>
SomeHasFS m -> DiskSnapshot -> m ()
deleteSnapshot SomeHasFS m
hasFS DiskSnapshot
s
          (InitLog blk -> InitLog blk)
-> [DiskSnapshot] -> m (InitLog blk, db, Word64)
tryNewestFirst (InitLog blk -> InitLog blk
acc (InitLog blk -> InitLog blk)
-> (InitLog blk -> InitLog blk) -> InitLog blk -> InitLog blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> SnapshotFailure blk -> InitLog blk -> InitLog blk
forall blk.
DiskSnapshot -> SnapshotFailure blk -> InitLog blk -> InitLog blk
InitFailure DiskSnapshot
s SnapshotFailure blk
err) [DiskSnapshot]
ss

        -- If we fail to use this snapshot for any other reason, delete it and
        -- try an older one
        Left SnapshotFailure blk
err -> do
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when (DiskSnapshot -> Bool
diskSnapshotIsTemporary DiskSnapshot
s Bool -> Bool -> Bool
|| SnapshotFailure blk
err SnapshotFailure blk -> SnapshotFailure blk -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotFailure blk
forall blk. SnapshotFailure blk
InitFailureGenesis) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            Tracer m (TraceSnapshotEvent blk) -> TraceSnapshotEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSnapshotEvent blk)
snapTracer (TraceSnapshotEvent blk -> m ()) -> TraceSnapshotEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ DiskSnapshot -> TraceSnapshotEvent blk
forall blk. DiskSnapshot -> TraceSnapshotEvent blk
DeletedSnapshot DiskSnapshot
s
            SomeHasFS m -> DiskSnapshot -> m ()
forall (m :: * -> *).
(Monad m, HasCallStack) =>
SomeHasFS m -> DiskSnapshot -> m ()
deleteSnapshot SomeHasFS m
hasFS DiskSnapshot
s
          Tracer m (TraceSnapshotEvent blk) -> TraceSnapshotEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSnapshotEvent blk)
snapTracer (TraceSnapshotEvent blk -> m ())
-> (SnapshotFailure blk -> TraceSnapshotEvent blk)
-> SnapshotFailure blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> SnapshotFailure blk -> TraceSnapshotEvent blk
forall blk.
DiskSnapshot -> SnapshotFailure blk -> TraceSnapshotEvent blk
InvalidSnapshot DiskSnapshot
s (SnapshotFailure blk -> m ()) -> SnapshotFailure blk -> m ()
forall a b. (a -> b) -> a -> b
$ SnapshotFailure blk
err
          (InitLog blk -> InitLog blk)
-> [DiskSnapshot] -> m (InitLog blk, db, Word64)
tryNewestFirst (InitLog blk -> InitLog blk
acc (InitLog blk -> InitLog blk)
-> (InitLog blk -> InitLog blk) -> InitLog blk -> InitLog blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> SnapshotFailure blk -> InitLog blk -> InitLog blk
forall blk.
DiskSnapshot -> SnapshotFailure blk -> InitLog blk -> InitLog blk
InitFailure DiskSnapshot
s SnapshotFailure blk
err) [DiskSnapshot]
ss

        Right (db
initDb, RealPoint blk
pt) -> do
          let pt' :: Point blk
pt' = RealPoint blk -> Point blk
forall blk. RealPoint blk -> Point blk
realPointToPoint RealPoint blk
pt
          Tracer m (TraceReplayStartEvent blk)
-> TraceReplayStartEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (TraceReplayStartEvent blk -> TraceReplayEvent blk
forall blk. TraceReplayStartEvent blk -> TraceReplayEvent blk
TraceReplayStartEvent (TraceReplayStartEvent blk -> TraceReplayEvent blk)
-> Tracer m (TraceReplayEvent blk)
-> Tracer m (TraceReplayStartEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m (TraceReplayEvent blk)
replayTracer) (DiskSnapshot -> ReplayStart blk -> TraceReplayStartEvent blk
forall {k} (blk :: k).
DiskSnapshot -> ReplayStart blk -> TraceReplayStartEvent blk
ReplayFromSnapshot DiskSnapshot
s (Point blk -> ReplayStart blk
forall {k} (blk :: k). Point blk -> ReplayStart blk
ReplayStart Point blk
pt'))
          let replayTracer'' :: Tracer
  m
  (ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
replayTracer'' = Point blk
-> Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk)
-> Tracer
     m
     (ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
forall blk (m :: * -> *).
Point blk
-> Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk)
-> Tracer
     m
     (ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
decorateReplayTracerWithStart Point blk
pt' Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk)
replayTracer'
          eDB <- ExceptT (SnapshotFailure blk) m (db, Word64)
-> m (Either (SnapshotFailure blk) (db, Word64))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
                   (ExceptT (SnapshotFailure blk) m (db, Word64)
 -> m (Either (SnapshotFailure blk) (db, Word64)))
-> ExceptT (SnapshotFailure blk) m (db, Word64)
-> m (Either (SnapshotFailure blk) (db, Word64))
forall a b. (a -> b) -> a -> b
$ Tracer
  m
  (ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk blk
-> db
-> Point blk
-> InitDB db m blk
-> ExceptT (SnapshotFailure blk) m (db, Word64)
forall (m :: * -> *) blk db.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Tracer
  m
  (ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk blk
-> db
-> Point blk
-> InitDB db m blk
-> ExceptT (SnapshotFailure blk) m (db, Word64)
replayStartingWith
                       Tracer
  m
  (ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
replayTracer''
                       LedgerDbCfg (ExtLedgerState blk)
cfg
                       StreamAPI m blk blk
stream
                       db
initDb
                       Point blk
pt'
                       InitDB db m blk
dbIface
          case eDB of
            Left SnapshotFailure blk
err -> do
              Tracer m (TraceSnapshotEvent blk) -> TraceSnapshotEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSnapshotEvent blk)
snapTracer (TraceSnapshotEvent blk -> m ())
-> (SnapshotFailure blk -> TraceSnapshotEvent blk)
-> SnapshotFailure blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> SnapshotFailure blk -> TraceSnapshotEvent blk
forall blk.
DiskSnapshot -> SnapshotFailure blk -> TraceSnapshotEvent blk
InvalidSnapshot DiskSnapshot
s (SnapshotFailure blk -> m ()) -> SnapshotFailure blk -> m ()
forall a b. (a -> b) -> a -> b
$ SnapshotFailure blk
err
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when (DiskSnapshot -> Bool
diskSnapshotIsTemporary DiskSnapshot
s) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ SomeHasFS m -> DiskSnapshot -> m ()
forall (m :: * -> *).
(Monad m, HasCallStack) =>
SomeHasFS m -> DiskSnapshot -> m ()
deleteSnapshot SomeHasFS m
hasFS DiskSnapshot
s
              db -> m ()
closeDb db
initDb
              (InitLog blk -> InitLog blk)
-> [DiskSnapshot] -> m (InitLog blk, db, Word64)
tryNewestFirst (InitLog blk -> InitLog blk
acc (InitLog blk -> InitLog blk)
-> (InitLog blk -> InitLog blk) -> InitLog blk -> InitLog blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> SnapshotFailure blk -> InitLog blk -> InitLog blk
forall blk.
DiskSnapshot -> SnapshotFailure blk -> InitLog blk -> InitLog blk
InitFailure DiskSnapshot
s SnapshotFailure blk
err) [DiskSnapshot]
ss
            Right (db
db, Word64
replayed) -> do
              db' <- InitDB db m blk -> db -> m db
forall db (m :: * -> *) blk. InitDB db m blk -> db -> m db
pruneDb InitDB db m blk
dbIface db
db
              return (acc (InitFromSnapshot s pt), db', replayed)

    replayTracer' :: Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk)
replayTracer' = Point blk
-> Tracer m (TraceReplayProgressEvent blk)
-> Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk)
forall blk (m :: * -> *).
Point blk
-> Tracer m (TraceReplayProgressEvent blk)
-> Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk)
decorateReplayTracerWithGoal
                                       Point blk
replayGoal
                                       (TraceReplayProgressEvent blk -> TraceReplayEvent blk
forall blk. TraceReplayProgressEvent blk -> TraceReplayEvent blk
TraceReplayProgressEvent (TraceReplayProgressEvent blk -> TraceReplayEvent blk)
-> Tracer m (TraceReplayEvent blk)
-> Tracer m (TraceReplayProgressEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m (TraceReplayEvent blk)
replayTracer)

-- | Replay all blocks in the Immutable database using the 'StreamAPI' provided
-- on top of the given @LedgerDB' blk@.
--
-- It will also return the number of blocks that were replayed.
replayStartingWith ::
     forall m blk db. (
         IOLike m
       , LedgerSupportsProtocol blk
       , InspectLedger blk
       , HasCallStack
       )
  => Tracer m (ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
  -> LedgerDbCfg (ExtLedgerState blk)
  -> StreamAPI m blk blk
  -> db
  -> Point blk
  -> InitDB db m blk
  -> ExceptT (SnapshotFailure blk) m (db, Word64)
replayStartingWith :: forall (m :: * -> *) blk db.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Tracer
  m
  (ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk blk
-> db
-> Point blk
-> InitDB db m blk
-> ExceptT (SnapshotFailure blk) m (db, Word64)
replayStartingWith Tracer
  m
  (ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
tracer LedgerDbCfg (ExtLedgerState blk)
cfg StreamAPI m blk blk
stream db
initDb Point blk
from InitDB{LedgerDbCfg (ExtLedgerState blk) -> blk -> db -> m db
initReapplyBlock :: forall db (m :: * -> *) blk.
InitDB db m blk
-> LedgerDbCfg (ExtLedgerState blk) -> blk -> db -> m db
initReapplyBlock :: LedgerDbCfg (ExtLedgerState blk) -> blk -> db -> m db
initReapplyBlock, db -> LedgerState blk EmptyMK
currentTip :: forall db (m :: * -> *) blk.
InitDB db m blk -> db -> LedgerState blk EmptyMK
currentTip :: db -> LedgerState blk EmptyMK
currentTip} = do
    StreamAPI m blk blk
-> Point blk
-> (RealPoint blk -> SnapshotFailure blk)
-> (db, Word64)
-> (blk -> (db, Word64) -> m (db, Word64))
-> ExceptT (SnapshotFailure blk) m (db, Word64)
forall (m :: * -> *) blk e b a.
(Monad m, HasCallStack) =>
StreamAPI m blk b
-> Point blk
-> (RealPoint blk -> e)
-> a
-> (b -> a -> m a)
-> ExceptT e m a
streamAll StreamAPI m blk blk
stream Point blk
from
        RealPoint blk -> SnapshotFailure blk
forall blk. RealPoint blk -> SnapshotFailure blk
InitFailureTooRecent
        (db
initDb, Word64
0)
        blk -> (db, Word64) -> m (db, Word64)
push
  where
    push :: blk
         -> (db, Word64)
         -> m (db, Word64)
    push :: blk -> (db, Word64) -> m (db, Word64)
push blk
blk (!db
db, !Word64
replayed) = do
        !db' <- LedgerDbCfg (ExtLedgerState blk) -> blk -> db -> m db
initReapplyBlock LedgerDbCfg (ExtLedgerState blk)
cfg blk
blk db
db

        let !replayed' = Word64
replayed Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1

            events = TopLevelConfig blk
-> LedgerState blk EmptyMK
-> LedgerState blk EmptyMK
-> [LedgerEvent blk]
forall blk (mk1 :: MapKind) (mk2 :: MapKind).
InspectLedger blk =>
TopLevelConfig blk
-> LedgerState blk mk1 -> LedgerState blk mk2 -> [LedgerEvent blk]
forall (mk1 :: MapKind) (mk2 :: MapKind).
TopLevelConfig blk
-> LedgerState blk mk1 -> LedgerState blk mk2 -> [LedgerEvent blk]
inspectLedger
                       (ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg (LedgerDbCfg (ExtLedgerState blk)
-> HKD Identity (LedgerCfg (ExtLedgerState blk))
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
ledgerDbCfg LedgerDbCfg (ExtLedgerState blk)
cfg))
                       (db -> LedgerState blk EmptyMK
currentTip db
db)
                       (db -> LedgerState blk EmptyMK
currentTip db
db')

        traceWith tracer (ReplayedBlock (blockRealPoint blk) events)
        return (db', replayed')

{-------------------------------------------------------------------------------
  Trace replay events
-------------------------------------------------------------------------------}

data TraceReplayEvent blk =
      TraceReplayStartEvent (TraceReplayStartEvent blk)
    | TraceReplayProgressEvent (TraceReplayProgressEvent blk)
    deriving (Int -> TraceReplayEvent blk -> ShowS
[TraceReplayEvent blk] -> ShowS
TraceReplayEvent blk -> String
(Int -> TraceReplayEvent blk -> ShowS)
-> (TraceReplayEvent blk -> String)
-> ([TraceReplayEvent blk] -> ShowS)
-> Show (TraceReplayEvent blk)
forall blk.
(StandardHash blk, InspectLedger blk) =>
Int -> TraceReplayEvent blk -> ShowS
forall blk.
(StandardHash blk, InspectLedger blk) =>
[TraceReplayEvent blk] -> ShowS
forall blk.
(StandardHash blk, InspectLedger blk) =>
TraceReplayEvent blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk.
(StandardHash blk, InspectLedger blk) =>
Int -> TraceReplayEvent blk -> ShowS
showsPrec :: Int -> TraceReplayEvent blk -> ShowS
$cshow :: forall blk.
(StandardHash blk, InspectLedger blk) =>
TraceReplayEvent blk -> String
show :: TraceReplayEvent blk -> String
$cshowList :: forall blk.
(StandardHash blk, InspectLedger blk) =>
[TraceReplayEvent blk] -> ShowS
showList :: [TraceReplayEvent blk] -> ShowS
Show, TraceReplayEvent blk -> TraceReplayEvent blk -> Bool
(TraceReplayEvent blk -> TraceReplayEvent blk -> Bool)
-> (TraceReplayEvent blk -> TraceReplayEvent blk -> Bool)
-> Eq (TraceReplayEvent blk)
forall blk.
(StandardHash blk, InspectLedger blk) =>
TraceReplayEvent blk -> TraceReplayEvent blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
(StandardHash blk, InspectLedger blk) =>
TraceReplayEvent blk -> TraceReplayEvent blk -> Bool
== :: TraceReplayEvent blk -> TraceReplayEvent blk -> Bool
$c/= :: forall blk.
(StandardHash blk, InspectLedger blk) =>
TraceReplayEvent blk -> TraceReplayEvent blk -> Bool
/= :: TraceReplayEvent blk -> TraceReplayEvent blk -> Bool
Eq)

-- | Add the tip of the Immutable DB to the trace event
decorateReplayTracerWithGoal
  :: Point blk -- ^ Tip of the ImmutableDB
  -> Tracer m (TraceReplayProgressEvent blk)
  -> Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk)
decorateReplayTracerWithGoal :: forall blk (m :: * -> *).
Point blk
-> Tracer m (TraceReplayProgressEvent blk)
-> Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk)
decorateReplayTracerWithGoal Point blk
immTip = (((ReplayGoal blk -> TraceReplayProgressEvent blk)
-> ReplayGoal blk -> TraceReplayProgressEvent blk
forall a b. (a -> b) -> a -> b
$ Point blk -> ReplayGoal blk
forall {k} (blk :: k). Point blk -> ReplayGoal blk
ReplayGoal Point blk
immTip) ((ReplayGoal blk -> TraceReplayProgressEvent blk)
 -> TraceReplayProgressEvent blk)
-> Tracer m (TraceReplayProgressEvent blk)
-> Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$<)

-- | Add the block at which a replay started.
decorateReplayTracerWithStart
  :: Point blk -- ^ Starting point of the replay
  -> Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk)
  -> Tracer m (ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
decorateReplayTracerWithStart :: forall blk (m :: * -> *).
Point blk
-> Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk)
-> Tracer
     m
     (ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
decorateReplayTracerWithStart Point blk
start = (((ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
-> ReplayStart blk
-> ReplayGoal blk
-> TraceReplayProgressEvent blk
forall a b. (a -> b) -> a -> b
$ Point blk -> ReplayStart blk
forall {k} (blk :: k). Point blk -> ReplayStart blk
ReplayStart Point blk
start) ((ReplayStart blk
  -> ReplayGoal blk -> TraceReplayProgressEvent blk)
 -> ReplayGoal blk -> TraceReplayProgressEvent blk)
-> Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk)
-> Tracer
     m
     (ReplayStart blk -> ReplayGoal blk -> TraceReplayProgressEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$<)

-- | Which point the replay started from
newtype ReplayStart blk = ReplayStart (Point blk) deriving (ReplayStart blk -> ReplayStart blk -> Bool
(ReplayStart blk -> ReplayStart blk -> Bool)
-> (ReplayStart blk -> ReplayStart blk -> Bool)
-> Eq (ReplayStart blk)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (blk :: k).
StandardHash blk =>
ReplayStart blk -> ReplayStart blk -> Bool
$c== :: forall k (blk :: k).
StandardHash blk =>
ReplayStart blk -> ReplayStart blk -> Bool
== :: ReplayStart blk -> ReplayStart blk -> Bool
$c/= :: forall k (blk :: k).
StandardHash blk =>
ReplayStart blk -> ReplayStart blk -> Bool
/= :: ReplayStart blk -> ReplayStart blk -> Bool
Eq, Int -> ReplayStart blk -> ShowS
[ReplayStart blk] -> ShowS
ReplayStart blk -> String
(Int -> ReplayStart blk -> ShowS)
-> (ReplayStart blk -> String)
-> ([ReplayStart blk] -> ShowS)
-> Show (ReplayStart blk)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (blk :: k).
StandardHash blk =>
Int -> ReplayStart blk -> ShowS
forall k (blk :: k). StandardHash blk => [ReplayStart blk] -> ShowS
forall k (blk :: k). StandardHash blk => ReplayStart blk -> String
$cshowsPrec :: forall k (blk :: k).
StandardHash blk =>
Int -> ReplayStart blk -> ShowS
showsPrec :: Int -> ReplayStart blk -> ShowS
$cshow :: forall k (blk :: k). StandardHash blk => ReplayStart blk -> String
show :: ReplayStart blk -> String
$cshowList :: forall k (blk :: k). StandardHash blk => [ReplayStart blk] -> ShowS
showList :: [ReplayStart blk] -> ShowS
Show)

-- | Which point the replay is expected to end at
newtype ReplayGoal blk = ReplayGoal (Point blk) deriving (ReplayGoal blk -> ReplayGoal blk -> Bool
(ReplayGoal blk -> ReplayGoal blk -> Bool)
-> (ReplayGoal blk -> ReplayGoal blk -> Bool)
-> Eq (ReplayGoal blk)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (blk :: k).
StandardHash blk =>
ReplayGoal blk -> ReplayGoal blk -> Bool
$c== :: forall k (blk :: k).
StandardHash blk =>
ReplayGoal blk -> ReplayGoal blk -> Bool
== :: ReplayGoal blk -> ReplayGoal blk -> Bool
$c/= :: forall k (blk :: k).
StandardHash blk =>
ReplayGoal blk -> ReplayGoal blk -> Bool
/= :: ReplayGoal blk -> ReplayGoal blk -> Bool
Eq, Int -> ReplayGoal blk -> ShowS
[ReplayGoal blk] -> ShowS
ReplayGoal blk -> String
(Int -> ReplayGoal blk -> ShowS)
-> (ReplayGoal blk -> String)
-> ([ReplayGoal blk] -> ShowS)
-> Show (ReplayGoal blk)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (blk :: k).
StandardHash blk =>
Int -> ReplayGoal blk -> ShowS
forall k (blk :: k). StandardHash blk => [ReplayGoal blk] -> ShowS
forall k (blk :: k). StandardHash blk => ReplayGoal blk -> String
$cshowsPrec :: forall k (blk :: k).
StandardHash blk =>
Int -> ReplayGoal blk -> ShowS
showsPrec :: Int -> ReplayGoal blk -> ShowS
$cshow :: forall k (blk :: k). StandardHash blk => ReplayGoal blk -> String
show :: ReplayGoal blk -> String
$cshowList :: forall k (blk :: k). StandardHash blk => [ReplayGoal blk] -> ShowS
showList :: [ReplayGoal blk] -> ShowS
Show)

-- | Events traced while replaying blocks against the ledger to bring it up to
-- date w.r.t. the tip of the ImmutableDB during initialisation. As this
-- process takes a while, we trace events to inform higher layers of our
-- progress.
data TraceReplayStartEvent blk
  = -- | There were no LedgerDB snapshots on disk, so we're replaying all blocks
    -- starting from Genesis against the initial ledger.
    ReplayFromGenesis
    -- | There was a LedgerDB snapshot on disk corresponding to the given tip.
    -- We're replaying more recent blocks against it.
  | ReplayFromSnapshot
        DiskSnapshot
        (ReplayStart blk) -- ^ the block at which this replay started
  deriving ((forall x.
 TraceReplayStartEvent blk -> Rep (TraceReplayStartEvent blk) x)
-> (forall x.
    Rep (TraceReplayStartEvent blk) x -> TraceReplayStartEvent blk)
-> Generic (TraceReplayStartEvent blk)
forall x.
Rep (TraceReplayStartEvent blk) x -> TraceReplayStartEvent blk
forall x.
TraceReplayStartEvent blk -> Rep (TraceReplayStartEvent blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (blk :: k) x.
Rep (TraceReplayStartEvent blk) x -> TraceReplayStartEvent blk
forall k (blk :: k) x.
TraceReplayStartEvent blk -> Rep (TraceReplayStartEvent blk) x
$cfrom :: forall k (blk :: k) x.
TraceReplayStartEvent blk -> Rep (TraceReplayStartEvent blk) x
from :: forall x.
TraceReplayStartEvent blk -> Rep (TraceReplayStartEvent blk) x
$cto :: forall k (blk :: k) x.
Rep (TraceReplayStartEvent blk) x -> TraceReplayStartEvent blk
to :: forall x.
Rep (TraceReplayStartEvent blk) x -> TraceReplayStartEvent blk
Generic, TraceReplayStartEvent blk -> TraceReplayStartEvent blk -> Bool
(TraceReplayStartEvent blk -> TraceReplayStartEvent blk -> Bool)
-> (TraceReplayStartEvent blk -> TraceReplayStartEvent blk -> Bool)
-> Eq (TraceReplayStartEvent blk)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (blk :: k).
StandardHash blk =>
TraceReplayStartEvent blk -> TraceReplayStartEvent blk -> Bool
$c== :: forall k (blk :: k).
StandardHash blk =>
TraceReplayStartEvent blk -> TraceReplayStartEvent blk -> Bool
== :: TraceReplayStartEvent blk -> TraceReplayStartEvent blk -> Bool
$c/= :: forall k (blk :: k).
StandardHash blk =>
TraceReplayStartEvent blk -> TraceReplayStartEvent blk -> Bool
/= :: TraceReplayStartEvent blk -> TraceReplayStartEvent blk -> Bool
Eq, Int -> TraceReplayStartEvent blk -> ShowS
[TraceReplayStartEvent blk] -> ShowS
TraceReplayStartEvent blk -> String
(Int -> TraceReplayStartEvent blk -> ShowS)
-> (TraceReplayStartEvent blk -> String)
-> ([TraceReplayStartEvent blk] -> ShowS)
-> Show (TraceReplayStartEvent blk)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (blk :: k).
StandardHash blk =>
Int -> TraceReplayStartEvent blk -> ShowS
forall k (blk :: k).
StandardHash blk =>
[TraceReplayStartEvent blk] -> ShowS
forall k (blk :: k).
StandardHash blk =>
TraceReplayStartEvent blk -> String
$cshowsPrec :: forall k (blk :: k).
StandardHash blk =>
Int -> TraceReplayStartEvent blk -> ShowS
showsPrec :: Int -> TraceReplayStartEvent blk -> ShowS
$cshow :: forall k (blk :: k).
StandardHash blk =>
TraceReplayStartEvent blk -> String
show :: TraceReplayStartEvent blk -> String
$cshowList :: forall k (blk :: k).
StandardHash blk =>
[TraceReplayStartEvent blk] -> ShowS
showList :: [TraceReplayStartEvent blk] -> ShowS
Show)

-- | We replayed the given block (reference) on the genesis snapshot during
-- the initialisation of the LedgerDB. Used during ImmutableDB replay.
--
-- Using this trace the node could (if it so desired) easily compute a
-- "percentage complete".
data TraceReplayProgressEvent blk =
  ReplayedBlock
    (RealPoint blk)   -- ^ the block being replayed
    [LedgerEvent blk]
    (ReplayStart blk) -- ^ the block at which this replay started
    (ReplayGoal blk)  -- ^ the block at the tip of the ImmutableDB
  deriving ((forall x.
 TraceReplayProgressEvent blk
 -> Rep (TraceReplayProgressEvent blk) x)
-> (forall x.
    Rep (TraceReplayProgressEvent blk) x
    -> TraceReplayProgressEvent blk)
-> Generic (TraceReplayProgressEvent blk)
forall x.
Rep (TraceReplayProgressEvent blk) x
-> TraceReplayProgressEvent blk
forall x.
TraceReplayProgressEvent blk
-> Rep (TraceReplayProgressEvent blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x.
Rep (TraceReplayProgressEvent blk) x
-> TraceReplayProgressEvent blk
forall blk x.
TraceReplayProgressEvent blk
-> Rep (TraceReplayProgressEvent blk) x
$cfrom :: forall blk x.
TraceReplayProgressEvent blk
-> Rep (TraceReplayProgressEvent blk) x
from :: forall x.
TraceReplayProgressEvent blk
-> Rep (TraceReplayProgressEvent blk) x
$cto :: forall blk x.
Rep (TraceReplayProgressEvent blk) x
-> TraceReplayProgressEvent blk
to :: forall x.
Rep (TraceReplayProgressEvent blk) x
-> TraceReplayProgressEvent blk
Generic, TraceReplayProgressEvent blk
-> TraceReplayProgressEvent blk -> Bool
(TraceReplayProgressEvent blk
 -> TraceReplayProgressEvent blk -> Bool)
-> (TraceReplayProgressEvent blk
    -> TraceReplayProgressEvent blk -> Bool)
-> Eq (TraceReplayProgressEvent blk)
forall blk.
(StandardHash blk, InspectLedger blk) =>
TraceReplayProgressEvent blk
-> TraceReplayProgressEvent blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
(StandardHash blk, InspectLedger blk) =>
TraceReplayProgressEvent blk
-> TraceReplayProgressEvent blk -> Bool
== :: TraceReplayProgressEvent blk
-> TraceReplayProgressEvent blk -> Bool
$c/= :: forall blk.
(StandardHash blk, InspectLedger blk) =>
TraceReplayProgressEvent blk
-> TraceReplayProgressEvent blk -> Bool
/= :: TraceReplayProgressEvent blk
-> TraceReplayProgressEvent blk -> Bool
Eq, Int -> TraceReplayProgressEvent blk -> ShowS
[TraceReplayProgressEvent blk] -> ShowS
TraceReplayProgressEvent blk -> String
(Int -> TraceReplayProgressEvent blk -> ShowS)
-> (TraceReplayProgressEvent blk -> String)
-> ([TraceReplayProgressEvent blk] -> ShowS)
-> Show (TraceReplayProgressEvent blk)
forall blk.
(StandardHash blk, InspectLedger blk) =>
Int -> TraceReplayProgressEvent blk -> ShowS
forall blk.
(StandardHash blk, InspectLedger blk) =>
[TraceReplayProgressEvent blk] -> ShowS
forall blk.
(StandardHash blk, InspectLedger blk) =>
TraceReplayProgressEvent blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk.
(StandardHash blk, InspectLedger blk) =>
Int -> TraceReplayProgressEvent blk -> ShowS
showsPrec :: Int -> TraceReplayProgressEvent blk -> ShowS
$cshow :: forall blk.
(StandardHash blk, InspectLedger blk) =>
TraceReplayProgressEvent blk -> String
show :: TraceReplayProgressEvent blk -> String
$cshowList :: forall blk.
(StandardHash blk, InspectLedger blk) =>
[TraceReplayProgressEvent blk] -> ShowS
showList :: [TraceReplayProgressEvent blk] -> ShowS
Show)

{-------------------------------------------------------------------------------
  Updating ledger tables
-------------------------------------------------------------------------------}

type LedgerSupportsInMemoryLedgerDB blk = (CanUpgradeLedgerTables (LedgerState blk))

-- | When pushing differences on InMemory Ledger DBs, we will sometimes need to
-- update ledger tables to the latest era. For unary blocks this is a no-op, but
-- for the Cardano block, we will need to upgrade all TxOuts in memory.
--
-- No correctness property relies on this, as Consensus can work with TxOuts
-- from multiple eras, but the performance depends on it as otherwise we will be
-- upgrading the TxOuts every time we consult them.
class CanUpgradeLedgerTables l where
  upgradeTables ::
       l mk1 -- ^ The original ledger state before the upgrade. This will be the
             -- tip before applying the block.
    -> l mk2 -- ^ The ledger state after the upgrade, which might be in a
             -- different era than the one above.
    -> LedgerTables l ValuesMK -- ^ The tables we want to maybe upgrade.
    -> LedgerTables l ValuesMK

instance CanUpgradeLedgerTables (LedgerState blk)
      => CanUpgradeLedgerTables (ExtLedgerState blk) where
  upgradeTables :: forall (mk1 :: MapKind) (mk2 :: MapKind).
ExtLedgerState blk mk1
-> ExtLedgerState blk mk2
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> LedgerTables (ExtLedgerState blk) ValuesMK
upgradeTables (ExtLedgerState LedgerState blk mk1
st0 HeaderState blk
_) (ExtLedgerState LedgerState blk mk2
st1 HeaderState blk
_) =
    LedgerTables (LedgerState blk) ValuesMK
-> LedgerTables (ExtLedgerState blk) ValuesMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: MapKind).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables (LedgerTables (LedgerState blk) ValuesMK
 -> LedgerTables (ExtLedgerState blk) ValuesMK)
-> (LedgerTables (ExtLedgerState blk) ValuesMK
    -> LedgerTables (LedgerState blk) ValuesMK)
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> LedgerTables (ExtLedgerState blk) ValuesMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState blk mk1
-> LedgerState blk mk2
-> LedgerTables (LedgerState blk) ValuesMK
-> LedgerTables (LedgerState blk) ValuesMK
forall (mk1 :: MapKind) (mk2 :: MapKind).
LedgerState blk mk1
-> LedgerState blk mk2
-> LedgerTables (LedgerState blk) ValuesMK
-> LedgerTables (LedgerState blk) ValuesMK
forall (l :: LedgerStateKind) (mk1 :: MapKind) (mk2 :: MapKind).
CanUpgradeLedgerTables l =>
l mk1
-> l mk2 -> LedgerTables l ValuesMK -> LedgerTables l ValuesMK
upgradeTables LedgerState blk mk1
st0 LedgerState blk mk2
st1 (LedgerTables (LedgerState blk) ValuesMK
 -> LedgerTables (LedgerState blk) ValuesMK)
-> (LedgerTables (ExtLedgerState blk) ValuesMK
    -> LedgerTables (LedgerState blk) ValuesMK)
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> LedgerTables (LedgerState blk) ValuesMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerTables (ExtLedgerState blk) ValuesMK
-> LedgerTables (LedgerState blk) ValuesMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: MapKind).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables

instance LedgerTablesAreTrivial l
      => CanUpgradeLedgerTables (TrivialLedgerTables l) where
  upgradeTables :: forall (mk1 :: MapKind) (mk2 :: MapKind).
TrivialLedgerTables l mk1
-> TrivialLedgerTables l mk2
-> LedgerTables (TrivialLedgerTables l) ValuesMK
-> LedgerTables (TrivialLedgerTables l) ValuesMK
upgradeTables TrivialLedgerTables l mk1
_ TrivialLedgerTables l mk2
_ (LedgerTables (ValuesMK Map (TxIn (TrivialLedgerTables l)) (TxOut (TrivialLedgerTables l))
mk)) =
    ValuesMK
  (TxIn (TrivialLedgerTables l)) (TxOut (TrivialLedgerTables l))
-> LedgerTables (TrivialLedgerTables l) ValuesMK
forall (l :: LedgerStateKind) (mk :: MapKind).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables (Map Void Void -> ValuesMK Void Void
forall k v. Map k v -> ValuesMK k v
ValuesMK ((Void -> Void) -> Map Void Void -> Map Void Void
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Void -> Void
forall a. Void -> a
absurd Map Void Void
Map (TxIn (TrivialLedgerTables l)) (TxOut (TrivialLedgerTables l))
mk))

{-------------------------------------------------------------------------------
  Supporting On-Disk backing stores
-------------------------------------------------------------------------------}

type LedgerSupportsOnDiskLedgerDB blk =
  ( IndexedMemPack (LedgerState blk EmptyMK) (TxOut (LedgerState blk))
  )

type LedgerSupportsLedgerDB blk =
  ( LedgerSupportsOnDiskLedgerDB blk
  , LedgerSupportsInMemoryLedgerDB blk
  )

{-------------------------------------------------------------------------------
  Pruning
-------------------------------------------------------------------------------}

-- | Options for prunning the LedgerDB
--
-- Rather than using a plain `Word64` we use this to be able to distinguish that
-- we are indeed using
--   1. @0@ in places where it is necessary
--   2. the security parameter as is, in other places
data LedgerDbPrune = LedgerDbPruneAll | LedgerDbPruneKeeping SecurityParam
  deriving Int -> LedgerDbPrune -> ShowS
[LedgerDbPrune] -> ShowS
LedgerDbPrune -> String
(Int -> LedgerDbPrune -> ShowS)
-> (LedgerDbPrune -> String)
-> ([LedgerDbPrune] -> ShowS)
-> Show LedgerDbPrune
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LedgerDbPrune -> ShowS
showsPrec :: Int -> LedgerDbPrune -> ShowS
$cshow :: LedgerDbPrune -> String
show :: LedgerDbPrune -> String
$cshowList :: [LedgerDbPrune] -> ShowS
showList :: [LedgerDbPrune] -> ShowS
Show