{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}

-- | Thin wrapper around the LedgerDB
module Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB (
    LgrDB
    -- opaque
  , LedgerDB'
  , LgrDbSerialiseConstraints
    -- * Initialization
  , LgrDbArgs (..)
  , defaultArgs
  , openDB
    -- * 'TraceReplayEvent' decorator
  , LedgerDB.decorateReplayTracerWithGoal
    -- * Wrappers
  , currentPoint
  , getCurrent
  , getDiskPolicy
  , setCurrent
  , takeSnapshot
  , trimSnapshots
    -- * Validation
  , ValidateResult (..)
  , validate
    -- * Previously applied blocks
  , garbageCollectPrevApplied
  , getPrevApplied
    -- * Re-exports
  , LedgerDB.AnnLedgerError (..)
  , LedgerDB.DiskPolicy (..)
  , LedgerDB.DiskSnapshot
  , LedgerDB.ExceededRollback (..)
  , LedgerDB.TraceReplayEvent (..)
  , LedgerDB.TraceSnapshotEvent (..)
  , LedgerDB.ledgerDbCurrent
    -- * Exported for testing purposes
  , mkLgrDB
  ) where

import           Codec.CBOR.Decoding (Decoder)
import           Codec.CBOR.Encoding (Encoding)
import           Codec.Serialise (Serialise (decode))
import           Control.Monad.Trans.Class
import           Control.Tracer
import           Data.Foldable (foldl')
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Word (Word64)
import           GHC.Generics (Generic)
import           GHC.Stack (HasCallStack)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
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.API (ChainDbFailure (..))
import           Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache
                     (BlockCache)
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache as BlockCache
import           Ouroboros.Consensus.Storage.Common
import           Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB)
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import           Ouroboros.Consensus.Storage.LedgerDB (LedgerDB')
import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
import           Ouroboros.Consensus.Storage.Serialisation
import           Ouroboros.Consensus.Util.Args
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.ResourceRegistry
import           System.FS.API (SomeHasFS (..), createDirectoryIfMissing)
import           System.FS.API.Types (FsError, mkFsPath)

-- | Thin wrapper around the ledger database
data LgrDB m blk = LgrDB {
      LgrDB m blk -> StrictTVar m (LedgerDB' blk)
varDB          :: !(StrictTVar m (LedgerDB' blk))
      -- ^ INVARIANT: the tip of the 'LedgerDB' is always in sync with the tip
      -- of the current chain of the ChainDB.
    , LgrDB m blk -> StrictTVar m (Set (RealPoint blk))
varPrevApplied :: !(StrictTVar m (Set (RealPoint blk)))
      -- ^ INVARIANT: this set contains only points that are in the
      -- VolatileDB.
      --
      -- INVARIANT: all points on the current chain fragment are in this set.
      --
      -- The VolatileDB might contain invalid blocks, these will not be in
      -- this set.
      --
      -- When a garbage-collection is performed on the VolatileDB, the points
      -- of the blocks eligible for garbage-collection should be removed from
      -- this set.
    , LgrDB m blk -> RealPoint blk -> m blk
resolveBlock   :: !(RealPoint blk -> m blk)
      -- ^ Read a block from disk
    , LgrDB m blk -> TopLevelConfig blk
cfg            :: !(TopLevelConfig blk)
    , LgrDB m blk -> DiskPolicy
diskPolicy     :: !LedgerDB.DiskPolicy
    , LgrDB m blk -> SomeHasFS m
hasFS          :: !(SomeHasFS m)
    , LgrDB m blk -> Tracer m (TraceSnapshotEvent blk)
tracer         :: !(Tracer m (LedgerDB.TraceSnapshotEvent blk))
    } deriving ((forall x. LgrDB m blk -> Rep (LgrDB m blk) x)
-> (forall x. Rep (LgrDB m blk) x -> LgrDB m blk)
-> Generic (LgrDB m blk)
forall x. Rep (LgrDB m blk) x -> LgrDB m blk
forall x. LgrDB m blk -> Rep (LgrDB m blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) blk x. Rep (LgrDB m blk) x -> LgrDB m blk
forall (m :: * -> *) blk x. LgrDB m blk -> Rep (LgrDB m blk) x
$cto :: forall (m :: * -> *) blk x. Rep (LgrDB m blk) x -> LgrDB m blk
$cfrom :: forall (m :: * -> *) blk x. LgrDB m blk -> Rep (LgrDB m blk) x
Generic)

deriving instance (IOLike m, LedgerSupportsProtocol blk)
               => NoThunks (LgrDB m blk)
  -- use generic instance

-- | 'EncodeDisk' and 'DecodeDisk' constraints needed for the LgrDB.
type LgrDbSerialiseConstraints blk =
  ( Serialise      (HeaderHash  blk)
  , EncodeDisk blk (LedgerState blk)
  , DecodeDisk blk (LedgerState blk)
  , EncodeDisk blk (AnnTip      blk)
  , DecodeDisk blk (AnnTip      blk)
  , EncodeDisk blk (ChainDepState (BlockProtocol blk))
  , DecodeDisk blk (ChainDepState (BlockProtocol blk))
  )

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

data LgrDbArgs f m blk = LgrDbArgs {
      LgrDbArgs f m blk -> DiskPolicy
lgrDiskPolicy     :: LedgerDB.DiskPolicy
    , LgrDbArgs f m blk -> HKD f (m (ExtLedgerState blk))
lgrGenesis        :: HKD f (m (ExtLedgerState blk))
    , LgrDbArgs f m blk -> SomeHasFS m
lgrHasFS          :: SomeHasFS m
    , LgrDbArgs f m blk -> HKD f (TopLevelConfig blk)
lgrTopLevelConfig :: HKD f (TopLevelConfig blk)
    , LgrDbArgs f m blk -> Tracer m (LedgerDB' blk)
lgrTraceLedger    :: Tracer m (LedgerDB' blk)
    , LgrDbArgs f m blk -> Tracer m (TraceSnapshotEvent blk)
lgrTracer         :: Tracer m (LedgerDB.TraceSnapshotEvent blk)
    }

-- | Default arguments
defaultArgs ::
     Applicative m
  => SomeHasFS m
  -> LedgerDB.DiskPolicy
  -> LgrDbArgs Defaults m blk
defaultArgs :: SomeHasFS m -> DiskPolicy -> LgrDbArgs Defaults m blk
defaultArgs SomeHasFS m
lgrHasFS DiskPolicy
diskPolicy = LgrDbArgs :: forall (f :: * -> *) (m :: * -> *) blk.
DiskPolicy
-> HKD f (m (ExtLedgerState blk))
-> SomeHasFS m
-> HKD f (TopLevelConfig blk)
-> Tracer m (LedgerDB' blk)
-> Tracer m (TraceSnapshotEvent blk)
-> LgrDbArgs f m blk
LgrDbArgs {
      lgrDiskPolicy :: DiskPolicy
lgrDiskPolicy     = DiskPolicy
diskPolicy
    , lgrGenesis :: HKD Defaults (m (ExtLedgerState blk))
lgrGenesis        = HKD Defaults (m (ExtLedgerState blk))
forall t. Defaults t
NoDefault
    , SomeHasFS m
lgrHasFS :: SomeHasFS m
lgrHasFS :: SomeHasFS m
lgrHasFS
    , lgrTopLevelConfig :: HKD Defaults (TopLevelConfig blk)
lgrTopLevelConfig = HKD Defaults (TopLevelConfig blk)
forall t. Defaults t
NoDefault
    , lgrTraceLedger :: Tracer m (LedgerDB' blk)
lgrTraceLedger    = Tracer m (LedgerDB' blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , lgrTracer :: Tracer m (TraceSnapshotEvent blk)
lgrTracer         = Tracer m (TraceSnapshotEvent blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    }

-- | Open the ledger DB
--
-- In addition to the ledger DB also returns the number of immutable blocks
-- that were replayed.
openDB :: forall m blk.
          ( IOLike m
          , LedgerSupportsProtocol blk
          , LgrDbSerialiseConstraints blk
          , InspectLedger blk
          , HasCallStack
          )
       => LgrDbArgs Identity m blk
       -- ^ Stateless initializaton arguments
       -> Tracer m (LedgerDB.ReplayGoal blk -> LedgerDB.TraceReplayEvent blk)
       -- ^ Used to trace the progress while replaying blocks against the
       -- ledger.
       -> ImmutableDB m blk
       -- ^ Reference to the immutable DB
       --
       -- After reading a snapshot from disk, the ledger DB will be brought
       -- up to date with tip of the immutable DB. The corresponding ledger
       -- state can then be used as the starting point for chain selection in
       -- the ChainDB driver.
       -> (RealPoint blk -> m blk)
       -- ^ Read a block from disk
       --
       -- The block may be in the immutable DB or in the volatile DB; the ledger
       -- DB does not know where the boundary is at any given point.
       -> m (LgrDB m blk, Word64)
openDB :: LgrDbArgs Identity m blk
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> ImmutableDB m blk
-> (RealPoint blk -> m blk)
-> m (LgrDB m blk, Word64)
openDB args :: LgrDbArgs Identity m blk
args@LgrDbArgs { lgrHasFS :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> SomeHasFS m
lgrHasFS = lgrHasFS :: SomeHasFS m
lgrHasFS@(SomeHasFS HasFS m h
hasFS), Tracer m (LedgerDB' blk)
Tracer m (TraceSnapshotEvent blk)
DiskPolicy
HKD Identity (m (ExtLedgerState blk))
HKD Identity (TopLevelConfig blk)
lgrTracer :: Tracer m (TraceSnapshotEvent blk)
lgrTraceLedger :: Tracer m (LedgerDB' blk)
lgrTopLevelConfig :: HKD Identity (TopLevelConfig blk)
lgrGenesis :: HKD Identity (m (ExtLedgerState blk))
lgrDiskPolicy :: DiskPolicy
lgrTracer :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> Tracer m (TraceSnapshotEvent blk)
lgrTraceLedger :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> Tracer m (LedgerDB' blk)
lgrTopLevelConfig :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> HKD f (TopLevelConfig blk)
lgrGenesis :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> HKD f (m (ExtLedgerState blk))
lgrDiskPolicy :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> DiskPolicy
.. } Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
replayTracer ImmutableDB m blk
immutableDB RealPoint blk -> m blk
getBlock = do
    HasFS m h -> Bool -> FsPath -> m ()
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
createDirectoryIfMissing HasFS m h
hasFS Bool
True (Context -> FsPath
mkFsPath [])
    (LedgerDB' blk
db, Word64
replayed) <- LgrDbArgs Identity m blk
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> ImmutableDB m blk
-> m (LedgerDB' blk, Word64)
forall blk (m :: * -> *).
(IOLike m, LedgerSupportsProtocol blk,
 LgrDbSerialiseConstraints blk, InspectLedger blk, HasCallStack) =>
LgrDbArgs Identity m blk
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> ImmutableDB m blk
-> m (LedgerDB' blk, Word64)
initFromDisk LgrDbArgs Identity m blk
args Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
replayTracer ImmutableDB m blk
immutableDB
    -- When initializing the ledger DB from disk we:
    --
    -- - Look for the newest valid snapshot, say 'Lbs', which corresponds to the
    --   application of a block in the immutable DB, say 'b'.
    --
    -- - Push onto the ledger DB all the ledger states that result from applying
    --   blocks found in the on-disk immutable DB, starting from the successor
    --   of 'b'.
    --
    -- The anchor of 'LedgerDB' must be the oldest point we can rollback to. So
    -- if we follow the procedure described above (that 'initFromDisk'
    -- implements), the newest ledger state in 'db', say 'Lbn' corresponds to
    -- the most recent block in the immutable DB. If this block is in the
    -- immutable DB, it means that at some point it was part of a chain that was
    -- >k blocks long. Thus 'Lbn' is the oldest point we can roll back to.
    -- Therefore, we need to make the newest state (current) of the ledger DB
    -- the anchor.
    let dbPrunedToImmDBTip :: LedgerDB' blk
dbPrunedToImmDBTip = SecurityParam -> LedgerDB' blk -> LedgerDB' blk
forall l. GetTip l => SecurityParam -> LedgerDB l -> LedgerDB l
LedgerDB.ledgerDbPrune (Word64 -> SecurityParam
SecurityParam Word64
0) LedgerDB' blk
db
    (StrictTVar m (LedgerDB' blk)
varDB, StrictTVar m (Set (RealPoint blk))
varPrevApplied) <-
      (,) (StrictTVar m (LedgerDB' blk)
 -> StrictTVar m (Set (RealPoint blk))
 -> (StrictTVar m (LedgerDB' blk),
     StrictTVar m (Set (RealPoint blk))))
-> m (StrictTVar m (LedgerDB' blk))
-> m (StrictTVar m (Set (RealPoint blk))
      -> (StrictTVar m (LedgerDB' blk),
          StrictTVar m (Set (RealPoint blk))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerDB' blk -> m (StrictTVar m (LedgerDB' blk))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO LedgerDB' blk
dbPrunedToImmDBTip m (StrictTVar m (Set (RealPoint blk))
   -> (StrictTVar m (LedgerDB' blk),
       StrictTVar m (Set (RealPoint blk))))
-> m (StrictTVar m (Set (RealPoint blk)))
-> m (StrictTVar m (LedgerDB' blk),
      StrictTVar m (Set (RealPoint blk)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set (RealPoint blk) -> m (StrictTVar m (Set (RealPoint blk)))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Set (RealPoint blk)
forall a. Set a
Set.empty
    (LgrDB m blk, Word64) -> m (LgrDB m blk, Word64)
forall (m :: * -> *) a. Monad m => a -> m a
return (
        LgrDB :: forall (m :: * -> *) blk.
StrictTVar m (LedgerDB' blk)
-> StrictTVar m (Set (RealPoint blk))
-> (RealPoint blk -> m blk)
-> TopLevelConfig blk
-> DiskPolicy
-> SomeHasFS m
-> Tracer m (TraceSnapshotEvent blk)
-> LgrDB m blk
LgrDB {
            varDB :: StrictTVar m (LedgerDB' blk)
varDB          = StrictTVar m (LedgerDB' blk)
varDB
          , varPrevApplied :: StrictTVar m (Set (RealPoint blk))
varPrevApplied = StrictTVar m (Set (RealPoint blk))
varPrevApplied
          , resolveBlock :: RealPoint blk -> m blk
resolveBlock   = RealPoint blk -> m blk
getBlock
          , cfg :: TopLevelConfig blk
cfg            = HKD Identity (TopLevelConfig blk)
TopLevelConfig blk
lgrTopLevelConfig
          , diskPolicy :: DiskPolicy
diskPolicy     = DiskPolicy
lgrDiskPolicy
          , hasFS :: SomeHasFS m
hasFS          = SomeHasFS m
lgrHasFS
          , tracer :: Tracer m (TraceSnapshotEvent blk)
tracer         = Tracer m (TraceSnapshotEvent blk)
lgrTracer
          }
      , Word64
replayed
      )

initFromDisk
  :: forall blk m.
     ( IOLike m
     , LedgerSupportsProtocol blk
     , LgrDbSerialiseConstraints blk
     , InspectLedger blk
     , HasCallStack
     )
  => LgrDbArgs Identity m blk
  -> Tracer m (LedgerDB.ReplayGoal blk -> LedgerDB.TraceReplayEvent blk)
  -> ImmutableDB m blk
  -> m (LedgerDB' blk, Word64)
initFromDisk :: LgrDbArgs Identity m blk
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> ImmutableDB m blk
-> m (LedgerDB' blk, Word64)
initFromDisk LgrDbArgs { lgrHasFS :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> SomeHasFS m
lgrHasFS = SomeHasFS m
hasFS, Tracer m (LedgerDB' blk)
Tracer m (TraceSnapshotEvent blk)
DiskPolicy
HKD Identity (m (ExtLedgerState blk))
HKD Identity (TopLevelConfig blk)
lgrTracer :: Tracer m (TraceSnapshotEvent blk)
lgrTraceLedger :: Tracer m (LedgerDB' blk)
lgrTopLevelConfig :: HKD Identity (TopLevelConfig blk)
lgrGenesis :: HKD Identity (m (ExtLedgerState blk))
lgrDiskPolicy :: DiskPolicy
lgrTracer :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> Tracer m (TraceSnapshotEvent blk)
lgrTraceLedger :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> Tracer m (LedgerDB' blk)
lgrTopLevelConfig :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> HKD f (TopLevelConfig blk)
lgrGenesis :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> HKD f (m (ExtLedgerState blk))
lgrDiskPolicy :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> DiskPolicy
.. }
             Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
replayTracer
             ImmutableDB m blk
immutableDB = Proxy blk -> m (LedgerDB' blk, Word64) -> m (LedgerDB' blk, Word64)
forall (m :: * -> *) x blk.
(MonadCatch m, HasHeader blk) =>
Proxy blk -> m x -> m x
wrapFailure (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) (m (LedgerDB' blk, Word64) -> m (LedgerDB' blk, Word64))
-> m (LedgerDB' blk, Word64) -> m (LedgerDB' blk, Word64)
forall a b. (a -> b) -> a -> b
$ do
    (InitLog blk
_initLog, LedgerDB' blk
db, Word64
replayed) <-
      Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (HeaderHash blk))
-> LedgerDbCfg (ExtLedgerState blk)
-> m (ExtLedgerState blk)
-> StreamAPI m blk
-> m (InitLog blk, LedgerDB' blk, Word64)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (HeaderHash blk))
-> LedgerDbCfg (ExtLedgerState blk)
-> m (ExtLedgerState blk)
-> StreamAPI m blk
-> m (InitLog blk, LedgerDB' blk, Word64)
LedgerDB.initLedgerDB
        Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
replayTracer
        Tracer m (TraceSnapshotEvent blk)
lgrTracer
        SomeHasFS m
hasFS
        forall s. Decoder s (ExtLedgerState blk)
decodeExtLedgerState'
        forall s. Decoder s (HeaderHash blk)
forall a s. Serialise a => Decoder s a
decode
        (TopLevelConfig blk -> LedgerDbCfg (ExtLedgerState blk)
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> LedgerDbCfg (ExtLedgerState blk)
LedgerDB.configLedgerDb HKD Identity (TopLevelConfig blk)
TopLevelConfig blk
lgrTopLevelConfig)
        m (ExtLedgerState blk)
HKD Identity (m (ExtLedgerState blk))
lgrGenesis
        (ImmutableDB m blk -> StreamAPI m blk
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
ImmutableDB m blk -> StreamAPI m blk
streamAPI ImmutableDB m blk
immutableDB)
    (LedgerDB' blk, Word64) -> m (LedgerDB' blk, Word64)
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerDB' blk
db, Word64
replayed)
  where
    ccfg :: CodecConfig blk
ccfg = TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec HKD Identity (TopLevelConfig blk)
TopLevelConfig blk
lgrTopLevelConfig

    decodeExtLedgerState' :: forall s. Decoder s (ExtLedgerState blk)
    decodeExtLedgerState' :: Decoder s (ExtLedgerState blk)
decodeExtLedgerState' = (forall s. Decoder s (LedgerState blk))
-> (forall s. Decoder s (ChainDepState (BlockProtocol blk)))
-> (forall s. Decoder s (AnnTip blk))
-> forall s. Decoder s (ExtLedgerState blk)
forall blk.
(forall s. Decoder s (LedgerState blk))
-> (forall s. Decoder s (ChainDepState (BlockProtocol blk)))
-> (forall s. Decoder s (AnnTip blk))
-> forall s. Decoder s (ExtLedgerState blk)
decodeExtLedgerState
                              (CodecConfig blk -> forall s. Decoder s (LedgerState blk)
forall blk a.
DecodeDisk blk a =>
CodecConfig blk -> forall s. Decoder s a
decodeDisk CodecConfig blk
ccfg)
                              (CodecConfig blk
-> forall s. Decoder s (ChainDepState (BlockProtocol blk))
forall blk a.
DecodeDisk blk a =>
CodecConfig blk -> forall s. Decoder s a
decodeDisk CodecConfig blk
ccfg)
                              (CodecConfig blk -> forall s. Decoder s (AnnTip blk)
forall blk a.
DecodeDisk blk a =>
CodecConfig blk -> forall s. Decoder s a
decodeDisk CodecConfig blk
ccfg)

-- | For testing purposes
mkLgrDB :: StrictTVar m (LedgerDB' blk)
        -> StrictTVar m (Set (RealPoint blk))
        -> (RealPoint blk -> m blk)
        -> LgrDbArgs Identity m blk
        -> LgrDB m blk
mkLgrDB :: StrictTVar m (LedgerDB' blk)
-> StrictTVar m (Set (RealPoint blk))
-> (RealPoint blk -> m blk)
-> LgrDbArgs Identity m blk
-> LgrDB m blk
mkLgrDB StrictTVar m (LedgerDB' blk)
varDB StrictTVar m (Set (RealPoint blk))
varPrevApplied RealPoint blk -> m blk
resolveBlock LgrDbArgs Identity m blk
args = LgrDB :: forall (m :: * -> *) blk.
StrictTVar m (LedgerDB' blk)
-> StrictTVar m (Set (RealPoint blk))
-> (RealPoint blk -> m blk)
-> TopLevelConfig blk
-> DiskPolicy
-> SomeHasFS m
-> Tracer m (TraceSnapshotEvent blk)
-> LgrDB m blk
LgrDB {StrictTVar m (Set (RealPoint blk))
StrictTVar m (LedgerDB' blk)
Tracer m (TraceSnapshotEvent blk)
SomeHasFS m
DiskPolicy
HKD Identity (TopLevelConfig blk)
TopLevelConfig blk
RealPoint blk -> m blk
tracer :: Tracer m (TraceSnapshotEvent blk)
hasFS :: SomeHasFS m
diskPolicy :: DiskPolicy
cfg :: HKD Identity (TopLevelConfig blk)
resolveBlock :: RealPoint blk -> m blk
varPrevApplied :: StrictTVar m (Set (RealPoint blk))
varDB :: StrictTVar m (LedgerDB' blk)
tracer :: Tracer m (TraceSnapshotEvent blk)
hasFS :: SomeHasFS m
diskPolicy :: DiskPolicy
cfg :: TopLevelConfig blk
resolveBlock :: RealPoint blk -> m blk
varPrevApplied :: StrictTVar m (Set (RealPoint blk))
varDB :: StrictTVar m (LedgerDB' blk)
..}
  where
    LgrDbArgs {
        lgrTopLevelConfig :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> HKD f (TopLevelConfig blk)
lgrTopLevelConfig = HKD Identity (TopLevelConfig blk)
cfg
      , lgrDiskPolicy :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> DiskPolicy
lgrDiskPolicy     = DiskPolicy
diskPolicy
      , lgrHasFS :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> SomeHasFS m
lgrHasFS          = SomeHasFS m
hasFS
      , lgrTracer :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> Tracer m (TraceSnapshotEvent blk)
lgrTracer         = Tracer m (TraceSnapshotEvent blk)
tracer
      } = LgrDbArgs Identity m blk
args

{-------------------------------------------------------------------------------
  Wrappers
-------------------------------------------------------------------------------}

getCurrent :: IOLike m => LgrDB m blk -> STM m (LedgerDB' blk)
getCurrent :: LgrDB m blk -> STM m (LedgerDB' blk)
getCurrent LgrDB{StrictTVar m (Set (RealPoint blk))
StrictTVar m (LedgerDB' blk)
Tracer m (TraceSnapshotEvent blk)
SomeHasFS m
DiskPolicy
TopLevelConfig blk
RealPoint blk -> m blk
tracer :: Tracer m (TraceSnapshotEvent blk)
hasFS :: SomeHasFS m
diskPolicy :: DiskPolicy
cfg :: TopLevelConfig blk
resolveBlock :: RealPoint blk -> m blk
varPrevApplied :: StrictTVar m (Set (RealPoint blk))
varDB :: StrictTVar m (LedgerDB' blk)
tracer :: forall (m :: * -> *) blk.
LgrDB m blk -> Tracer m (TraceSnapshotEvent blk)
hasFS :: forall (m :: * -> *) blk. LgrDB m blk -> SomeHasFS m
diskPolicy :: forall (m :: * -> *) blk. LgrDB m blk -> DiskPolicy
cfg :: forall (m :: * -> *) blk. LgrDB m blk -> TopLevelConfig blk
resolveBlock :: forall (m :: * -> *) blk. LgrDB m blk -> RealPoint blk -> m blk
varPrevApplied :: forall (m :: * -> *) blk.
LgrDB m blk -> StrictTVar m (Set (RealPoint blk))
varDB :: forall (m :: * -> *) blk.
LgrDB m blk -> StrictTVar m (LedgerDB' blk)
..} = StrictTVar m (LedgerDB' blk) -> STM m (LedgerDB' blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (LedgerDB' blk)
varDB

-- | PRECONDITION: The new 'LedgerDB' must be the result of calling either
-- 'LedgerDB.ledgerDbSwitch' or 'LedgerDB.ledgerDbPushMany' on the current
-- 'LedgerDB'.
setCurrent :: IOLike m => LgrDB m blk -> LedgerDB' blk -> STM m ()
setCurrent :: LgrDB m blk -> LedgerDB' blk -> STM m ()
setCurrent LgrDB{StrictTVar m (Set (RealPoint blk))
StrictTVar m (LedgerDB' blk)
Tracer m (TraceSnapshotEvent blk)
SomeHasFS m
DiskPolicy
TopLevelConfig blk
RealPoint blk -> m blk
tracer :: Tracer m (TraceSnapshotEvent blk)
hasFS :: SomeHasFS m
diskPolicy :: DiskPolicy
cfg :: TopLevelConfig blk
resolveBlock :: RealPoint blk -> m blk
varPrevApplied :: StrictTVar m (Set (RealPoint blk))
varDB :: StrictTVar m (LedgerDB' blk)
tracer :: forall (m :: * -> *) blk.
LgrDB m blk -> Tracer m (TraceSnapshotEvent blk)
hasFS :: forall (m :: * -> *) blk. LgrDB m blk -> SomeHasFS m
diskPolicy :: forall (m :: * -> *) blk. LgrDB m blk -> DiskPolicy
cfg :: forall (m :: * -> *) blk. LgrDB m blk -> TopLevelConfig blk
resolveBlock :: forall (m :: * -> *) blk. LgrDB m blk -> RealPoint blk -> m blk
varPrevApplied :: forall (m :: * -> *) blk.
LgrDB m blk -> StrictTVar m (Set (RealPoint blk))
varDB :: forall (m :: * -> *) blk.
LgrDB m blk -> StrictTVar m (LedgerDB' blk)
..} = StrictTVar m (LedgerDB' blk) -> LedgerDB' blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (StrictTVar m (LedgerDB' blk) -> LedgerDB' blk -> STM m ())
-> StrictTVar m (LedgerDB' blk) -> LedgerDB' blk -> STM m ()
forall a b. (a -> b) -> a -> b
$! StrictTVar m (LedgerDB' blk)
varDB

currentPoint :: forall blk. UpdateLedger blk => LedgerDB' blk -> Point blk
currentPoint :: LedgerDB' blk -> Point blk
currentPoint = Point blk -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint
             (Point blk -> Point blk)
-> (LedgerDB' blk -> Point blk) -> LedgerDB' blk -> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState blk -> Point blk
forall blk. UpdateLedger blk => LedgerState blk -> Point blk
ledgerTipPoint
             (LedgerState blk -> Point blk)
-> (LedgerDB' blk -> LedgerState blk) -> LedgerDB' blk -> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState
             (ExtLedgerState blk -> LedgerState blk)
-> (LedgerDB' blk -> ExtLedgerState blk)
-> LedgerDB' blk
-> LedgerState blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDB' blk -> ExtLedgerState blk
forall l. GetTip l => LedgerDB l -> l
LedgerDB.ledgerDbCurrent

takeSnapshot ::
     forall m blk.
     ( IOLike m
     , LgrDbSerialiseConstraints blk
     , HasHeader blk
     , IsLedger (LedgerState blk)
     )
  => LgrDB m blk -> m (Maybe (LedgerDB.DiskSnapshot, RealPoint blk))
takeSnapshot :: LgrDB m blk -> m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot lgrDB :: LgrDB m blk
lgrDB@LgrDB{ TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg :: forall (m :: * -> *) blk. LgrDB m blk -> TopLevelConfig blk
cfg, Tracer m (TraceSnapshotEvent blk)
tracer :: Tracer m (TraceSnapshotEvent blk)
tracer :: forall (m :: * -> *) blk.
LgrDB m blk -> Tracer m (TraceSnapshotEvent blk)
tracer, SomeHasFS m
hasFS :: SomeHasFS m
hasFS :: forall (m :: * -> *) blk. LgrDB m blk -> SomeHasFS m
hasFS } = Proxy blk
-> m (Maybe (DiskSnapshot, RealPoint blk))
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) x blk.
(MonadCatch m, HasHeader blk) =>
Proxy blk -> m x -> m x
wrapFailure (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) (m (Maybe (DiskSnapshot, RealPoint blk))
 -> m (Maybe (DiskSnapshot, RealPoint blk)))
-> m (Maybe (DiskSnapshot, RealPoint blk))
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall a b. (a -> b) -> a -> b
$ do
    ExtLedgerState blk
ledgerDB <- LedgerDB (ExtLedgerState blk) -> ExtLedgerState blk
forall l. LedgerDB l -> l
LedgerDB.ledgerDbAnchor (LedgerDB (ExtLedgerState blk) -> ExtLedgerState blk)
-> m (LedgerDB (ExtLedgerState blk)) -> m (ExtLedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (LedgerDB (ExtLedgerState blk))
-> m (LedgerDB (ExtLedgerState blk))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (LgrDB m blk -> STM m (LedgerDB (ExtLedgerState blk))
forall (m :: * -> *) blk.
IOLike m =>
LgrDB m blk -> STM m (LedgerDB' blk)
getCurrent LgrDB m blk
lgrDB)
    Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> (ExtLedgerState blk -> Encoding)
-> ExtLedgerState blk
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) blk.
(MonadThrow m, IsLedger (LedgerState blk)) =>
Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> (ExtLedgerState blk -> Encoding)
-> ExtLedgerState blk
-> m (Maybe (DiskSnapshot, RealPoint blk))
LedgerDB.takeSnapshot
      Tracer m (TraceSnapshotEvent blk)
tracer
      SomeHasFS m
hasFS
      ExtLedgerState blk -> Encoding
encodeExtLedgerState'
      ExtLedgerState blk
ledgerDB
  where
    ccfg :: CodecConfig blk
ccfg = TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec TopLevelConfig blk
cfg

    encodeExtLedgerState' :: ExtLedgerState blk -> Encoding
    encodeExtLedgerState' :: ExtLedgerState blk -> Encoding
encodeExtLedgerState' = (LedgerState blk -> Encoding)
-> (ChainDepState (BlockProtocol blk) -> Encoding)
-> (AnnTip blk -> Encoding)
-> ExtLedgerState blk
-> Encoding
forall blk.
(LedgerState blk -> Encoding)
-> (ChainDepState (BlockProtocol blk) -> Encoding)
-> (AnnTip blk -> Encoding)
-> ExtLedgerState blk
-> Encoding
encodeExtLedgerState
                              (CodecConfig blk -> LedgerState blk -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig blk
ccfg)
                              (CodecConfig blk -> ChainDepState (BlockProtocol blk) -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig blk
ccfg)
                              (CodecConfig blk -> AnnTip blk -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig blk
ccfg)

trimSnapshots ::
     forall m blk. (MonadCatch m, HasHeader blk)
  => LgrDB m blk
  -> m [LedgerDB.DiskSnapshot]
trimSnapshots :: LgrDB m blk -> m [DiskSnapshot]
trimSnapshots LgrDB { DiskPolicy
diskPolicy :: DiskPolicy
diskPolicy :: forall (m :: * -> *) blk. LgrDB m blk -> DiskPolicy
diskPolicy, Tracer m (TraceSnapshotEvent blk)
tracer :: Tracer m (TraceSnapshotEvent blk)
tracer :: forall (m :: * -> *) blk.
LgrDB m blk -> Tracer m (TraceSnapshotEvent blk)
tracer, SomeHasFS m
hasFS :: SomeHasFS m
hasFS :: forall (m :: * -> *) blk. LgrDB m blk -> SomeHasFS m
hasFS } = Proxy blk -> m [DiskSnapshot] -> m [DiskSnapshot]
forall (m :: * -> *) x blk.
(MonadCatch m, HasHeader blk) =>
Proxy blk -> m x -> m x
wrapFailure (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) (m [DiskSnapshot] -> m [DiskSnapshot])
-> m [DiskSnapshot] -> m [DiskSnapshot]
forall a b. (a -> b) -> a -> b
$
    Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m -> DiskPolicy -> m [DiskSnapshot]
forall (m :: * -> *) r.
Monad m =>
Tracer m (TraceSnapshotEvent r)
-> SomeHasFS m -> DiskPolicy -> m [DiskSnapshot]
LedgerDB.trimSnapshots Tracer m (TraceSnapshotEvent blk)
tracer SomeHasFS m
hasFS DiskPolicy
diskPolicy

getDiskPolicy :: LgrDB m blk -> LedgerDB.DiskPolicy
getDiskPolicy :: LgrDB m blk -> DiskPolicy
getDiskPolicy = LgrDB m blk -> DiskPolicy
forall (m :: * -> *) blk. LgrDB m blk -> DiskPolicy
diskPolicy

{-------------------------------------------------------------------------------
  Validation
-------------------------------------------------------------------------------}

data ValidateResult blk =
    ValidateSuccessful       (LedgerDB'       blk)
  | ValidateLedgerError      (LedgerDB.AnnLedgerError' blk)
  | ValidateExceededRollBack LedgerDB.ExceededRollback

validate :: forall m blk. (IOLike m, LedgerSupportsProtocol blk, HasCallStack)
         => LgrDB m blk
         -> LedgerDB' blk
            -- ^ This is used as the starting point for validation, not the one
            -- in the 'LgrDB'.
         -> BlockCache blk
         -> Word64  -- ^ How many blocks to roll back
         -> (LedgerDB.UpdateLedgerDbTraceEvent blk -> m ())
         -> [Header blk]
         -> m (ValidateResult blk)
validate :: LgrDB m blk
-> LedgerDB' blk
-> BlockCache blk
-> Word64
-> (UpdateLedgerDbTraceEvent blk -> m ())
-> [Header blk]
-> m (ValidateResult blk)
validate LgrDB{StrictTVar m (Set (RealPoint blk))
StrictTVar m (LedgerDB' blk)
Tracer m (TraceSnapshotEvent blk)
SomeHasFS m
DiskPolicy
TopLevelConfig blk
RealPoint blk -> m blk
tracer :: Tracer m (TraceSnapshotEvent blk)
hasFS :: SomeHasFS m
diskPolicy :: DiskPolicy
cfg :: TopLevelConfig blk
resolveBlock :: RealPoint blk -> m blk
varPrevApplied :: StrictTVar m (Set (RealPoint blk))
varDB :: StrictTVar m (LedgerDB' blk)
tracer :: forall (m :: * -> *) blk.
LgrDB m blk -> Tracer m (TraceSnapshotEvent blk)
hasFS :: forall (m :: * -> *) blk. LgrDB m blk -> SomeHasFS m
diskPolicy :: forall (m :: * -> *) blk. LgrDB m blk -> DiskPolicy
cfg :: forall (m :: * -> *) blk. LgrDB m blk -> TopLevelConfig blk
resolveBlock :: forall (m :: * -> *) blk. LgrDB m blk -> RealPoint blk -> m blk
varPrevApplied :: forall (m :: * -> *) blk.
LgrDB m blk -> StrictTVar m (Set (RealPoint blk))
varDB :: forall (m :: * -> *) blk.
LgrDB m blk -> StrictTVar m (LedgerDB' blk)
..} LedgerDB' blk
ledgerDB BlockCache blk
blockCache Word64
numRollbacks UpdateLedgerDbTraceEvent blk -> m ()
trace = \[Header blk]
hdrs -> do
    [Ap
   (ExceptT
      (AnnLedgerError (ExtLedgerState blk) blk)
      (ReaderT (RealPoint blk -> m blk) m))
   (ExtLedgerState blk)
   blk
   (ResolvesBlocks
      (ExceptT
         (AnnLedgerError (ExtLedgerState blk) blk)
         (ReaderT (RealPoint blk -> m blk) m))
      blk,
    ThrowsLedgerError
      (ExceptT
         (AnnLedgerError (ExtLedgerState blk) blk)
         (ReaderT (RealPoint blk -> m blk) m))
      (ExtLedgerState blk)
      blk)]
aps <- [Header blk]
-> Set (RealPoint blk)
-> [Ap
      (ExceptT
         (AnnLedgerError (ExtLedgerState blk) blk)
         (ReaderT (RealPoint blk -> m blk) m))
      (ExtLedgerState blk)
      blk
      (ResolvesBlocks
         (ExceptT
            (AnnLedgerError (ExtLedgerState blk) blk)
            (ReaderT (RealPoint blk -> m blk) m))
         blk,
       ThrowsLedgerError
         (ExceptT
            (AnnLedgerError (ExtLedgerState blk) blk)
            (ReaderT (RealPoint blk -> m blk) m))
         (ExtLedgerState blk)
         blk)]
forall (n :: * -> *) l.
(l ~ ExtLedgerState blk) =>
[Header blk]
-> Set (RealPoint blk)
-> [Ap n l blk (ResolvesBlocks n blk, ThrowsLedgerError n l blk)]
mkAps [Header blk]
hdrs (Set (RealPoint blk)
 -> [Ap
       (ExceptT
          (AnnLedgerError (ExtLedgerState blk) blk)
          (ReaderT (RealPoint blk -> m blk) m))
       (ExtLedgerState blk)
       blk
       (ResolvesBlocks
          (ExceptT
             (AnnLedgerError (ExtLedgerState blk) blk)
             (ReaderT (RealPoint blk -> m blk) m))
          blk,
        ThrowsLedgerError
          (ExceptT
             (AnnLedgerError (ExtLedgerState blk) blk)
             (ReaderT (RealPoint blk -> m blk) m))
          (ExtLedgerState blk)
          blk)])
-> m (Set (RealPoint blk))
-> m [Ap
        (ExceptT
           (AnnLedgerError (ExtLedgerState blk) blk)
           (ReaderT (RealPoint blk -> m blk) m))
        (ExtLedgerState blk)
        blk
        (ResolvesBlocks
           (ExceptT
              (AnnLedgerError (ExtLedgerState blk) blk)
              (ReaderT (RealPoint blk -> m blk) m))
           blk,
         ThrowsLedgerError
           (ExceptT
              (AnnLedgerError (ExtLedgerState blk) blk)
              (ReaderT (RealPoint blk -> m blk) m))
           (ExtLedgerState blk)
           blk)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (Set (RealPoint blk)) -> m (Set (RealPoint blk))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (Set (RealPoint blk)) -> STM m (Set (RealPoint blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Set (RealPoint blk))
varPrevApplied)
    ValidateResult blk
res <- (Either
   (AnnLedgerError (ExtLedgerState blk) blk)
   (Either ExceededRollback (LedgerDB' blk))
 -> ValidateResult blk)
-> m (Either
        (AnnLedgerError (ExtLedgerState blk) blk)
        (Either ExceededRollback (LedgerDB' blk)))
-> m (ValidateResult blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either
  (AnnLedgerError (ExtLedgerState blk) blk)
  (Either ExceededRollback (LedgerDB' blk))
-> ValidateResult blk
rewrap (m (Either
      (AnnLedgerError (ExtLedgerState blk) blk)
      (Either ExceededRollback (LedgerDB' blk)))
 -> m (ValidateResult blk))
-> m (Either
        (AnnLedgerError (ExtLedgerState blk) blk)
        (Either ExceededRollback (LedgerDB' blk)))
-> m (ValidateResult blk)
forall a b. (a -> b) -> a -> b
$ (RealPoint blk -> m blk)
-> ExceptT
     (AnnLedgerError (ExtLedgerState blk) blk)
     (ReaderT (RealPoint blk -> m blk) m)
     (Either ExceededRollback (LedgerDB' blk))
-> m (Either
        (AnnLedgerError (ExtLedgerState blk) blk)
        (Either ExceededRollback (LedgerDB' blk)))
forall (m :: * -> *) blk l a.
ResolveBlock m blk
-> ExceptT
     (AnnLedgerError l blk) (ReaderT (ResolveBlock m blk) m) a
-> m (Either (AnnLedgerError l blk) a)
LedgerDB.defaultResolveWithErrors RealPoint blk -> m blk
resolveBlock (ExceptT
   (AnnLedgerError (ExtLedgerState blk) blk)
   (ReaderT (RealPoint blk -> m blk) m)
   (Either ExceededRollback (LedgerDB' blk))
 -> m (Either
         (AnnLedgerError (ExtLedgerState blk) blk)
         (Either ExceededRollback (LedgerDB' blk))))
-> ExceptT
     (AnnLedgerError (ExtLedgerState blk) blk)
     (ReaderT (RealPoint blk -> m blk) m)
     (Either ExceededRollback (LedgerDB' blk))
-> m (Either
        (AnnLedgerError (ExtLedgerState blk) blk)
        (Either ExceededRollback (LedgerDB' blk)))
forall a b. (a -> b) -> a -> b
$
             LedgerDbCfg (ExtLedgerState blk)
-> Word64
-> (UpdateLedgerDbTraceEvent blk
    -> ExceptT
         (AnnLedgerError (ExtLedgerState blk) blk)
         (ReaderT (RealPoint blk -> m blk) m)
         ())
-> [Ap
      (ExceptT
         (AnnLedgerError (ExtLedgerState blk) blk)
         (ReaderT (RealPoint blk -> m blk) m))
      (ExtLedgerState blk)
      blk
      (ResolvesBlocks
         (ExceptT
            (AnnLedgerError (ExtLedgerState blk) blk)
            (ReaderT (RealPoint blk -> m blk) m))
         blk,
       ThrowsLedgerError
         (ExceptT
            (AnnLedgerError (ExtLedgerState blk) blk)
            (ReaderT (RealPoint blk -> m blk) m))
         (ExtLedgerState blk)
         blk)]
-> LedgerDB' blk
-> ExceptT
     (AnnLedgerError (ExtLedgerState blk) blk)
     (ReaderT (RealPoint blk -> m blk) m)
     (Either ExceededRollback (LedgerDB' blk))
forall l blk (m :: * -> *) (c :: Constraint).
(ApplyBlock l blk, Monad m, c) =>
LedgerDbCfg l
-> Word64
-> (UpdateLedgerDbTraceEvent blk -> m ())
-> [Ap m l blk c]
-> LedgerDB l
-> m (Either ExceededRollback (LedgerDB l))
LedgerDB.ledgerDbSwitch
               (TopLevelConfig blk -> LedgerDbCfg (ExtLedgerState blk)
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> LedgerDbCfg (ExtLedgerState blk)
LedgerDB.configLedgerDb TopLevelConfig blk
cfg)
               Word64
numRollbacks
               (ReaderT (RealPoint blk -> m blk) m ()
-> ExceptT
     (AnnLedgerError (ExtLedgerState blk) blk)
     (ReaderT (RealPoint blk -> m blk) m)
     ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (RealPoint blk -> m blk) m ()
 -> ExceptT
      (AnnLedgerError (ExtLedgerState blk) blk)
      (ReaderT (RealPoint blk -> m blk) m)
      ())
-> (UpdateLedgerDbTraceEvent blk
    -> ReaderT (RealPoint blk -> m blk) m ())
-> UpdateLedgerDbTraceEvent blk
-> ExceptT
     (AnnLedgerError (ExtLedgerState blk) blk)
     (ReaderT (RealPoint blk -> m blk) m)
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> ReaderT (RealPoint blk -> m blk) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT (RealPoint blk -> m blk) m ())
-> (UpdateLedgerDbTraceEvent blk -> m ())
-> UpdateLedgerDbTraceEvent blk
-> ReaderT (RealPoint blk -> m blk) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateLedgerDbTraceEvent blk -> m ()
trace)
               [Ap
   (ExceptT
      (AnnLedgerError (ExtLedgerState blk) blk)
      (ReaderT (RealPoint blk -> m blk) m))
   (ExtLedgerState blk)
   blk
   (ResolvesBlocks
      (ExceptT
         (AnnLedgerError (ExtLedgerState blk) blk)
         (ReaderT (RealPoint blk -> m blk) m))
      blk,
    ThrowsLedgerError
      (ExceptT
         (AnnLedgerError (ExtLedgerState blk) blk)
         (ReaderT (RealPoint blk -> m blk) m))
      (ExtLedgerState blk)
      blk)]
aps
               LedgerDB' blk
ledgerDB
    STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Set (RealPoint blk))
-> (Set (RealPoint blk) -> Set (RealPoint blk)) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Set (RealPoint blk))
varPrevApplied ((Set (RealPoint blk) -> Set (RealPoint blk)) -> STM m ())
-> (Set (RealPoint blk) -> Set (RealPoint blk)) -> STM m ()
forall a b. (a -> b) -> a -> b
$
      [RealPoint blk] -> Set (RealPoint blk) -> Set (RealPoint blk)
addPoints (ValidateResult blk -> [RealPoint blk] -> [RealPoint blk]
validBlockPoints ValidateResult blk
res ((Header blk -> RealPoint blk) -> [Header blk] -> [RealPoint blk]
forall a b. (a -> b) -> [a] -> [b]
map Header blk -> RealPoint blk
forall blk. HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint [Header blk]
hdrs))
    ValidateResult blk -> m (ValidateResult blk)
forall (m :: * -> *) a. Monad m => a -> m a
return ValidateResult blk
res
  where
    rewrap :: Either (LedgerDB.AnnLedgerError' blk) (Either LedgerDB.ExceededRollback (LedgerDB' blk))
           -> ValidateResult blk
    rewrap :: Either
  (AnnLedgerError (ExtLedgerState blk) blk)
  (Either ExceededRollback (LedgerDB' blk))
-> ValidateResult blk
rewrap (Left         AnnLedgerError (ExtLedgerState blk) blk
e)  = AnnLedgerError (ExtLedgerState blk) blk -> ValidateResult blk
forall blk. AnnLedgerError' blk -> ValidateResult blk
ValidateLedgerError      AnnLedgerError (ExtLedgerState blk) blk
e
    rewrap (Right (Left  ExceededRollback
e)) = ExceededRollback -> ValidateResult blk
forall blk. ExceededRollback -> ValidateResult blk
ValidateExceededRollBack ExceededRollback
e
    rewrap (Right (Right LedgerDB' blk
l)) = LedgerDB' blk -> ValidateResult blk
forall blk. LedgerDB' blk -> ValidateResult blk
ValidateSuccessful       LedgerDB' blk
l

    mkAps :: forall n l. l ~ ExtLedgerState blk
          => [Header blk]
          -> Set (RealPoint blk)
          -> [LedgerDB.Ap n l blk ( LedgerDB.ResolvesBlocks    n   blk
                                  , LedgerDB.ThrowsLedgerError n l blk
                                  )]
    mkAps :: [Header blk]
-> Set (RealPoint blk)
-> [Ap n l blk (ResolvesBlocks n blk, ThrowsLedgerError n l blk)]
mkAps [Header blk]
hdrs Set (RealPoint blk)
prevApplied =
      [ case ( RealPoint blk -> Set (RealPoint blk) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Header blk -> RealPoint blk
forall blk. HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint Header blk
hdr) Set (RealPoint blk)
prevApplied
             , HeaderHash blk -> BlockCache blk -> Maybe blk
forall blk.
HasHeader blk =>
HeaderHash blk -> BlockCache blk -> Maybe blk
BlockCache.lookup (Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr) BlockCache blk
blockCache
             ) of
          (Bool
False, Maybe blk
Nothing)  ->                   RealPoint blk
-> Ap n l blk (ResolvesBlocks n blk, ThrowsLedgerError n l blk)
forall blk (m :: * -> *) l.
RealPoint blk
-> Ap m l blk (ResolvesBlocks m blk, ThrowsLedgerError m l blk)
LedgerDB.ApplyRef   (Header blk -> RealPoint blk
forall blk. HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint Header blk
hdr)
          (Bool
True,  Maybe blk
Nothing)  -> Ap n l blk (ResolvesBlocks n blk)
-> Ap n l blk (ResolvesBlocks n blk, ThrowsLedgerError n l blk)
forall (c' :: Constraint) (c :: Constraint) (m :: * -> *) l blk.
(c' => c) =>
Ap m l blk c -> Ap m l blk c'
LedgerDB.Weaken (Ap n l blk (ResolvesBlocks n blk)
 -> Ap n l blk (ResolvesBlocks n blk, ThrowsLedgerError n l blk))
-> Ap n l blk (ResolvesBlocks n blk)
-> Ap n l blk (ResolvesBlocks n blk, ThrowsLedgerError n l blk)
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> Ap n l blk (ResolvesBlocks n blk)
forall blk (m :: * -> *) l.
RealPoint blk -> Ap m l blk (ResolvesBlocks m blk)
LedgerDB.ReapplyRef (Header blk -> RealPoint blk
forall blk. HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint Header blk
hdr)
          (Bool
False, Just blk
blk) -> Ap n l blk (ThrowsLedgerError n l blk)
-> Ap n l blk (ResolvesBlocks n blk, ThrowsLedgerError n l blk)
forall (c' :: Constraint) (c :: Constraint) (m :: * -> *) l blk.
(c' => c) =>
Ap m l blk c -> Ap m l blk c'
LedgerDB.Weaken (Ap n l blk (ThrowsLedgerError n l blk)
 -> Ap n l blk (ResolvesBlocks n blk, ThrowsLedgerError n l blk))
-> Ap n l blk (ThrowsLedgerError n l blk)
-> Ap n l blk (ResolvesBlocks n blk, ThrowsLedgerError n l blk)
forall a b. (a -> b) -> a -> b
$ blk -> Ap n l blk (ThrowsLedgerError n l blk)
forall blk (m :: * -> *) l.
blk -> Ap m l blk (ThrowsLedgerError m l blk)
LedgerDB.ApplyVal   blk
blk
          (Bool
True,  Just blk
blk) -> Ap n l blk (() :: Constraint)
-> Ap n l blk (ResolvesBlocks n blk, ThrowsLedgerError n l blk)
forall (c' :: Constraint) (c :: Constraint) (m :: * -> *) l blk.
(c' => c) =>
Ap m l blk c -> Ap m l blk c'
LedgerDB.Weaken (Ap n l blk (() :: Constraint)
 -> Ap n l blk (ResolvesBlocks n blk, ThrowsLedgerError n l blk))
-> Ap n l blk (() :: Constraint)
-> Ap n l blk (ResolvesBlocks n blk, ThrowsLedgerError n l blk)
forall a b. (a -> b) -> a -> b
$ blk -> Ap n l blk (() :: Constraint)
forall blk (m :: * -> *) l. blk -> Ap m l blk (() :: Constraint)
LedgerDB.ReapplyVal blk
blk
      | Header blk
hdr <- [Header blk]
hdrs
      ]

    -- | Based on the 'ValidateResult', return the hashes corresponding to
    -- valid blocks.
    validBlockPoints :: ValidateResult blk -> [RealPoint blk] -> [RealPoint blk]
    validBlockPoints :: ValidateResult blk -> [RealPoint blk] -> [RealPoint blk]
validBlockPoints = \case
      ValidateExceededRollBack ExceededRollback
_ -> [RealPoint blk] -> [RealPoint blk] -> [RealPoint blk]
forall a b. a -> b -> a
const []
      ValidateSuccessful       LedgerDB' blk
_ -> [RealPoint blk] -> [RealPoint blk]
forall a. a -> a
id
      ValidateLedgerError      AnnLedgerError (ExtLedgerState blk) blk
e -> (RealPoint blk -> Bool) -> [RealPoint blk] -> [RealPoint blk]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (RealPoint blk -> RealPoint blk -> Bool
forall a. Eq a => a -> a -> Bool
/= AnnLedgerError (ExtLedgerState blk) blk -> RealPoint blk
forall l blk. AnnLedgerError l blk -> RealPoint blk
LedgerDB.annLedgerErrRef AnnLedgerError (ExtLedgerState blk) blk
e)

    addPoints :: [RealPoint blk]
              -> Set (RealPoint blk) -> Set (RealPoint blk)
    addPoints :: [RealPoint blk] -> Set (RealPoint blk) -> Set (RealPoint blk)
addPoints [RealPoint blk]
hs Set (RealPoint blk)
set = (Set (RealPoint blk) -> RealPoint blk -> Set (RealPoint blk))
-> Set (RealPoint blk) -> [RealPoint blk] -> Set (RealPoint blk)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((RealPoint blk -> Set (RealPoint blk) -> Set (RealPoint blk))
-> Set (RealPoint blk) -> RealPoint blk -> Set (RealPoint blk)
forall a b c. (a -> b -> c) -> b -> a -> c
flip RealPoint blk -> Set (RealPoint blk) -> Set (RealPoint blk)
forall a. Ord a => a -> Set a -> Set a
Set.insert) Set (RealPoint blk)
set [RealPoint blk]
hs

{-------------------------------------------------------------------------------
  Stream API to the immutable DB
-------------------------------------------------------------------------------}

streamAPI ::
     forall m blk.
     (IOLike m, HasHeader blk)
  => ImmutableDB m blk -> LedgerDB.StreamAPI m blk
streamAPI :: ImmutableDB m blk -> StreamAPI m blk
streamAPI ImmutableDB m blk
immutableDB = (forall a.
 HasCallStack =>
 Point blk
 -> (Either (RealPoint blk) (m (NextBlock blk)) -> m a) -> m a)
-> StreamAPI m blk
forall (m :: * -> *) blk.
(forall a.
 HasCallStack =>
 Point blk
 -> (Either (RealPoint blk) (m (NextBlock blk)) -> m a) -> m a)
-> StreamAPI m blk
LedgerDB.StreamAPI forall a.
HasCallStack =>
Point blk
-> (Either (RealPoint blk) (m (NextBlock blk)) -> m a) -> m a
streamAfter
  where
    streamAfter :: HasCallStack
                => Point blk
                -> (Either (RealPoint blk) (m (LedgerDB.NextBlock blk)) -> m a)
                -> m a
    streamAfter :: Point blk
-> (Either (RealPoint blk) (m (NextBlock blk)) -> m a) -> m a
streamAfter Point blk
tip Either (RealPoint blk) (m (NextBlock blk)) -> m a
k = (ResourceRegistry m -> m a) -> m a
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry m -> m a) -> m a)
-> (ResourceRegistry m -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry m
registry -> do
        Either (MissingBlock blk) (Iterator m blk blk)
eItr <-
          ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk blk
-> Point blk
-> m (Either (MissingBlock blk) (Iterator m blk blk))
forall (m :: * -> *) blk b.
(MonadSTM m, HasHeader blk, HasCallStack) =>
ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> Point blk
-> m (Either (MissingBlock blk) (Iterator m blk b))
ImmutableDB.streamAfterPoint
            ImmutableDB m blk
immutableDB
            ResourceRegistry m
registry
            BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock
            Point blk
tip
        case Either (MissingBlock blk) (Iterator m blk blk)
eItr of
          -- Snapshot is too recent
          Left  MissingBlock blk
err -> Either (RealPoint blk) (m (NextBlock blk)) -> m a
k (Either (RealPoint blk) (m (NextBlock blk)) -> m a)
-> Either (RealPoint blk) (m (NextBlock blk)) -> m a
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> Either (RealPoint blk) (m (NextBlock blk))
forall a b. a -> Either a b
Left  (RealPoint blk -> Either (RealPoint blk) (m (NextBlock blk)))
-> RealPoint blk -> Either (RealPoint blk) (m (NextBlock blk))
forall a b. (a -> b) -> a -> b
$ MissingBlock blk -> RealPoint blk
forall blk. MissingBlock blk -> RealPoint blk
ImmutableDB.missingBlockPoint MissingBlock blk
err
          Right Iterator m blk blk
itr -> Either (RealPoint blk) (m (NextBlock blk)) -> m a
k (Either (RealPoint blk) (m (NextBlock blk)) -> m a)
-> Either (RealPoint blk) (m (NextBlock blk)) -> m a
forall a b. (a -> b) -> a -> b
$ m (NextBlock blk) -> Either (RealPoint blk) (m (NextBlock blk))
forall a b. b -> Either a b
Right (m (NextBlock blk) -> Either (RealPoint blk) (m (NextBlock blk)))
-> m (NextBlock blk) -> Either (RealPoint blk) (m (NextBlock blk))
forall a b. (a -> b) -> a -> b
$ Iterator m blk blk -> m (NextBlock blk)
streamUsing Iterator m blk blk
itr

    streamUsing :: ImmutableDB.Iterator m blk blk -> m (LedgerDB.NextBlock blk)
    streamUsing :: Iterator m blk blk -> m (NextBlock blk)
streamUsing Iterator m blk blk
itr = Iterator m blk blk -> HasCallStack => m (IteratorResult blk)
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m (IteratorResult b)
ImmutableDB.iteratorNext Iterator m blk blk
itr m (IteratorResult blk)
-> (IteratorResult blk -> m (NextBlock blk)) -> m (NextBlock blk)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      IteratorResult blk
ImmutableDB.IteratorExhausted  -> NextBlock blk -> m (NextBlock blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (NextBlock blk -> m (NextBlock blk))
-> NextBlock blk -> m (NextBlock blk)
forall a b. (a -> b) -> a -> b
$ NextBlock blk
forall blk. NextBlock blk
LedgerDB.NoMoreBlocks
      ImmutableDB.IteratorResult blk
blk -> NextBlock blk -> m (NextBlock blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (NextBlock blk -> m (NextBlock blk))
-> NextBlock blk -> m (NextBlock blk)
forall a b. (a -> b) -> a -> b
$ blk -> NextBlock blk
forall blk. blk -> NextBlock blk
LedgerDB.NextBlock blk
blk

{-------------------------------------------------------------------------------
  Previously applied blocks
-------------------------------------------------------------------------------}

getPrevApplied :: IOLike m => LgrDB m blk -> STM m (Set (RealPoint blk))
getPrevApplied :: LgrDB m blk -> STM m (Set (RealPoint blk))
getPrevApplied LgrDB{StrictTVar m (Set (RealPoint blk))
StrictTVar m (LedgerDB' blk)
Tracer m (TraceSnapshotEvent blk)
SomeHasFS m
DiskPolicy
TopLevelConfig blk
RealPoint blk -> m blk
tracer :: Tracer m (TraceSnapshotEvent blk)
hasFS :: SomeHasFS m
diskPolicy :: DiskPolicy
cfg :: TopLevelConfig blk
resolveBlock :: RealPoint blk -> m blk
varPrevApplied :: StrictTVar m (Set (RealPoint blk))
varDB :: StrictTVar m (LedgerDB' blk)
tracer :: forall (m :: * -> *) blk.
LgrDB m blk -> Tracer m (TraceSnapshotEvent blk)
hasFS :: forall (m :: * -> *) blk. LgrDB m blk -> SomeHasFS m
diskPolicy :: forall (m :: * -> *) blk. LgrDB m blk -> DiskPolicy
cfg :: forall (m :: * -> *) blk. LgrDB m blk -> TopLevelConfig blk
resolveBlock :: forall (m :: * -> *) blk. LgrDB m blk -> RealPoint blk -> m blk
varPrevApplied :: forall (m :: * -> *) blk.
LgrDB m blk -> StrictTVar m (Set (RealPoint blk))
varDB :: forall (m :: * -> *) blk.
LgrDB m blk -> StrictTVar m (LedgerDB' blk)
..} = StrictTVar m (Set (RealPoint blk)) -> STM m (Set (RealPoint blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Set (RealPoint blk))
varPrevApplied

-- | Remove all points with a slot older than the given slot from the set of
-- previously applied points.
garbageCollectPrevApplied :: IOLike m => LgrDB m blk -> SlotNo -> STM m ()
garbageCollectPrevApplied :: LgrDB m blk -> SlotNo -> STM m ()
garbageCollectPrevApplied LgrDB{StrictTVar m (Set (RealPoint blk))
StrictTVar m (LedgerDB' blk)
Tracer m (TraceSnapshotEvent blk)
SomeHasFS m
DiskPolicy
TopLevelConfig blk
RealPoint blk -> m blk
tracer :: Tracer m (TraceSnapshotEvent blk)
hasFS :: SomeHasFS m
diskPolicy :: DiskPolicy
cfg :: TopLevelConfig blk
resolveBlock :: RealPoint blk -> m blk
varPrevApplied :: StrictTVar m (Set (RealPoint blk))
varDB :: StrictTVar m (LedgerDB' blk)
tracer :: forall (m :: * -> *) blk.
LgrDB m blk -> Tracer m (TraceSnapshotEvent blk)
hasFS :: forall (m :: * -> *) blk. LgrDB m blk -> SomeHasFS m
diskPolicy :: forall (m :: * -> *) blk. LgrDB m blk -> DiskPolicy
cfg :: forall (m :: * -> *) blk. LgrDB m blk -> TopLevelConfig blk
resolveBlock :: forall (m :: * -> *) blk. LgrDB m blk -> RealPoint blk -> m blk
varPrevApplied :: forall (m :: * -> *) blk.
LgrDB m blk -> StrictTVar m (Set (RealPoint blk))
varDB :: forall (m :: * -> *) blk.
LgrDB m blk -> StrictTVar m (LedgerDB' blk)
..} SlotNo
slotNo = StrictTVar m (Set (RealPoint blk))
-> (Set (RealPoint blk) -> Set (RealPoint blk)) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Set (RealPoint blk))
varPrevApplied ((Set (RealPoint blk) -> Set (RealPoint blk)) -> STM m ())
-> (Set (RealPoint blk) -> Set (RealPoint blk)) -> STM m ()
forall a b. (a -> b) -> a -> b
$
    (RealPoint blk -> Bool)
-> Set (RealPoint blk) -> Set (RealPoint blk)
forall a. (a -> Bool) -> Set a -> Set a
Set.dropWhileAntitone ((SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
slotNo) (SlotNo -> Bool)
-> (RealPoint blk -> SlotNo) -> RealPoint blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot)

{-------------------------------------------------------------------------------
  Error handling
-------------------------------------------------------------------------------}

-- | Wrap exceptions that may indicate disk failure in a 'ChainDbFailure'
-- exception using the 'LgrDbFailure' constructor.
wrapFailure ::
     forall m x blk. (MonadCatch m, HasHeader blk)
  => Proxy blk
  -> m x
  -> m x
wrapFailure :: Proxy blk -> m x -> m x
wrapFailure Proxy blk
_ m x
k = m x -> (FsError -> m x) -> m x
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch m x
k FsError -> m x
rethrow
  where
    rethrow :: FsError -> m x
    rethrow :: FsError -> m x
rethrow FsError
err = ChainDbFailure blk -> m x
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ChainDbFailure blk -> m x) -> ChainDbFailure blk -> m x
forall a b. (a -> b) -> a -> b
$ FsError -> ChainDbFailure blk
forall blk. FsError -> ChainDbFailure blk
LgrDbFailure @blk FsError
err