{-# 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
  , TraceLedgerReplayEvent
  , decorateReplayTracer
    -- * Wrappers
  , getCurrent
  , setCurrent
  , getCurrentState
  , getPastState
  , getHeaderStateHistory
  , currentPoint
  , takeSnapshot
  , trimSnapshots
  , getDiskPolicy
    -- * Validation
  , validate
  , ValidateResult(..)
    -- * Previously applied blocks
  , getPrevApplied
  , garbageCollectPrevApplied
    -- * Re-exports
  , ExceededRollback(..)
  , LedgerDB.AnnLedgerError(..)
  , LedgerDbParams(..)
  , DiskPolicy (..)
  , DiskSnapshot
  , TraceEvent (..)
  , TraceReplayEvent (..)
  , LedgerDB.ledgerDbCurrent
    -- * Exported for testing purposes
  , mkLgrDB
  ) where

import           Codec.CBOR.Decoding (Decoder)
import           Codec.CBOR.Encoding (Encoding)
import           Codec.Serialise (Serialise (decode, encode))
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           System.FilePath ((</>))

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.HeaderStateHistory
                     (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.Util.Args
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.ResourceRegistry

import           Ouroboros.Consensus.Storage.Common
import           Ouroboros.Consensus.Storage.FS.API (SomeHasFS (..),
                     createDirectoryIfMissing)
import           Ouroboros.Consensus.Storage.FS.API.Types (FsError,
                     MountPoint (..), mkFsPath)
import           Ouroboros.Consensus.Storage.FS.IO (ioHasFS)

import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy
                     (DiskPolicy (..))
import           Ouroboros.Consensus.Storage.LedgerDB.InMemory (Ap (..),
                     ExceededRollback (..), LedgerDbParams (..))
import qualified Ouroboros.Consensus.Storage.LedgerDB.InMemory as LedgerDB
import           Ouroboros.Consensus.Storage.LedgerDB.OnDisk (AnnLedgerError',
                     DiskSnapshot, LedgerDB', NextBlock (..), StreamAPI (..),
                     TraceEvent (..), TraceReplayEvent (..))
import qualified Ouroboros.Consensus.Storage.LedgerDB.OnDisk as LedgerDB

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.ImmutableDB (ImmutableDB)
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import           Ouroboros.Consensus.Storage.Serialisation

-- | 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     :: !DiskPolicy
    , LgrDB m blk -> SomeHasFS m
hasFS          :: !(SomeHasFS m)
    , LgrDB m blk -> Tracer m (TraceEvent blk)
tracer         :: !(Tracer m (TraceEvent 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 -> HKD f DiskPolicy
lgrDiskPolicy     :: HKD f 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 LedgerDbParams
lgrParams         :: HKD f LedgerDbParams
    , 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 (TraceEvent blk)
lgrTracer         :: Tracer m (TraceEvent blk)
    }

-- | Default arguments
defaultArgs :: FilePath -> LgrDbArgs Defaults IO blk
defaultArgs :: String -> LgrDbArgs Defaults IO blk
defaultArgs String
fp = LgrDbArgs :: forall (f :: * -> *) (m :: * -> *) blk.
HKD f DiskPolicy
-> HKD f (m (ExtLedgerState blk))
-> SomeHasFS m
-> HKD f LedgerDbParams
-> HKD f (TopLevelConfig blk)
-> Tracer m (LedgerDB' blk)
-> Tracer m (TraceEvent blk)
-> LgrDbArgs f m blk
LgrDbArgs {
      lgrDiskPolicy :: HKD Defaults DiskPolicy
lgrDiskPolicy     = HKD Defaults DiskPolicy
forall t. Defaults t
NoDefault
    , lgrGenesis :: HKD Defaults (IO (ExtLedgerState blk))
lgrGenesis        = HKD Defaults (IO (ExtLedgerState blk))
forall t. Defaults t
NoDefault
    , lgrHasFS :: SomeHasFS IO
lgrHasFS          = HasFS IO HandleIO -> SomeHasFS IO
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS (HasFS IO HandleIO -> SomeHasFS IO)
-> HasFS IO HandleIO -> SomeHasFS IO
forall a b. (a -> b) -> a -> b
$ MountPoint -> HasFS IO HandleIO
ioHasFS (MountPoint -> HasFS IO HandleIO)
-> MountPoint -> HasFS IO HandleIO
forall a b. (a -> b) -> a -> b
$ String -> MountPoint
MountPoint (String
fp String -> String -> String
</> String
"ledger")
    , lgrParams :: HKD Defaults LedgerDbParams
lgrParams         = HKD Defaults LedgerDbParams
forall t. Defaults t
NoDefault
    , lgrTopLevelConfig :: HKD Defaults (TopLevelConfig blk)
lgrTopLevelConfig = HKD Defaults (TopLevelConfig blk)
forall t. Defaults t
NoDefault
    , lgrTraceLedger :: Tracer IO (LedgerDB' blk)
lgrTraceLedger    = Tracer IO (LedgerDB' blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , lgrTracer :: Tracer IO (TraceEvent blk)
lgrTracer         = Tracer IO (TraceEvent 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 (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 (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 (TraceEvent blk)
HKD Identity (m (ExtLedgerState blk))
HKD Identity DiskPolicy
HKD Identity (TopLevelConfig blk)
HKD Identity LedgerDbParams
lgrTracer :: Tracer m (TraceEvent blk)
lgrTraceLedger :: Tracer m (LedgerDB' blk)
lgrTopLevelConfig :: HKD Identity (TopLevelConfig blk)
lgrParams :: HKD Identity LedgerDbParams
lgrGenesis :: HKD Identity (m (ExtLedgerState blk))
lgrDiskPolicy :: HKD Identity DiskPolicy
lgrTracer :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> Tracer m (TraceEvent 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)
lgrParams :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> HKD f LedgerDbParams
lgrGenesis :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> HKD f (m (ExtLedgerState blk))
lgrDiskPolicy :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> HKD f DiskPolicy
.. } Tracer m (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 (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 (TraceReplayEvent blk ())
-> ImmutableDB m blk
-> m (LedgerDB' blk, Word64)
initFromDisk LgrDbArgs Identity m blk
args Tracer m (TraceReplayEvent blk ())
replayTracer ImmutableDB m blk
immutableDB
    (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
db 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 (TraceEvent 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
HKD Identity DiskPolicy
lgrDiskPolicy
          , hasFS :: SomeHasFS m
hasFS          = SomeHasFS m
lgrHasFS
          , tracer :: Tracer m (TraceEvent blk)
tracer         = Tracer m (TraceEvent blk)
lgrTracer
          }
      , Word64
replayed
      )

initFromDisk
  :: forall blk m.
     ( IOLike m
     , LedgerSupportsProtocol blk
     , LgrDbSerialiseConstraints blk
     , InspectLedger blk
     , HasCallStack
     )
  => LgrDbArgs Identity m blk
  -> Tracer m (TraceReplayEvent blk ())
  -> ImmutableDB m blk
  -> m (LedgerDB' blk, Word64)
initFromDisk :: LgrDbArgs Identity m blk
-> Tracer m (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 (TraceEvent blk)
HKD Identity (m (ExtLedgerState blk))
HKD Identity DiskPolicy
HKD Identity (TopLevelConfig blk)
HKD Identity LedgerDbParams
lgrTracer :: Tracer m (TraceEvent blk)
lgrTraceLedger :: Tracer m (LedgerDB' blk)
lgrTopLevelConfig :: HKD Identity (TopLevelConfig blk)
lgrParams :: HKD Identity LedgerDbParams
lgrGenesis :: HKD Identity (m (ExtLedgerState blk))
lgrDiskPolicy :: HKD Identity DiskPolicy
lgrTracer :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> Tracer m (TraceEvent 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)
lgrParams :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> HKD f LedgerDbParams
lgrGenesis :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> HKD f (m (ExtLedgerState blk))
lgrDiskPolicy :: forall (f :: * -> *) (m :: * -> *) blk.
LgrDbArgs f m blk -> HKD f DiskPolicy
.. }
             Tracer m (TraceReplayEvent blk ())
replayTracer
             ImmutableDB m blk
immutableDB = m (LedgerDB' blk, Word64) -> m (LedgerDB' blk, Word64)
forall (m :: * -> *) x. MonadCatch m => m x -> m x
wrapFailure (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 (TraceReplayEvent blk ())
-> Tracer m (TraceEvent blk)
-> SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (RealPoint blk))
-> LedgerDbParams
-> ExtLedgerCfg 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 (TraceReplayEvent blk ())
-> Tracer m (TraceEvent blk)
-> SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (RealPoint blk))
-> LedgerDbParams
-> ExtLedgerCfg blk
-> m (ExtLedgerState blk)
-> StreamAPI m blk
-> m (InitLog blk, LedgerDB' blk, Word64)
LedgerDB.initLedgerDB
        Tracer m (TraceReplayEvent blk ())
replayTracer
        Tracer m (TraceEvent blk)
lgrTracer
        SomeHasFS m
hasFS
        forall s. Decoder s (ExtLedgerState blk)
decodeExtLedgerState'
        ((forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (RealPoint blk)
forall blk.
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (RealPoint blk)
decodeRealPoint forall s. Decoder s (HeaderHash blk)
forall a s. Serialise a => Decoder s a
decode)
        HKD Identity LedgerDbParams
LedgerDbParams
lgrParams
        (TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg 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 (TraceEvent blk)
-> LgrDB m blk
LgrDB {Tracer m (TraceEvent blk)
StrictTVar m (Set (RealPoint blk))
StrictTVar m (LedgerDB' blk)
DiskPolicy
HKD Identity DiskPolicy
HKD Identity (TopLevelConfig blk)
SomeHasFS m
TopLevelConfig blk
RealPoint blk -> m blk
tracer :: Tracer m (TraceEvent blk)
hasFS :: SomeHasFS m
diskPolicy :: HKD Identity 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 (TraceEvent 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 -> HKD f DiskPolicy
lgrDiskPolicy     = HKD Identity 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 (TraceEvent blk)
lgrTracer         = Tracer m (TraceEvent blk)
tracer
      } = LgrDbArgs Identity m blk
args

{-------------------------------------------------------------------------------
  TraceReplayEvent decorator
-------------------------------------------------------------------------------}

-- | 'TraceReplayEvent' instantiated with additional information.
--
-- The @replayTo@ parameter is instantiated with the 'Point' of
-- the tip of the ImmutableDB.
type TraceLedgerReplayEvent blk = TraceReplayEvent blk (Point blk)

-- | Add the tip of the Immutable DB to the trace event
--
-- Between the tip of the immutable DB and the point of the starting block,
-- the node could (if it so desired) easily compute a "percentage complete".
decorateReplayTracer
  :: Point blk -- ^ Tip of the ImmutableDB
  -> Tracer m (TraceLedgerReplayEvent blk)
  -> Tracer m (TraceReplayEvent blk ())
decorateReplayTracer :: Point blk
-> Tracer m (TraceLedgerReplayEvent blk)
-> Tracer m (TraceReplayEvent blk ())
decorateReplayTracer Point blk
immTip = (TraceReplayEvent blk () -> TraceLedgerReplayEvent blk)
-> Tracer m (TraceLedgerReplayEvent blk)
-> Tracer m (TraceReplayEvent blk ())
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ((TraceReplayEvent blk () -> TraceLedgerReplayEvent blk)
 -> Tracer m (TraceLedgerReplayEvent blk)
 -> Tracer m (TraceReplayEvent blk ()))
-> (TraceReplayEvent blk () -> TraceLedgerReplayEvent blk)
-> Tracer m (TraceLedgerReplayEvent blk)
-> Tracer m (TraceReplayEvent blk ())
forall a b. (a -> b) -> a -> b
$ (() -> Point blk)
-> TraceReplayEvent blk () -> TraceLedgerReplayEvent blk
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Point blk -> () -> Point blk
forall a b. a -> b -> a
const Point blk
immTip)

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

getCurrent :: IOLike m => LgrDB m blk -> STM m (LedgerDB' blk)
getCurrent :: LgrDB m blk -> STM m (LedgerDB' blk)
getCurrent LgrDB{Tracer m (TraceEvent blk)
StrictTVar m (Set (RealPoint blk))
StrictTVar m (LedgerDB' blk)
DiskPolicy
SomeHasFS m
TopLevelConfig blk
RealPoint blk -> m blk
tracer :: Tracer m (TraceEvent 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 (TraceEvent 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

getCurrentState :: IOLike m => LgrDB m blk -> STM m (ExtLedgerState blk)
getCurrentState :: LgrDB m blk -> STM m (ExtLedgerState blk)
getCurrentState LgrDB{Tracer m (TraceEvent blk)
StrictTVar m (Set (RealPoint blk))
StrictTVar m (LedgerDB' blk)
DiskPolicy
SomeHasFS m
TopLevelConfig blk
RealPoint blk -> m blk
tracer :: Tracer m (TraceEvent 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 (TraceEvent 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 -> ExtLedgerState blk
forall l r. LedgerDB l r -> l
LedgerDB.ledgerDbCurrent (LedgerDB' blk -> ExtLedgerState blk)
-> STM m (LedgerDB' blk) -> STM m (ExtLedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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

getPastState :: (IOLike m, HasHeader blk)
             => LgrDB m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk))
getPastState :: LgrDB m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk))
getPastState LgrDB{Tracer m (TraceEvent blk)
StrictTVar m (Set (RealPoint blk))
StrictTVar m (LedgerDB' blk)
DiskPolicy
SomeHasFS m
TopLevelConfig blk
RealPoint blk -> m blk
tracer :: Tracer m (TraceEvent 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 (TraceEvent 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)
..} Point blk
p = do
    LedgerDB' blk
db <- 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
    Maybe (ExtLedgerState blk) -> STM m (Maybe (ExtLedgerState blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ExtLedgerState blk) -> STM m (Maybe (ExtLedgerState blk)))
-> Maybe (ExtLedgerState blk) -> STM m (Maybe (ExtLedgerState blk))
forall a b. (a -> b) -> a -> b
$
      (RealPoint blk -> SlotNo)
-> WithOrigin (RealPoint blk)
-> LedgerDB' blk
-> Maybe (ExtLedgerState blk)
forall l r ro.
(Ord ro, Eq r) =>
(r -> ro) -> WithOrigin r -> LedgerDB l r -> Maybe l
LedgerDB.ledgerDbPast
        RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot
        (Point blk -> WithOrigin (RealPoint blk)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint Point blk
p)
        LedgerDB' blk
db

getHeaderStateHistory ::
     IOLike m
  => LgrDB m blk -> STM m (HeaderStateHistory blk)
getHeaderStateHistory :: LgrDB m blk -> STM m (HeaderStateHistory blk)
getHeaderStateHistory LgrDB{Tracer m (TraceEvent blk)
StrictTVar m (Set (RealPoint blk))
StrictTVar m (LedgerDB' blk)
DiskPolicy
SomeHasFS m
TopLevelConfig blk
RealPoint blk -> m blk
tracer :: Tracer m (TraceEvent 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 (TraceEvent 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)
..} = do
    LedgerDB' blk
db <- 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
    let (HeaderState blk
anchor, StrictSeq (HeaderState blk)
snapshots) = (ExtLedgerState blk -> HeaderState blk)
-> LedgerDB' blk -> (HeaderState blk, StrictSeq (HeaderState blk))
forall l a r. (l -> a) -> LedgerDB l r -> (a, StrictSeq a)
LedgerDB.ledgerDbPastLedgers ExtLedgerState blk -> HeaderState blk
forall blk. ExtLedgerState blk -> HeaderState blk
headerState LedgerDB' blk
db
    HeaderStateHistory blk -> STM m (HeaderStateHistory blk)
forall (m :: * -> *) a. Monad m => a -> m a
return HeaderStateHistory :: forall blk.
StrictSeq (HeaderState blk)
-> HeaderState blk -> HeaderStateHistory blk
HeaderStateHistory {
        headerStateHistorySnapshots :: StrictSeq (HeaderState blk)
headerStateHistorySnapshots = StrictSeq (HeaderState blk)
snapshots
      , headerStateHistoryAnchor :: HeaderState blk
headerStateHistoryAnchor    = HeaderState blk
anchor
      }

-- | 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{Tracer m (TraceEvent blk)
StrictTVar m (Set (RealPoint blk))
StrictTVar m (LedgerDB' blk)
DiskPolicy
SomeHasFS m
TopLevelConfig blk
RealPoint blk -> m blk
tracer :: Tracer m (TraceEvent 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 (TraceEvent 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
. Proxy blk -> LedgerState blk -> Point blk
forall blk.
UpdateLedger blk =>
Proxy blk -> LedgerState blk -> Point blk
ledgerTipPoint (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)
             (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 r. LedgerDB l r -> l
LedgerDB.ledgerDbCurrent

takeSnapshot :: forall m blk.
                (IOLike m, LgrDbSerialiseConstraints blk)
             => LgrDB m blk -> m (DiskSnapshot, Point blk)
takeSnapshot :: LgrDB m blk -> m (DiskSnapshot, Point 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 (TraceEvent blk)
tracer :: Tracer m (TraceEvent blk)
tracer :: forall (m :: * -> *) blk. LgrDB m blk -> Tracer m (TraceEvent blk)
tracer, SomeHasFS m
hasFS :: SomeHasFS m
hasFS :: forall (m :: * -> *) blk. LgrDB m blk -> SomeHasFS m
hasFS } = m (DiskSnapshot, Point blk) -> m (DiskSnapshot, Point blk)
forall (m :: * -> *) x. MonadCatch m => m x -> m x
wrapFailure (m (DiskSnapshot, Point blk) -> m (DiskSnapshot, Point blk))
-> m (DiskSnapshot, Point blk) -> m (DiskSnapshot, Point blk)
forall a b. (a -> b) -> a -> b
$ do
    LedgerDB' blk
ledgerDB <- STM m (LedgerDB' blk) -> m (LedgerDB' blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LedgerDB' blk) -> m (LedgerDB' blk))
-> STM m (LedgerDB' blk) -> m (LedgerDB' blk)
forall a b. (a -> b) -> a -> b
$ LgrDB m blk -> STM m (LedgerDB' blk)
forall (m :: * -> *) blk.
IOLike m =>
LgrDB m blk -> STM m (LedgerDB' blk)
getCurrent LgrDB m blk
lgrDB
    Tracer m (TraceEvent blk)
-> SomeHasFS m
-> (ExtLedgerState blk -> Encoding)
-> (RealPoint blk -> Encoding)
-> LedgerDB' blk
-> m (DiskSnapshot, Point blk)
forall (m :: * -> *) blk.
MonadThrow m =>
Tracer m (TraceEvent blk)
-> SomeHasFS m
-> (ExtLedgerState blk -> Encoding)
-> (RealPoint blk -> Encoding)
-> LedgerDB' blk
-> m (DiskSnapshot, Point blk)
LedgerDB.takeSnapshot
      Tracer m (TraceEvent blk)
tracer
      SomeHasFS m
hasFS
      ExtLedgerState blk -> Encoding
encodeExtLedgerState'
      ((HeaderHash blk -> Encoding) -> RealPoint blk -> Encoding
forall blk.
(HeaderHash blk -> Encoding) -> RealPoint blk -> Encoding
encodeRealPoint HeaderHash blk -> Encoding
forall a. Serialise a => a -> Encoding
encode)
      LedgerDB' 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 :: MonadCatch m => LgrDB m blk -> m [DiskSnapshot]
trimSnapshots :: LgrDB m blk -> m [DiskSnapshot]
trimSnapshots LgrDB { DiskPolicy
diskPolicy :: DiskPolicy
diskPolicy :: forall (m :: * -> *) blk. LgrDB m blk -> DiskPolicy
diskPolicy, Tracer m (TraceEvent blk)
tracer :: Tracer m (TraceEvent blk)
tracer :: forall (m :: * -> *) blk. LgrDB m blk -> Tracer m (TraceEvent blk)
tracer, SomeHasFS m
hasFS :: SomeHasFS m
hasFS :: forall (m :: * -> *) blk. LgrDB m blk -> SomeHasFS m
hasFS } = m [DiskSnapshot] -> m [DiskSnapshot]
forall (m :: * -> *) x. MonadCatch m => m x -> m x
wrapFailure (m [DiskSnapshot] -> m [DiskSnapshot])
-> m [DiskSnapshot] -> m [DiskSnapshot]
forall a b. (a -> b) -> a -> b
$
    Tracer m (TraceEvent blk)
-> SomeHasFS m -> DiskPolicy -> m [DiskSnapshot]
forall (m :: * -> *) r.
Monad m =>
Tracer m (TraceEvent r)
-> SomeHasFS m -> DiskPolicy -> m [DiskSnapshot]
LedgerDB.trimSnapshots Tracer m (TraceEvent blk)
tracer SomeHasFS m
hasFS DiskPolicy
diskPolicy

getDiskPolicy :: LgrDB m blk -> 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      (AnnLedgerError' blk)
  | ValidateExceededRollBack 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
         -> [Header blk]
         -> m (ValidateResult blk)
validate :: LgrDB m blk
-> LedgerDB' blk
-> BlockCache blk
-> Word64
-> [Header blk]
-> m (ValidateResult blk)
validate LgrDB{Tracer m (TraceEvent blk)
StrictTVar m (Set (RealPoint blk))
StrictTVar m (LedgerDB' blk)
DiskPolicy
SomeHasFS m
TopLevelConfig blk
RealPoint blk -> m blk
tracer :: Tracer m (TraceEvent 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 (TraceEvent 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 = \[Header blk]
hdrs -> do
    [Ap
   (ExceptT
      (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
      (ReaderT (RealPoint blk -> m blk) m))
   (ExtLedgerState blk)
   (RealPoint blk)
   blk
   (ResolvesBlocks
      (RealPoint blk)
      blk
      (ExceptT
         (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
         (ReaderT (RealPoint blk -> m blk) m)),
    ThrowsLedgerError
      (ExtLedgerState blk)
      (RealPoint blk)
      (ExceptT
         (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
         (ReaderT (RealPoint blk -> m blk) m)))]
aps <- [Header blk]
-> Set (RealPoint blk)
-> [Ap
      (ExceptT
         (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
         (ReaderT (RealPoint blk -> m blk) m))
      (ExtLedgerState blk)
      (RealPoint blk)
      blk
      (ResolvesBlocks
         (RealPoint blk)
         blk
         (ExceptT
            (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
            (ReaderT (RealPoint blk -> m blk) m)),
       ThrowsLedgerError
         (ExtLedgerState blk)
         (RealPoint blk)
         (ExceptT
            (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
            (ReaderT (RealPoint blk -> m blk) m)))]
forall (n :: * -> *) r l b.
(r ~ RealPoint blk, l ~ ExtLedgerState blk, b ~ blk) =>
[Header blk]
-> Set r
-> [Ap n l r b (ResolvesBlocks r b n, ThrowsLedgerError l r n)]
mkAps [Header blk]
hdrs (Set (RealPoint blk)
 -> [Ap
       (ExceptT
          (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
          (ReaderT (RealPoint blk -> m blk) m))
       (ExtLedgerState blk)
       (RealPoint blk)
       blk
       (ResolvesBlocks
          (RealPoint blk)
          blk
          (ExceptT
             (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
             (ReaderT (RealPoint blk -> m blk) m)),
        ThrowsLedgerError
          (ExtLedgerState blk)
          (RealPoint blk)
          (ExceptT
             (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
             (ReaderT (RealPoint blk -> m blk) m)))])
-> m (Set (RealPoint blk))
-> m [Ap
        (ExceptT
           (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
           (ReaderT (RealPoint blk -> m blk) m))
        (ExtLedgerState blk)
        (RealPoint blk)
        blk
        (ResolvesBlocks
           (RealPoint blk)
           blk
           (ExceptT
              (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
              (ReaderT (RealPoint blk -> m blk) m)),
         ThrowsLedgerError
           (ExtLedgerState blk)
           (RealPoint blk)
           (ExceptT
              (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
              (ReaderT (RealPoint blk -> m blk) m)))]
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) (RealPoint blk))
   (Either ExceededRollback (LedgerDB' blk))
 -> ValidateResult blk)
-> m (Either
        (AnnLedgerError (ExtLedgerState blk) (RealPoint 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) (RealPoint blk))
  (Either ExceededRollback (LedgerDB' blk))
-> ValidateResult blk
rewrap (m (Either
      (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
      (Either ExceededRollback (LedgerDB' blk)))
 -> m (ValidateResult blk))
-> m (Either
        (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
        (Either ExceededRollback (LedgerDB' blk)))
-> m (ValidateResult blk)
forall a b. (a -> b) -> a -> b
$ (RealPoint blk -> m blk)
-> ExceptT
     (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
     (ReaderT (RealPoint blk -> m blk) m)
     (Either ExceededRollback (LedgerDB' blk))
-> m (Either
        (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
        (Either ExceededRollback (LedgerDB' blk)))
forall (m :: * -> *) r b l a.
ResolveBlock m r b
-> ExceptT (AnnLedgerError l r) (ReaderT (ResolveBlock m r b) m) a
-> m (Either (AnnLedgerError l r) a)
LedgerDB.defaultResolveWithErrors RealPoint blk -> m blk
resolveBlock (ExceptT
   (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
   (ReaderT (RealPoint blk -> m blk) m)
   (Either ExceededRollback (LedgerDB' blk))
 -> m (Either
         (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
         (Either ExceededRollback (LedgerDB' blk))))
-> ExceptT
     (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
     (ReaderT (RealPoint blk -> m blk) m)
     (Either ExceededRollback (LedgerDB' blk))
-> m (Either
        (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
        (Either ExceededRollback (LedgerDB' blk)))
forall a b. (a -> b) -> a -> b
$
             LedgerCfg (ExtLedgerState blk)
-> Word64
-> [Ap
      (ExceptT
         (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
         (ReaderT (RealPoint blk -> m blk) m))
      (ExtLedgerState blk)
      (RealPoint blk)
      blk
      (ResolvesBlocks
         (RealPoint blk)
         blk
         (ExceptT
            (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
            (ReaderT (RealPoint blk -> m blk) m)),
       ThrowsLedgerError
         (ExtLedgerState blk)
         (RealPoint blk)
         (ExceptT
            (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
            (ReaderT (RealPoint blk -> m blk) m)))]
-> LedgerDB' blk
-> ExceptT
     (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
     (ReaderT (RealPoint blk -> m blk) m)
     (Either ExceededRollback (LedgerDB' blk))
forall l b (m :: * -> *) (c :: Constraint) r.
(ApplyBlock l b, Monad m, c) =>
LedgerCfg l
-> Word64
-> [Ap m l r b c]
-> LedgerDB l r
-> m (Either ExceededRollback (LedgerDB l r))
LedgerDB.ledgerDbSwitch
               (TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
cfg)
               Word64
numRollbacks
               [Ap
   (ExceptT
      (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
      (ReaderT (RealPoint blk -> m blk) m))
   (ExtLedgerState blk)
   (RealPoint blk)
   blk
   (ResolvesBlocks
      (RealPoint blk)
      blk
      (ExceptT
         (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
         (ReaderT (RealPoint blk -> m blk) m)),
    ThrowsLedgerError
      (ExtLedgerState blk)
      (RealPoint blk)
      (ExceptT
         (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
         (ReaderT (RealPoint blk -> m blk) m)))]
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 (AnnLedgerError' blk) (Either ExceededRollback (LedgerDB' blk))
           -> ValidateResult blk
    rewrap :: Either
  (AnnLedgerError (ExtLedgerState blk) (RealPoint blk))
  (Either ExceededRollback (LedgerDB' blk))
-> ValidateResult blk
rewrap (Left         AnnLedgerError (ExtLedgerState blk) (RealPoint blk)
e)  = AnnLedgerError (ExtLedgerState blk) (RealPoint blk)
-> ValidateResult blk
forall blk. AnnLedgerError' blk -> ValidateResult blk
ValidateLedgerError      AnnLedgerError (ExtLedgerState blk) (RealPoint 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 r l b. (
               r ~ RealPoint      blk
             , l ~ ExtLedgerState blk
             , b ~                blk
             )
          => [Header blk]
          -> Set r
          -> [Ap n l r b ( LedgerDB.ResolvesBlocks r b n
                         , LedgerDB.ThrowsLedgerError l r n
                         )]
    mkAps :: [Header blk]
-> Set r
-> [Ap n l r b (ResolvesBlocks r b n, ThrowsLedgerError l r n)]
mkAps [Header blk]
hdrs Set r
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 r
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
     (RealPoint blk)
     b
     (ResolvesBlocks (RealPoint blk) b n,
      ThrowsLedgerError l (RealPoint blk) n)
forall r (m :: * -> *) l b.
r -> Ap m l r b (ResolvesBlocks r b m, ThrowsLedgerError l r m)
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 (RealPoint blk) b (ResolvesBlocks (RealPoint blk) b n)
-> Ap
     n
     l
     (RealPoint blk)
     b
     (ResolvesBlocks r b n, ThrowsLedgerError l r n)
forall (c' :: Constraint) (c :: Constraint) (m :: * -> *) l r b.
(c' => c) =>
Ap m l r b c -> Ap m l r b c'
Weaken (Ap n l (RealPoint blk) b (ResolvesBlocks (RealPoint blk) b n)
 -> Ap
      n
      l
      (RealPoint blk)
      b
      (ResolvesBlocks r b n, ThrowsLedgerError l r n))
-> Ap n l (RealPoint blk) b (ResolvesBlocks (RealPoint blk) b n)
-> Ap
     n
     l
     (RealPoint blk)
     b
     (ResolvesBlocks r b n, ThrowsLedgerError l r n)
forall a b. (a -> b) -> a -> b
$ RealPoint blk
-> Ap n l (RealPoint blk) b (ResolvesBlocks (RealPoint blk) b n)
forall r (m :: * -> *) l b. r -> Ap m l r b (ResolvesBlocks r b m)
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 (RealPoint blk) blk (ThrowsLedgerError l (RealPoint blk) n)
-> Ap
     n
     l
     (RealPoint blk)
     blk
     (ResolvesBlocks r b n, ThrowsLedgerError l r n)
forall (c' :: Constraint) (c :: Constraint) (m :: * -> *) l r b.
(c' => c) =>
Ap m l r b c -> Ap m l r b c'
Weaken (Ap n l (RealPoint blk) blk (ThrowsLedgerError l (RealPoint blk) n)
 -> Ap
      n
      l
      (RealPoint blk)
      blk
      (ResolvesBlocks r b n, ThrowsLedgerError l r n))
-> Ap
     n l (RealPoint blk) blk (ThrowsLedgerError l (RealPoint blk) n)
-> Ap
     n
     l
     (RealPoint blk)
     blk
     (ResolvesBlocks r b n, ThrowsLedgerError l r n)
forall a b. (a -> b) -> a -> b
$ RealPoint blk
-> blk
-> Ap
     n l (RealPoint blk) blk (ThrowsLedgerError l (RealPoint blk) n)
forall r b (m :: * -> *) l.
r -> b -> Ap m l r b (ThrowsLedgerError l r m)
ApplyVal   (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
blk) blk
blk
          (Bool
True,  Just blk
blk) -> Ap n l (RealPoint blk) blk (() :: Constraint)
-> Ap
     n
     l
     (RealPoint blk)
     blk
     (ResolvesBlocks r b n, ThrowsLedgerError l r n)
forall (c' :: Constraint) (c :: Constraint) (m :: * -> *) l r b.
(c' => c) =>
Ap m l r b c -> Ap m l r b c'
Weaken (Ap n l (RealPoint blk) blk (() :: Constraint)
 -> Ap
      n
      l
      (RealPoint blk)
      blk
      (ResolvesBlocks r b n, ThrowsLedgerError l r n))
-> Ap n l (RealPoint blk) blk (() :: Constraint)
-> Ap
     n
     l
     (RealPoint blk)
     blk
     (ResolvesBlocks r b n, ThrowsLedgerError l r n)
forall a b. (a -> b) -> a -> b
$ RealPoint blk
-> blk -> Ap n l (RealPoint blk) blk (() :: Constraint)
forall r b (m :: * -> *) l. r -> b -> Ap m l r b (() :: Constraint)
ReapplyVal (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
blk) 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) (RealPoint 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) (RealPoint blk)
-> RealPoint blk
forall l r. AnnLedgerError l r -> r
LedgerDB.annLedgerErrRef AnnLedgerError (ExtLedgerState blk) (RealPoint 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 -> StreamAPI m blk
streamAPI :: ImmutableDB m blk -> StreamAPI m blk
streamAPI ImmutableDB m blk
immutableDB = (forall a.
 HasCallStack =>
 Point blk -> (Maybe (m (NextBlock blk)) -> m a) -> m a)
-> StreamAPI m blk
forall (m :: * -> *) blk.
(forall a.
 HasCallStack =>
 Point blk -> (Maybe (m (NextBlock blk)) -> m a) -> m a)
-> StreamAPI m blk
StreamAPI forall a.
HasCallStack =>
Point blk -> (Maybe (m (NextBlock blk)) -> m a) -> m a
streamAfter
  where
    streamAfter :: HasCallStack
                => Point blk
                -> (Maybe (m (NextBlock blk)) -> m a)
                -> m a
    streamAfter :: Point blk -> (Maybe (m (NextBlock blk)) -> m a) -> m a
streamAfter Point blk
tip Maybe (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 -> Maybe (m (NextBlock blk)) -> m a
k (Maybe (m (NextBlock blk)) -> m a)
-> Maybe (m (NextBlock blk)) -> m a
forall a b. (a -> b) -> a -> b
$ Maybe (m (NextBlock blk))
forall a. Maybe a
Nothing
          Right Iterator m blk blk
itr -> Maybe (m (NextBlock blk)) -> m a
k (Maybe (m (NextBlock blk)) -> m a)
-> Maybe (m (NextBlock blk)) -> m a
forall a b. (a -> b) -> a -> b
$ Iterator m blk blk -> Maybe (m (NextBlock blk))
streamUsing Iterator m blk blk
itr

    streamUsing ::
         ImmutableDB.Iterator m blk blk
      -> Maybe (m (NextBlock blk))
    streamUsing :: Iterator m blk blk -> Maybe (m (NextBlock blk))
streamUsing Iterator m blk blk
itr = m (NextBlock blk) -> Maybe (m (NextBlock blk))
forall a. a -> Maybe a
Just (m (NextBlock blk) -> Maybe (m (NextBlock blk)))
-> m (NextBlock blk) -> Maybe (m (NextBlock blk))
forall a b. (a -> b) -> a -> b
$ 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
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
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{Tracer m (TraceEvent blk)
StrictTVar m (Set (RealPoint blk))
StrictTVar m (LedgerDB' blk)
DiskPolicy
SomeHasFS m
TopLevelConfig blk
RealPoint blk -> m blk
tracer :: Tracer m (TraceEvent 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 (TraceEvent 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{Tracer m (TraceEvent blk)
StrictTVar m (Set (RealPoint blk))
StrictTVar m (LedgerDB' blk)
DiskPolicy
SomeHasFS m
TopLevelConfig blk
RealPoint blk -> m blk
tracer :: Tracer m (TraceEvent 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 (TraceEvent 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. MonadCatch m => m x -> m x
wrapFailure :: m x -> m x
wrapFailure 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 -> m x
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ChainDbFailure -> m x) -> ChainDbFailure -> m x
forall a b. (a -> b) -> a -> b
$ FsError -> ChainDbFailure
LgrDbFailure FsError
err