{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Storage.LedgerDB.V2 (mkInitDb) where

import Control.Arrow ((>>>))
import qualified Control.Monad as Monad (void, (>=>))
import Control.Monad.Except
import Control.RAWLock
import qualified Control.RAWLock as RAWLock
import Control.ResourceRegistry
import Control.Tracer
import Data.Foldable (traverse_)
import qualified Data.Foldable as Foldable
import Data.Functor.Contravariant ((>$<))
import Data.Kind (Type)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Traversable (for)
import Data.Tuple (Solo (..))
import Data.Void
import Data.Word
import GHC.Generics
import NoThunks.Class
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.HardFork.Abstract
import Ouroboros.Consensus.HeaderStateHistory
  ( HeaderStateHistory (..)
  , mkHeaderStateWithTimeFromSummary
  )
import Ouroboros.Consensus.HeaderValidation
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.SupportsProtocol
import Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache
import Ouroboros.Consensus.Storage.LedgerDB.API
import Ouroboros.Consensus.Storage.LedgerDB.Args
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent
import Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2
import Ouroboros.Consensus.Storage.LedgerDB.V2.Forker
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory
import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
import Ouroboros.Consensus.Util.Args
import Ouroboros.Consensus.Util.CallStack
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.NormalForm.StrictTVar ()
import qualified Ouroboros.Network.AnchoredSeq as AS
import Ouroboros.Network.Protocol.LocalStateQuery.Type
import System.FS.API
import Prelude hiding (read)

mkInitDb ::
  forall m blk.
  ( LedgerSupportsProtocol blk
  , IOLike m
  , LedgerDbSerialiseConstraints blk
  , HasHardForkHistory blk
  , LedgerSupportsInMemoryLedgerDB blk
  ) =>
  Complete LedgerDbArgs m blk ->
  Complete V2.LedgerDbFlavorArgs m ->
  ResolveBlock m blk ->
  InitDB (LedgerSeq' m blk) m blk
mkInitDb :: forall (m :: * -> *) blk.
(LedgerSupportsProtocol blk, IOLike m,
 LedgerDbSerialiseConstraints blk, HasHardForkHistory blk,
 LedgerSupportsInMemoryLedgerDB blk) =>
Complete LedgerDbArgs m blk
-> Complete LedgerDbFlavorArgs m
-> ResolveBlock m blk
-> InitDB (LedgerSeq' m blk) m blk
mkInitDb Complete LedgerDbArgs m blk
args Complete LedgerDbFlavorArgs m
flavArgs ResolveBlock m blk
getBlock =
  InitDB
    { initFromGenesis :: m (LedgerSeq' m blk)
initFromGenesis = ExtLedgerState blk ValuesMK -> m (LedgerSeq' m blk)
emptyF (ExtLedgerState blk ValuesMK -> m (LedgerSeq' m blk))
-> m (ExtLedgerState blk ValuesMK) -> m (LedgerSeq' m blk)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (ExtLedgerState blk ValuesMK)
HKD Identity (m (ExtLedgerState blk ValuesMK))
lgrGenesis
    , initFromSnapshot :: DiskSnapshot
-> m (Either
        (SnapshotFailure blk) (LedgerSeq' m blk, RealPoint blk))
initFromSnapshot =
        CodecConfig blk
-> SomeHasFS m
-> DiskSnapshot
-> m (Either
        (SnapshotFailure blk) (LedgerSeq' m blk, RealPoint blk))
loadSnapshot (TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec (TopLevelConfig blk -> CodecConfig blk)
-> (LedgerDbCfg (ExtLedgerState blk) -> TopLevelConfig blk)
-> LedgerDbCfg (ExtLedgerState blk)
-> CodecConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg (ExtLedgerCfg blk -> TopLevelConfig blk)
-> (LedgerDbCfg (ExtLedgerState blk) -> ExtLedgerCfg blk)
-> LedgerDbCfg (ExtLedgerState blk)
-> TopLevelConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDbCfg (ExtLedgerState blk)
-> HKD Identity (LedgerCfg (ExtLedgerState blk))
LedgerDbCfg (ExtLedgerState blk) -> ExtLedgerCfg blk
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
ledgerDbCfg (LedgerDbCfg (ExtLedgerState blk) -> CodecConfig blk)
-> LedgerDbCfg (ExtLedgerState blk) -> CodecConfig blk
forall a b. (a -> b) -> a -> b
$ LedgerDbCfg (ExtLedgerState blk)
lgrConfig) SomeHasFS m
HKD Identity (SomeHasFS m)
lgrHasFS
    , closeDb :: LedgerSeq' m blk -> m ()
closeDb = LedgerSeq' m blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind).
Monad m =>
LedgerSeq m l -> m ()
closeLedgerSeq
    , initReapplyBlock :: LedgerDbCfg (ExtLedgerState blk)
-> blk -> LedgerSeq' m blk -> m (LedgerSeq' m blk)
initReapplyBlock = \LedgerDbCfg (ExtLedgerState blk)
a blk
b LedgerSeq' m blk
c -> do
        (x, y) <- ResourceRegistry m
-> LedgerDbCfg (ExtLedgerState blk)
-> blk
-> LedgerSeq' m blk
-> m (m (), LedgerSeq' m blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, ApplyBlock l blk) =>
ResourceRegistry m
-> LedgerDbCfg l -> blk -> LedgerSeq m l -> m (m (), LedgerSeq m l)
reapplyThenPush ResourceRegistry m
HKD Identity (ResourceRegistry m)
lgrRegistry LedgerDbCfg (ExtLedgerState blk)
a blk
b LedgerSeq' m blk
c
        x
        pure y
    , currentTip :: LedgerSeq' m blk -> LedgerState blk EmptyMK
currentTip = ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState (ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK)
-> (LedgerSeq' m blk -> ExtLedgerState blk EmptyMK)
-> LedgerSeq' m blk
-> LedgerState blk EmptyMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq' m blk -> ExtLedgerState blk EmptyMK
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> l EmptyMK
current
    , pruneDb :: LedgerSeq' m blk -> m (LedgerSeq' m blk)
pruneDb = \LedgerSeq' m blk
lseq -> do
        let (m ()
rel, LedgerSeq' m blk
dbPrunedToImmDBTip) = LedgerSeq' m blk -> (m (), LedgerSeq' m blk)
forall (m :: * -> *) (l :: LedgerStateKind).
(Monad m, GetTip l) =>
LedgerSeq m l -> (m (), LedgerSeq m l)
pruneToImmTipOnly LedgerSeq' m blk
lseq
        m ()
rel
        LedgerSeq' m blk -> m (LedgerSeq' m blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerSeq' m blk
dbPrunedToImmDBTip
    , mkLedgerDb :: LedgerSeq' m blk
-> m (LedgerDB m (ExtLedgerState blk) blk,
      TestInternals m (ExtLedgerState blk) blk)
mkLedgerDb = \LedgerSeq' m blk
lseq -> do
        varDB <- LedgerSeq' m blk -> m (StrictTVar m (LedgerSeq' m blk))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO LedgerSeq' m blk
lseq
        prevApplied <- newTVarIO Set.empty
        lock <- RAWLock.new ()
        forkers <- newTVarIO Map.empty
        nextForkerKey <- newTVarIO (ForkerKey 0)
        let env =
              LedgerDBEnv
                { ldbSeq :: StrictTVar m (LedgerSeq' m blk)
ldbSeq = StrictTVar m (LedgerSeq' m blk)
varDB
                , ldbPrevApplied :: StrictTVar m (Set (RealPoint blk))
ldbPrevApplied = StrictTVar m (Set (RealPoint blk))
prevApplied
                , ldbForkers :: StrictTVar m (Map ForkerKey (ForkerEnv m (ExtLedgerState blk) blk))
ldbForkers = StrictTVar m (Map ForkerKey (ForkerEnv m (ExtLedgerState blk) blk))
forkers
                , ldbNextForkerKey :: StrictTVar m ForkerKey
ldbNextForkerKey = StrictTVar m ForkerKey
nextForkerKey
                , ldbSnapshotPolicy :: SnapshotPolicy
ldbSnapshotPolicy = SecurityParam -> SnapshotPolicyArgs -> SnapshotPolicy
defaultSnapshotPolicy (LedgerDbCfg (ExtLedgerState blk) -> HKD Identity SecurityParam
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f SecurityParam
ledgerDbCfgSecParam LedgerDbCfg (ExtLedgerState blk)
lgrConfig) SnapshotPolicyArgs
lgrSnapshotPolicyArgs
                , ldbTracer :: Tracer m (TraceEvent blk)
ldbTracer = Tracer m (TraceEvent blk)
lgrTracer
                , ldbCfg :: LedgerDbCfg (ExtLedgerState blk)
ldbCfg = LedgerDbCfg (ExtLedgerState blk)
lgrConfig
                , ldbHasFS :: SomeHasFS m
ldbHasFS = SomeHasFS m
HKD Identity (SomeHasFS m)
lgrHasFS
                , ldbResolveBlock :: ResolveBlock m blk
ldbResolveBlock = ResolveBlock m blk
getBlock
                , ldbQueryBatchSize :: QueryBatchSize
ldbQueryBatchSize = QueryBatchSize
lgrQueryBatchSize
                , ldbOpenHandlesLock :: RAWLock m ()
ldbOpenHandlesLock = RAWLock m ()
lock
                }
        h <- LDBHandle <$> newTVarIO (LedgerDBOpen env)
        pure $ implMkLedgerDb h bss
    }
 where
  LedgerDbArgs
    { LedgerDbCfg (ExtLedgerState blk)
lgrConfig :: LedgerDbCfg (ExtLedgerState blk)
lgrConfig :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> LedgerDbCfgF f (ExtLedgerState blk)
lgrConfig
    , HKD Identity (m (ExtLedgerState blk ValuesMK))
lgrGenesis :: HKD Identity (m (ExtLedgerState blk ValuesMK))
lgrGenesis :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (m (ExtLedgerState blk ValuesMK))
lgrGenesis
    , HKD Identity (SomeHasFS m)
lgrHasFS :: HKD Identity (SomeHasFS m)
lgrHasFS :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (SomeHasFS m)
lgrHasFS
    , SnapshotPolicyArgs
lgrSnapshotPolicyArgs :: SnapshotPolicyArgs
lgrSnapshotPolicyArgs :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> SnapshotPolicyArgs
lgrSnapshotPolicyArgs
    , Tracer m (TraceEvent blk)
lgrTracer :: Tracer m (TraceEvent blk)
lgrTracer :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> Tracer m (TraceEvent blk)
lgrTracer
    , QueryBatchSize
lgrQueryBatchSize :: QueryBatchSize
lgrQueryBatchSize :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> QueryBatchSize
lgrQueryBatchSize
    , HKD Identity (ResourceRegistry m)
lgrRegistry :: HKD Identity (ResourceRegistry m)
lgrRegistry :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (ResourceRegistry m)
lgrRegistry
    } = Complete LedgerDbArgs m blk
args

  bss :: HandleArgs
bss = case Complete LedgerDbFlavorArgs m
flavArgs of V2Args HandleArgs
bss0 -> HandleArgs
bss0

  v2Tracer :: Tracer m V2.FlavorImplSpecificTrace
  v2Tracer :: Tracer m FlavorImplSpecificTrace
v2Tracer = FlavorImplSpecificTrace -> TraceEvent blk
forall blk. FlavorImplSpecificTrace -> TraceEvent blk
LedgerDBFlavorImplEvent (FlavorImplSpecificTrace -> TraceEvent blk)
-> (FlavorImplSpecificTrace -> FlavorImplSpecificTrace)
-> FlavorImplSpecificTrace
-> TraceEvent blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlavorImplSpecificTrace -> FlavorImplSpecificTrace
FlavorImplSpecificTraceV2 (FlavorImplSpecificTrace -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m FlavorImplSpecificTrace
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m (TraceEvent blk)
lgrTracer

  emptyF ::
    ExtLedgerState blk ValuesMK ->
    m (LedgerSeq' m blk)
  emptyF :: ExtLedgerState blk ValuesMK -> m (LedgerSeq' m blk)
emptyF ExtLedgerState blk ValuesMK
st =
    ExtLedgerState blk ValuesMK
-> (LedgerTables (ExtLedgerState blk) ValuesMK
    -> m (LedgerTablesHandle m (ExtLedgerState blk)))
-> m (LedgerSeq' m blk)
forall (l :: LedgerStateKind) (m :: * -> *).
(GetTip l, IOLike m, HasLedgerTables l) =>
l ValuesMK
-> (LedgerTables l ValuesMK -> m (LedgerTablesHandle m l))
-> m (LedgerSeq m l)
empty' ExtLedgerState blk ValuesMK
st ((LedgerTables (ExtLedgerState blk) ValuesMK
  -> m (LedgerTablesHandle m (ExtLedgerState blk)))
 -> m (LedgerSeq' m blk))
-> (LedgerTables (ExtLedgerState blk) ValuesMK
    -> m (LedgerTablesHandle m (ExtLedgerState blk)))
-> m (LedgerSeq' m blk)
forall a b. (a -> b) -> a -> b
$ case HandleArgs
bss of
      HandleArgs
InMemoryHandleArgs -> Tracer m FlavorImplSpecificTrace
-> SomeHasFS m
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> m (LedgerTablesHandle m (ExtLedgerState blk))
forall (m :: * -> *) (l :: LedgerStateKind).
(IOLike m, HasLedgerTables l, CanUpgradeLedgerTables l,
 SerializeTablesWithHint l) =>
Tracer m FlavorImplSpecificTrace
-> SomeHasFS m
-> LedgerTables l ValuesMK
-> m (LedgerTablesHandle m l)
InMemory.newInMemoryLedgerTablesHandle Tracer m FlavorImplSpecificTrace
v2Tracer SomeHasFS m
HKD Identity (SomeHasFS m)
lgrHasFS
      LSMHandleArgs Void
x -> Void
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> m (LedgerTablesHandle m (ExtLedgerState blk))
forall a. Void -> a
absurd Void
x

  loadSnapshot ::
    CodecConfig blk ->
    SomeHasFS m ->
    DiskSnapshot ->
    m (Either (SnapshotFailure blk) (LedgerSeq' m blk, RealPoint blk))
  loadSnapshot :: CodecConfig blk
-> SomeHasFS m
-> DiskSnapshot
-> m (Either
        (SnapshotFailure blk) (LedgerSeq' m blk, RealPoint blk))
loadSnapshot CodecConfig blk
ccfg SomeHasFS m
fs DiskSnapshot
ds = case HandleArgs
bss of
    HandleArgs
InMemoryHandleArgs -> ExceptT (SnapshotFailure blk) m (LedgerSeq' m blk, RealPoint blk)
-> m (Either
        (SnapshotFailure blk) (LedgerSeq' m blk, RealPoint blk))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (SnapshotFailure blk) m (LedgerSeq' m blk, RealPoint blk)
 -> m (Either
         (SnapshotFailure blk) (LedgerSeq' m blk, RealPoint blk)))
-> ExceptT
     (SnapshotFailure blk) m (LedgerSeq' m blk, RealPoint blk)
-> m (Either
        (SnapshotFailure blk) (LedgerSeq' m blk, RealPoint blk))
forall a b. (a -> b) -> a -> b
$ Tracer m FlavorImplSpecificTrace
-> ResourceRegistry m
-> CodecConfig blk
-> SomeHasFS m
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk) m (LedgerSeq' m blk, RealPoint blk)
forall blk (m :: * -> *).
(LedgerDbSerialiseConstraints blk, LedgerSupportsProtocol blk,
 IOLike m, LedgerSupportsInMemoryLedgerDB blk) =>
Tracer m FlavorImplSpecificTrace
-> ResourceRegistry m
-> CodecConfig blk
-> SomeHasFS m
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk) m (LedgerSeq' m blk, RealPoint blk)
InMemory.loadSnapshot Tracer m FlavorImplSpecificTrace
v2Tracer ResourceRegistry m
HKD Identity (ResourceRegistry m)
lgrRegistry CodecConfig blk
ccfg SomeHasFS m
fs DiskSnapshot
ds
    LSMHandleArgs Void
x -> Void
-> m (Either
        (SnapshotFailure blk) (LedgerSeq' m blk, RealPoint blk))
forall a. Void -> a
absurd Void
x

implMkLedgerDb ::
  forall m l blk.
  ( IOLike m
  , HasCallStack
  , IsLedger l
  , l ~ ExtLedgerState blk
  , StandardHash l
  , HasLedgerTables l
  , LedgerSupportsProtocol blk
  , LedgerDbSerialiseConstraints blk
  , HasHardForkHistory blk
  ) =>
  LedgerDBHandle m l blk ->
  HandleArgs ->
  (LedgerDB m l blk, TestInternals m l blk)
implMkLedgerDb :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasCallStack, IsLedger l, l ~ ExtLedgerState blk,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk,
 LedgerDbSerialiseConstraints blk, HasHardForkHistory blk) =>
LedgerDBHandle m l blk
-> HandleArgs -> (LedgerDB m l blk, TestInternals m l blk)
implMkLedgerDb LedgerDBHandle m l blk
h HandleArgs
bss =
  ( LedgerDB
      { getVolatileTip :: STM m (l EmptyMK)
getVolatileTip = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m (ExtLedgerState blk EmptyMK))
-> STM m (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m r) -> STM m r
getEnvSTM LedgerDBHandle m l blk
h LedgerDBEnv m l blk -> STM m (l EmptyMK)
LedgerDBEnv m l blk -> STM m (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l) =>
LedgerDBEnv m l blk -> STM m (l EmptyMK)
implGetVolatileTip
      , getImmutableTip :: STM m (l EmptyMK)
getImmutableTip = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m (ExtLedgerState blk EmptyMK))
-> STM m (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m r) -> STM m r
getEnvSTM LedgerDBHandle m l blk
h LedgerDBEnv m l blk -> STM m (l EmptyMK)
LedgerDBEnv m l blk -> STM m (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
MonadSTM m =>
LedgerDBEnv m l blk -> STM m (l EmptyMK)
implGetImmutableTip
      , getPastLedgerState :: Point blk -> STM m (Maybe (l EmptyMK))
getPastLedgerState = \Point blk
s -> LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk
    -> STM m (Maybe (ExtLedgerState blk EmptyMK)))
-> STM m (Maybe (ExtLedgerState blk EmptyMK))
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m r) -> STM m r
getEnvSTM LedgerDBHandle m l blk
h ((LedgerDBEnv m l blk
 -> Point blk -> STM m (Maybe (ExtLedgerState blk EmptyMK)))
-> Point blk
-> LedgerDBEnv m l blk
-> STM m (Maybe (ExtLedgerState blk EmptyMK))
forall a b c. (a -> b -> c) -> b -> a -> c
flip LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l EmptyMK))
LedgerDBEnv m l blk
-> Point blk -> STM m (Maybe (ExtLedgerState blk EmptyMK))
forall (m :: * -> *) blk (l :: LedgerStateKind).
(MonadSTM m, HasHeader blk, IsLedger l, StandardHash l,
 HeaderHash l ~ HeaderHash blk) =>
LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l EmptyMK))
implGetPastLedgerState Point blk
s)
      , getHeaderStateHistory :: (l ~ ExtLedgerState blk) => STM m (HeaderStateHistory blk)
getHeaderStateHistory = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m (HeaderStateHistory blk))
-> STM m (HeaderStateHistory blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m r) -> STM m r
getEnvSTM LedgerDBHandle m l blk
h LedgerDBEnv m l blk -> STM m (HeaderStateHistory blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, l ~ ExtLedgerState blk, IsLedger (LedgerState blk),
 HasHardForkHistory blk, HasAnnTip blk) =>
LedgerDBEnv m l blk -> STM m (HeaderStateHistory blk)
implGetHeaderStateHistory
      , getForkerAtTarget :: ResourceRegistry m
-> Target (Point blk) -> m (Either GetForkerError (Forker m l blk))
getForkerAtTarget = LedgerDBHandle m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 HasLedgerTables l, LedgerSupportsProtocol blk, StandardHash l) =>
LedgerDBHandle m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
newForkerAtTarget LedgerDBHandle m l blk
h
      , validateFork :: (l ~ ExtLedgerState blk) =>
ResourceRegistry m
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> [Header blk]
-> m (ValidateResult m l blk)
validateFork = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk
    -> ResourceRegistry m
    -> (TraceValidateEvent blk -> m ())
    -> BlockCache blk
    -> Word64
    -> [Header blk]
    -> m (ValidateResult m l blk))
-> ResourceRegistry m
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> [Header blk]
-> m (ValidateResult m l blk)
forall (m :: * -> *) blk (l :: LedgerStateKind) a b c d e r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> b -> c -> d -> e -> m r)
-> a
-> b
-> c
-> d
-> e
-> m r
getEnv5 LedgerDBHandle m l blk
h (LedgerDBHandle m l blk
-> LedgerDBEnv m l blk
-> ResourceRegistry m
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> [Header blk]
-> m (ValidateResult m (ExtLedgerState blk) blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, LedgerSupportsProtocol blk, HasCallStack,
 l ~ ExtLedgerState blk) =>
LedgerDBHandle m l blk
-> LedgerDBEnv m l blk
-> ResourceRegistry m
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> [Header blk]
-> m (ValidateResult m (ExtLedgerState blk) blk)
implValidate LedgerDBHandle m l blk
h)
      , getPrevApplied :: STM m (Set (RealPoint blk))
getPrevApplied = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m (Set (RealPoint blk)))
-> STM m (Set (RealPoint blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m r) -> STM m r
getEnvSTM LedgerDBHandle m l blk
h LedgerDBEnv m l blk -> STM m (Set (RealPoint blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
MonadSTM m =>
LedgerDBEnv m l blk -> STM m (Set (RealPoint blk))
implGetPrevApplied
      , garbageCollect :: SlotNo -> STM m ()
garbageCollect = \SlotNo
s -> LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m ()) -> STM m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m r) -> STM m r
getEnvSTM LedgerDBHandle m l blk
h ((LedgerDBEnv m l blk -> SlotNo -> STM m ())
-> SlotNo -> LedgerDBEnv m l blk -> STM m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LedgerDBEnv m l blk -> SlotNo -> STM m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
MonadSTM m =>
LedgerDBEnv m l blk -> SlotNo -> STM m ()
implGarbageCollect SlotNo
s)
      , tryTakeSnapshot :: (l ~ ExtLedgerState blk) =>
Maybe (Time, Time) -> Word64 -> m SnapCounters
tryTakeSnapshot = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk
    -> Maybe (Time, Time) -> Word64 -> m SnapCounters)
-> Maybe (Time, Time)
-> Word64
-> m SnapCounters
forall (m :: * -> *) blk (l :: LedgerStateKind) a b r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> b -> m r) -> a -> b -> m r
getEnv2 LedgerDBHandle m l blk
h (HandleArgs
-> LedgerDBEnv m l blk
-> Maybe (Time, Time)
-> Word64
-> m SnapCounters
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(l ~ ExtLedgerState blk, IOLike m, LedgerSupportsProtocol blk,
 LedgerDbSerialiseConstraints blk) =>
HandleArgs
-> LedgerDBEnv m l blk
-> Maybe (Time, Time)
-> Word64
-> m SnapCounters
implTryTakeSnapshot HandleArgs
bss)
      , tryFlush :: m ()
tryFlush = LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m ()) -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m l blk
h LedgerDBEnv m l blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Applicative m =>
LedgerDBEnv m l blk -> m ()
implTryFlush
      , closeDB :: m ()
closeDB = LedgerDBHandle m l blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDBHandle m l blk -> m ()
implCloseDB LedgerDBHandle m l blk
h
      }
  , HandleArgs
-> LedgerDBHandle m (ExtLedgerState blk) blk
-> TestInternals' m blk
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk, ApplyBlock (ExtLedgerState blk) blk) =>
HandleArgs
-> LedgerDBHandle m (ExtLedgerState blk) blk
-> TestInternals' m blk
mkInternals HandleArgs
bss LedgerDBHandle m l blk
LedgerDBHandle m (ExtLedgerState blk) blk
h
  )

mkInternals ::
  forall m blk.
  ( IOLike m
  , LedgerDbSerialiseConstraints blk
  , LedgerSupportsProtocol blk
  , ApplyBlock (ExtLedgerState blk) blk
  ) =>
  HandleArgs ->
  LedgerDBHandle m (ExtLedgerState blk) blk ->
  TestInternals' m blk
mkInternals :: forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk, ApplyBlock (ExtLedgerState blk) blk) =>
HandleArgs
-> LedgerDBHandle m (ExtLedgerState blk) blk
-> TestInternals' m blk
mkInternals HandleArgs
bss LedgerDBHandle m (ExtLedgerState blk) blk
h =
  TestInternals
    { takeSnapshotNOW :: WhereToTakeSnapshot -> Maybe String -> m ()
takeSnapshotNOW = \WhereToTakeSnapshot
whereTo Maybe String
suff -> LedgerDBHandle m (ExtLedgerState blk) blk
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m (ExtLedgerState blk) blk
h ((LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \LedgerDBEnv m (ExtLedgerState blk) blk
env -> do
        let selectWhereTo :: LedgerSeq m (ExtLedgerState blk) -> StateRef m (ExtLedgerState blk)
selectWhereTo = case WhereToTakeSnapshot
whereTo of
              WhereToTakeSnapshot
TakeAtImmutableTip -> LedgerSeq m (ExtLedgerState blk) -> StateRef m (ExtLedgerState blk)
forall (m :: * -> *) (l :: LedgerStateKind).
LedgerSeq m l -> StateRef m l
anchorHandle
              WhereToTakeSnapshot
TakeAtVolatileTip -> LedgerSeq m (ExtLedgerState blk) -> StateRef m (ExtLedgerState blk)
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> StateRef m l
currentHandle
        LedgerDBEnv m (ExtLedgerState blk) blk
-> (LedgerSeq m (ExtLedgerState blk)
    -> Solo (StateRef m (ExtLedgerState blk)))
-> (Solo (StateRef m (ExtLedgerState blk)) -> m ())
-> m ()
forall (m :: * -> *) (t :: * -> *) (l :: LedgerStateKind) blk a.
(IOLike m, Traversable t) =>
LedgerDBEnv m l blk
-> (LedgerSeq m l -> t (StateRef m l))
-> (t (StateRef m l) -> m a)
-> m a
withStateRef LedgerDBEnv m (ExtLedgerState blk) blk
env (StateRef m (ExtLedgerState blk)
-> Solo (StateRef m (ExtLedgerState blk))
forall a. a -> Solo a
MkSolo (StateRef m (ExtLedgerState blk)
 -> Solo (StateRef m (ExtLedgerState blk)))
-> (LedgerSeq m (ExtLedgerState blk)
    -> StateRef m (ExtLedgerState blk))
-> LedgerSeq m (ExtLedgerState blk)
-> Solo (StateRef m (ExtLedgerState blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m (ExtLedgerState blk) -> StateRef m (ExtLedgerState blk)
selectWhereTo) ((Solo (StateRef m (ExtLedgerState blk)) -> m ()) -> m ())
-> (Solo (StateRef m (ExtLedgerState blk)) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(MkSolo StateRef m (ExtLedgerState blk)
st) ->
          m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Monad.void (m (Maybe (DiskSnapshot, RealPoint blk)) -> m ())
-> m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall a b. (a -> b) -> a -> b
$
            CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> Maybe String
-> StateRef m (ExtLedgerState blk)
-> m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot
              (TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec (TopLevelConfig blk -> CodecConfig blk)
-> (LedgerDbCfgF Identity (ExtLedgerState blk)
    -> TopLevelConfig blk)
-> LedgerDbCfgF Identity (ExtLedgerState blk)
-> CodecConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg (ExtLedgerCfg blk -> TopLevelConfig blk)
-> (LedgerDbCfgF Identity (ExtLedgerState blk) -> ExtLedgerCfg blk)
-> LedgerDbCfgF Identity (ExtLedgerState blk)
-> TopLevelConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDbCfgF Identity (ExtLedgerState blk)
-> HKD Identity (LedgerCfg (ExtLedgerState blk))
LedgerDbCfgF Identity (ExtLedgerState blk) -> ExtLedgerCfg blk
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
ledgerDbCfg (LedgerDbCfgF Identity (ExtLedgerState blk) -> CodecConfig blk)
-> LedgerDbCfgF Identity (ExtLedgerState blk) -> CodecConfig blk
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m (ExtLedgerState blk) blk
-> LedgerDbCfgF Identity (ExtLedgerState blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l
ldbCfg LedgerDBEnv m (ExtLedgerState blk) blk
env)
              (TraceSnapshotEvent blk -> TraceEvent blk
forall blk. TraceSnapshotEvent blk -> TraceEvent blk
LedgerDBSnapshotEvent (TraceSnapshotEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceSnapshotEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< LedgerDBEnv m (ExtLedgerState blk) blk -> Tracer m (TraceEvent blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> Tracer m (TraceEvent blk)
ldbTracer LedgerDBEnv m (ExtLedgerState blk) blk
env)
              (LedgerDBEnv m (ExtLedgerState blk) blk -> SomeHasFS m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SomeHasFS m
ldbHasFS LedgerDBEnv m (ExtLedgerState blk) blk
env)
              Maybe String
suff
              StateRef m (ExtLedgerState blk)
st
    , push :: ExtLedgerState blk DiffMK -> m ()
push = \ExtLedgerState blk DiffMK
st -> (ResourceRegistry m -> m ()) -> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry m -> m ()) -> m ())
-> (ResourceRegistry m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry m
reg -> do
        eFrk <- LedgerDBHandle m (ExtLedgerState blk) blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m (ExtLedgerState blk) blk))
forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 HasLedgerTables l, LedgerSupportsProtocol blk, StandardHash l) =>
LedgerDBHandle m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
newForkerAtTarget LedgerDBHandle m (ExtLedgerState blk) blk
h ResourceRegistry m
reg Target (Point blk)
forall point. Target point
VolatileTip
        case eFrk of
          Left{} -> String -> m ()
forall a. HasCallStack => String -> a
error String
"Unreachable, Volatile tip MUST be in LedgerDB"
          Right Forker m (ExtLedgerState blk) blk
frk ->
            Forker m (ExtLedgerState blk) blk
-> ExtLedgerState blk DiffMK -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> l DiffMK -> m ()
forkerPush Forker m (ExtLedgerState blk) blk
frk ExtLedgerState blk DiffMK
st m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Forker m (ExtLedgerState blk) blk -> STM m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> STM m ()
forkerCommit Forker m (ExtLedgerState blk) blk
frk) m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Forker m (ExtLedgerState blk) blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> m ()
forkerClose Forker m (ExtLedgerState blk) blk
frk
    , reapplyThenPushNOW :: blk -> m ()
reapplyThenPushNOW = \blk
blk -> LedgerDBHandle m (ExtLedgerState blk) blk
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m (ExtLedgerState blk) blk
h ((LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \LedgerDBEnv m (ExtLedgerState blk) blk
env -> (ResourceRegistry m -> m ()) -> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry m -> m ()) -> m ())
-> (ResourceRegistry m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry m
reg -> do
        eFrk <- LedgerDBHandle m (ExtLedgerState blk) blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m (ExtLedgerState blk) blk))
forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 HasLedgerTables l, LedgerSupportsProtocol blk, StandardHash l) =>
LedgerDBHandle m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
newForkerAtTarget LedgerDBHandle m (ExtLedgerState blk) blk
h ResourceRegistry m
reg Target (Point blk)
forall point. Target point
VolatileTip
        case eFrk of
          Left{} -> String -> m ()
forall a. HasCallStack => String -> a
error String
"Unreachable, Volatile tip MUST be in LedgerDB"
          Right Forker m (ExtLedgerState blk) blk
frk -> do
            st <- STM m (ExtLedgerState blk EmptyMK)
-> m (ExtLedgerState blk EmptyMK)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ExtLedgerState blk EmptyMK)
 -> m (ExtLedgerState blk EmptyMK))
-> STM m (ExtLedgerState blk EmptyMK)
-> m (ExtLedgerState blk EmptyMK)
forall a b. (a -> b) -> a -> b
$ Forker m (ExtLedgerState blk) blk
-> STM m (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> STM m (l EmptyMK)
forkerGetLedgerState Forker m (ExtLedgerState blk) blk
frk
            tables <- forkerReadTables frk (getBlockKeySets blk)
            let st' =
                  ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> blk
-> ExtLedgerState blk ValuesMK
-> ExtLedgerState blk DiffMK
forall (l :: LedgerStateKind) blk.
ApplyBlock l blk =>
ComputeLedgerEvents -> LedgerCfg l -> blk -> l ValuesMK -> l DiffMK
tickThenReapply
                    (LedgerDbCfgF Identity (ExtLedgerState blk) -> ComputeLedgerEvents
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> ComputeLedgerEvents
ledgerDbCfgComputeLedgerEvents (LedgerDBEnv m (ExtLedgerState blk) blk
-> LedgerDbCfgF Identity (ExtLedgerState blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l
ldbCfg LedgerDBEnv m (ExtLedgerState blk) blk
env))
                    (LedgerDbCfgF Identity (ExtLedgerState blk)
-> HKD Identity (LedgerCfg (ExtLedgerState blk))
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
ledgerDbCfg (LedgerDbCfgF Identity (ExtLedgerState blk)
 -> HKD Identity (LedgerCfg (ExtLedgerState blk)))
-> LedgerDbCfgF Identity (ExtLedgerState blk)
-> HKD Identity (LedgerCfg (ExtLedgerState blk))
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m (ExtLedgerState blk) blk
-> LedgerDbCfgF Identity (ExtLedgerState blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l
ldbCfg LedgerDBEnv m (ExtLedgerState blk) blk
env)
                    blk
blk
                    (ExtLedgerState blk EmptyMK
st ExtLedgerState blk EmptyMK
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> ExtLedgerState blk ValuesMK
forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
ExtLedgerState blk any
-> LedgerTables (ExtLedgerState blk) mk -> ExtLedgerState blk mk
forall (l :: LedgerStateKind) (mk :: MapKind) (any :: MapKind).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
`withLedgerTables` LedgerTables (ExtLedgerState blk) ValuesMK
tables)
            forkerPush frk st' >> atomically (forkerCommit frk) >> forkerClose frk
    , wipeLedgerDB :: m ()
wipeLedgerDB = LedgerDBHandle m (ExtLedgerState blk) blk
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m (ExtLedgerState blk) blk
h ((LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ SomeHasFS m -> m ()
forall (m :: * -> *). Monad m => SomeHasFS m -> m ()
destroySnapshots (SomeHasFS m -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> SomeHasFS m)
-> LedgerDBEnv m (ExtLedgerState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBEnv m (ExtLedgerState blk) blk -> SomeHasFS m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SomeHasFS m
ldbHasFS
    , closeLedgerDB :: m ()
closeLedgerDB =
        let LDBHandle StrictTVar m (LedgerDBState m (ExtLedgerState blk) blk)
tvar = LedgerDBHandle m (ExtLedgerState blk) blk
h
         in STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (LedgerDBState m (ExtLedgerState blk) blk)
-> LedgerDBState m (ExtLedgerState blk) blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (LedgerDBState m (ExtLedgerState blk) blk)
tvar LedgerDBState m (ExtLedgerState blk) blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBState m l blk
LedgerDBClosed)
    , truncateSnapshots :: m ()
truncateSnapshots = LedgerDBHandle m (ExtLedgerState blk) blk
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m (ExtLedgerState blk) blk
h ((LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ SomeHasFS m -> m ()
forall (m :: * -> *). MonadThrow m => SomeHasFS m -> m ()
implIntTruncateSnapshots (SomeHasFS m -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> SomeHasFS m)
-> LedgerDBEnv m (ExtLedgerState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBEnv m (ExtLedgerState blk) blk -> SomeHasFS m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SomeHasFS m
ldbHasFS
    , getNumLedgerTablesHandles :: m Word64
getNumLedgerTablesHandles = LedgerDBHandle m (ExtLedgerState blk) blk
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m Word64) -> m Word64
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m (ExtLedgerState blk) blk
h ((LedgerDBEnv m (ExtLedgerState blk) blk -> m Word64) -> m Word64)
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m Word64) -> m Word64
forall a b. (a -> b) -> a -> b
$ \LedgerDBEnv m (ExtLedgerState blk) blk
env -> do
        l <- StrictTVar m (LedgerSeq m (ExtLedgerState blk))
-> m (LedgerSeq m (ExtLedgerState blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (LedgerDBEnv m (ExtLedgerState blk) blk
-> StrictTVar m (LedgerSeq m (ExtLedgerState blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
ldbSeq LedgerDBEnv m (ExtLedgerState blk) blk
env)
        -- We always have a state at the anchor.
        pure $ 1 + maxRollback l
    }
 where
  takeSnapshot ::
    CodecConfig blk ->
    Tracer m (TraceSnapshotEvent blk) ->
    SomeHasFS m ->
    Maybe String ->
    StateRef m (ExtLedgerState blk) ->
    m (Maybe (DiskSnapshot, RealPoint blk))
  takeSnapshot :: CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> Maybe String
-> StateRef m (ExtLedgerState blk)
-> m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot = case HandleArgs
bss of
    HandleArgs
InMemoryHandleArgs -> CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> Maybe String
-> StateRef m (ExtLedgerState blk)
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk) =>
CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> Maybe String
-> StateRef m (ExtLedgerState blk)
-> m (Maybe (DiskSnapshot, RealPoint blk))
InMemory.takeSnapshot
    LSMHandleArgs Void
x -> Void
-> CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> Maybe String
-> StateRef m (ExtLedgerState blk)
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall a. Void -> a
absurd Void
x

-- | Testing only! Truncate all snapshots in the DB.
implIntTruncateSnapshots :: MonadThrow m => SomeHasFS m -> m ()
implIntTruncateSnapshots :: forall (m :: * -> *). MonadThrow m => SomeHasFS m -> m ()
implIntTruncateSnapshots sfs :: SomeHasFS m
sfs@(SomeHasFS HasFS m h
fs) = do
  SomeHasFS m -> (String -> m ()) -> m ()
forall (m :: * -> *) a.
Monad m =>
SomeHasFS m -> (String -> m a) -> m ()
snapshotsMapM_ SomeHasFS m
sfs ([String] -> m ()
truncateRecursively ([String] -> m ()) -> (String -> [String]) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> [String]
forall a. a -> [a] -> [a]
: []))
 where
  truncateRecursively :: [String] -> m ()
truncateRecursively [String]
pre = do
    dirs <- HasFS m h -> HasCallStack => FsPath -> m (Set String)
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set String)
listDirectory HasFS m h
fs ([String] -> FsPath
mkFsPath [String]
pre)
    mapM_
      ( \String
d -> do
          let d' :: [String]
d' = [String]
pre [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
d]
          isDir <- HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesDirectoryExist HasFS m h
fs (FsPath -> m Bool) -> FsPath -> m Bool
forall a b. (a -> b) -> a -> b
$ [String] -> FsPath
mkFsPath [String]
d'
          if isDir
            then truncateRecursively d'
            else withFile fs (mkFsPath d') (AppendMode AllowExisting) $ \Handle h
h -> HasFS m h -> HasCallStack => Handle h -> Word64 -> m ()
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ()
hTruncate HasFS m h
fs Handle h
h Word64
0
      )
      dirs

implGetVolatileTip ::
  (MonadSTM m, GetTip l) =>
  LedgerDBEnv m l blk ->
  STM m (l EmptyMK)
implGetVolatileTip :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l) =>
LedgerDBEnv m l blk -> STM m (l EmptyMK)
implGetVolatileTip = (LedgerSeq m l -> l EmptyMK)
-> STM m (LedgerSeq m l) -> STM m (l EmptyMK)
forall a b. (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LedgerSeq m l -> l EmptyMK
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> l EmptyMK
current (STM m (LedgerSeq m l) -> STM m (l EmptyMK))
-> (LedgerDBEnv m l blk -> STM m (LedgerSeq m l))
-> LedgerDBEnv m l blk
-> STM m (l EmptyMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictTVar m (LedgerSeq m l) -> STM m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (StrictTVar m (LedgerSeq m l) -> STM m (LedgerSeq m l))
-> (LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l))
-> LedgerDBEnv m l blk
-> STM m (LedgerSeq m l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
ldbSeq

implGetImmutableTip ::
  MonadSTM m =>
  LedgerDBEnv m l blk ->
  STM m (l EmptyMK)
implGetImmutableTip :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
MonadSTM m =>
LedgerDBEnv m l blk -> STM m (l EmptyMK)
implGetImmutableTip = (LedgerSeq m l -> l EmptyMK)
-> STM m (LedgerSeq m l) -> STM m (l EmptyMK)
forall a b. (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LedgerSeq m l -> l EmptyMK
forall (m :: * -> *) (l :: LedgerStateKind).
LedgerSeq m l -> l EmptyMK
anchor (STM m (LedgerSeq m l) -> STM m (l EmptyMK))
-> (LedgerDBEnv m l blk -> STM m (LedgerSeq m l))
-> LedgerDBEnv m l blk
-> STM m (l EmptyMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictTVar m (LedgerSeq m l) -> STM m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (StrictTVar m (LedgerSeq m l) -> STM m (LedgerSeq m l))
-> (LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l))
-> LedgerDBEnv m l blk
-> STM m (LedgerSeq m l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
ldbSeq

implGetPastLedgerState ::
  ( MonadSTM m
  , HasHeader blk
  , IsLedger l
  , StandardHash l
  , HeaderHash l ~ HeaderHash blk
  ) =>
  LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l EmptyMK))
implGetPastLedgerState :: forall (m :: * -> *) blk (l :: LedgerStateKind).
(MonadSTM m, HasHeader blk, IsLedger l, StandardHash l,
 HeaderHash l ~ HeaderHash blk) =>
LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l EmptyMK))
implGetPastLedgerState LedgerDBEnv m l blk
env Point blk
point = Point blk -> LedgerSeq m l -> Maybe (l EmptyMK)
forall blk (l :: LedgerStateKind) (m :: * -> *).
(HasHeader blk, GetTip l, HeaderHash l ~ HeaderHash blk,
 StandardHash l) =>
Point blk -> LedgerSeq m l -> Maybe (l EmptyMK)
getPastLedgerAt Point blk
point (LedgerSeq m l -> Maybe (l EmptyMK))
-> STM m (LedgerSeq m l) -> STM m (Maybe (l EmptyMK))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (LedgerSeq m l) -> STM m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
ldbSeq LedgerDBEnv m l blk
env)

implGetHeaderStateHistory ::
  ( MonadSTM m
  , l ~ ExtLedgerState blk
  , IsLedger (LedgerState blk)
  , HasHardForkHistory blk
  , HasAnnTip blk
  ) =>
  LedgerDBEnv m l blk -> STM m (HeaderStateHistory blk)
implGetHeaderStateHistory :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, l ~ ExtLedgerState blk, IsLedger (LedgerState blk),
 HasHardForkHistory blk, HasAnnTip blk) =>
LedgerDBEnv m l blk -> STM m (HeaderStateHistory blk)
implGetHeaderStateHistory LedgerDBEnv m l blk
env = do
  ldb <- StrictTVar m (LedgerSeq m l) -> STM m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
ldbSeq LedgerDBEnv m l blk
env)
  let currentLedgerState = ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState (ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK)
-> ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall a b. (a -> b) -> a -> b
$ LedgerSeq m (ExtLedgerState blk) -> ExtLedgerState blk EmptyMK
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> l EmptyMK
current LedgerSeq m (ExtLedgerState blk)
ldb
      -- This summary can convert all tip slots of the ledger states in the
      -- @ledgerDb@ as these are not newer than the tip slot of the current
      -- ledger state (Property 17.1 in the Consensus report).
      summary = LedgerConfig blk
-> LedgerState blk EmptyMK -> Summary (HardForkIndices blk)
forall blk (mk :: MapKind).
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
forall (mk :: MapKind).
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
hardForkSummary (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger (TopLevelConfig blk -> LedgerConfig blk)
-> TopLevelConfig blk -> LedgerConfig blk
forall a b. (a -> b) -> a -> b
$ ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg (ExtLedgerCfg blk -> TopLevelConfig blk)
-> ExtLedgerCfg blk -> TopLevelConfig blk
forall a b. (a -> b) -> a -> b
$ LedgerDbCfgF Identity l -> HKD Identity (LedgerCfg l)
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
ledgerDbCfg (LedgerDbCfgF Identity l -> HKD Identity (LedgerCfg l))
-> LedgerDbCfgF Identity l -> HKD Identity (LedgerCfg l)
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> LedgerDbCfgF Identity l
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l
ldbCfg LedgerDBEnv m l blk
env) LedgerState blk EmptyMK
currentLedgerState
      mkHeaderStateWithTime' =
        Summary (HardForkIndices blk)
-> HeaderState blk -> HeaderStateWithTime blk
forall blk.
(HasCallStack, HasAnnTip blk) =>
Summary (HardForkIndices blk)
-> HeaderState blk -> HeaderStateWithTime blk
mkHeaderStateWithTimeFromSummary Summary (HardForkIndices blk)
summary
          (HeaderState blk -> HeaderStateWithTime blk)
-> (StateRef m (ExtLedgerState blk) -> HeaderState blk)
-> StateRef m (ExtLedgerState blk)
-> HeaderStateWithTime blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerState blk EmptyMK -> HeaderState blk
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> HeaderState blk
headerState
          (ExtLedgerState blk EmptyMK -> HeaderState blk)
-> (StateRef m (ExtLedgerState blk) -> ExtLedgerState blk EmptyMK)
-> StateRef m (ExtLedgerState blk)
-> HeaderState blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef m (ExtLedgerState blk) -> ExtLedgerState blk EmptyMK
forall (m :: * -> *) (l :: LedgerStateKind).
StateRef m l -> l EmptyMK
state
  pure
    . HeaderStateHistory
    . AS.bimap mkHeaderStateWithTime' mkHeaderStateWithTime'
    $ getLedgerSeq ldb

implValidate ::
  forall m l blk.
  ( IOLike m
  , LedgerSupportsProtocol blk
  , HasCallStack
  , l ~ ExtLedgerState blk
  ) =>
  LedgerDBHandle m l blk ->
  LedgerDBEnv m l blk ->
  ResourceRegistry m ->
  (TraceValidateEvent blk -> m ()) ->
  BlockCache blk ->
  Word64 ->
  [Header blk] ->
  m (ValidateResult m (ExtLedgerState blk) blk)
implValidate :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, LedgerSupportsProtocol blk, HasCallStack,
 l ~ ExtLedgerState blk) =>
LedgerDBHandle m l blk
-> LedgerDBEnv m l blk
-> ResourceRegistry m
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> [Header blk]
-> m (ValidateResult m (ExtLedgerState blk) blk)
implValidate LedgerDBHandle m l blk
h LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr TraceValidateEvent blk -> m ()
tr BlockCache blk
cache Word64
rollbacks [Header blk]
hdrs =
  ComputeLedgerEvents
-> ValidateArgs m blk -> m (ValidateResult' m blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, HasCallStack) =>
ComputeLedgerEvents
-> ValidateArgs m blk -> m (ValidateResult' m blk)
validate (LedgerDbCfgF Identity l -> ComputeLedgerEvents
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> ComputeLedgerEvents
ledgerDbCfgComputeLedgerEvents (LedgerDbCfgF Identity l -> ComputeLedgerEvents)
-> LedgerDbCfgF Identity l -> ComputeLedgerEvents
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> LedgerDbCfgF Identity l
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l
ldbCfg LedgerDBEnv m l blk
ldbEnv) (ValidateArgs m blk -> m (ValidateResult' m blk))
-> ValidateArgs m blk -> m (ValidateResult' m blk)
forall a b. (a -> b) -> a -> b
$
    ResolveBlock m blk
-> TopLevelConfig blk
-> ([RealPoint blk] -> STM m ())
-> STM m (Set (RealPoint blk))
-> (ResourceRegistry m
    -> Word64 -> m (Either GetForkerError (Forker' m blk)))
-> ResourceRegistry m
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> [Header blk]
-> ValidateArgs m blk
forall (m :: * -> *) blk.
ResolveBlock m blk
-> TopLevelConfig blk
-> ([RealPoint blk] -> STM m ())
-> STM m (Set (RealPoint blk))
-> (ResourceRegistry m
    -> Word64 -> m (Either GetForkerError (Forker' m blk)))
-> ResourceRegistry m
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> [Header blk]
-> ValidateArgs m blk
ValidateArgs
      (LedgerDBEnv m l blk -> ResolveBlock m blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> ResolveBlock m blk
ldbResolveBlock LedgerDBEnv m l blk
ldbEnv)
      (ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg (ExtLedgerCfg blk -> TopLevelConfig blk)
-> (LedgerDbCfgF Identity l -> ExtLedgerCfg blk)
-> LedgerDbCfgF Identity l
-> TopLevelConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDbCfgF Identity l -> HKD Identity (LedgerCfg l)
LedgerDbCfgF Identity l -> ExtLedgerCfg blk
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
ledgerDbCfg (LedgerDbCfgF Identity l -> TopLevelConfig blk)
-> LedgerDbCfgF Identity l -> TopLevelConfig blk
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> LedgerDbCfgF Identity l
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l
ldbCfg LedgerDBEnv m l blk
ldbEnv)
      ( \[RealPoint blk]
l -> do
          prev <- StrictTVar m (Set (RealPoint blk)) -> STM m (Set (RealPoint blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
ldbPrevApplied LedgerDBEnv m l blk
ldbEnv)
          writeTVar (ldbPrevApplied ldbEnv) (Foldable.foldl' (flip Set.insert) prev l)
      )
      (StrictTVar m (Set (RealPoint blk)) -> STM m (Set (RealPoint blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
ldbPrevApplied LedgerDBEnv m l blk
ldbEnv))
      (LedgerDBHandle m (ExtLedgerState blk) blk
-> ResourceRegistry m
-> Word64
-> m (Either GetForkerError (Forker' m blk))
forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBHandle m l blk
-> ResourceRegistry m
-> Word64
-> m (Either GetForkerError (Forker m l blk))
newForkerByRollback LedgerDBHandle m l blk
LedgerDBHandle m (ExtLedgerState blk) blk
h)
      ResourceRegistry m
rr
      TraceValidateEvent blk -> m ()
tr
      BlockCache blk
cache
      Word64
rollbacks
      [Header blk]
hdrs

implGetPrevApplied :: MonadSTM m => LedgerDBEnv m l blk -> STM m (Set (RealPoint blk))
implGetPrevApplied :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
MonadSTM m =>
LedgerDBEnv m l blk -> STM m (Set (RealPoint blk))
implGetPrevApplied LedgerDBEnv m l blk
env = StrictTVar m (Set (RealPoint blk)) -> STM m (Set (RealPoint blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
ldbPrevApplied LedgerDBEnv m l blk
env)

-- | Remove all points with a slot older than the given slot from the set of
-- previously applied points.
implGarbageCollect :: MonadSTM m => LedgerDBEnv m l blk -> SlotNo -> STM m ()
implGarbageCollect :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
MonadSTM m =>
LedgerDBEnv m l blk -> SlotNo -> STM m ()
implGarbageCollect LedgerDBEnv m l blk
env 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 (LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
ldbPrevApplied LedgerDBEnv m l blk
env) ((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)

implTryTakeSnapshot ::
  forall m l blk.
  ( l ~ ExtLedgerState blk
  , IOLike m
  , LedgerSupportsProtocol blk
  , LedgerDbSerialiseConstraints blk
  ) =>
  HandleArgs ->
  LedgerDBEnv m l blk ->
  Maybe (Time, Time) ->
  Word64 ->
  m SnapCounters
implTryTakeSnapshot :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(l ~ ExtLedgerState blk, IOLike m, LedgerSupportsProtocol blk,
 LedgerDbSerialiseConstraints blk) =>
HandleArgs
-> LedgerDBEnv m l blk
-> Maybe (Time, Time)
-> Word64
-> m SnapCounters
implTryTakeSnapshot HandleArgs
bss LedgerDBEnv m l blk
env Maybe (Time, Time)
mTime Word64
nrBlocks =
  if SnapshotPolicy -> Maybe DiffTime -> Word64 -> Bool
onDiskShouldTakeSnapshot (LedgerDBEnv m l blk -> SnapshotPolicy
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotPolicy
ldbSnapshotPolicy LedgerDBEnv m l blk
env) ((Time -> Time -> DiffTime) -> (Time, Time) -> DiffTime
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Time -> Time -> DiffTime) -> Time -> Time -> DiffTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip Time -> Time -> DiffTime
diffTime) ((Time, Time) -> DiffTime) -> Maybe (Time, Time) -> Maybe DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Time, Time)
mTime) Word64
nrBlocks
    then do
      LedgerDBEnv m l blk
-> (LedgerSeq m l -> Solo (StateRef m l))
-> (Solo (StateRef m l) -> m ())
-> m ()
forall (m :: * -> *) (t :: * -> *) (l :: LedgerStateKind) blk a.
(IOLike m, Traversable t) =>
LedgerDBEnv m l blk
-> (LedgerSeq m l -> t (StateRef m l))
-> (t (StateRef m l) -> m a)
-> m a
withStateRef LedgerDBEnv m l blk
env (StateRef m l -> Solo (StateRef m l)
forall a. a -> Solo a
MkSolo (StateRef m l -> Solo (StateRef m l))
-> (LedgerSeq m l -> StateRef m l)
-> LedgerSeq m l
-> Solo (StateRef m l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m l -> StateRef m l
forall (m :: * -> *) (l :: LedgerStateKind).
LedgerSeq m l -> StateRef m l
anchorHandle) ((Solo (StateRef m l) -> m ()) -> m ())
-> (Solo (StateRef m l) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(MkSolo StateRef m l
st) ->
        m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Monad.void (m (Maybe (DiskSnapshot, RealPoint blk)) -> m ())
-> m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall a b. (a -> b) -> a -> b
$
          CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> StateRef m (ExtLedgerState blk)
-> m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot
            (TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec (TopLevelConfig blk -> CodecConfig blk)
-> (LedgerDbCfgF Identity l -> TopLevelConfig blk)
-> LedgerDbCfgF Identity l
-> CodecConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg (ExtLedgerCfg blk -> TopLevelConfig blk)
-> (LedgerDbCfgF Identity l -> ExtLedgerCfg blk)
-> LedgerDbCfgF Identity l
-> TopLevelConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDbCfgF Identity l -> HKD Identity (LedgerCfg l)
LedgerDbCfgF Identity l -> ExtLedgerCfg blk
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
ledgerDbCfg (LedgerDbCfgF Identity l -> CodecConfig blk)
-> LedgerDbCfgF Identity l -> CodecConfig blk
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> LedgerDbCfgF Identity l
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l
ldbCfg LedgerDBEnv m l blk
env)
            (TraceSnapshotEvent blk -> TraceEvent blk
forall blk. TraceSnapshotEvent blk -> TraceEvent blk
LedgerDBSnapshotEvent (TraceSnapshotEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceSnapshotEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< LedgerDBEnv m l blk -> Tracer m (TraceEvent blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> Tracer m (TraceEvent blk)
ldbTracer LedgerDBEnv m l blk
env)
            (LedgerDBEnv m l blk -> SomeHasFS m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SomeHasFS m
ldbHasFS LedgerDBEnv m l blk
env)
            StateRef m l
StateRef m (ExtLedgerState blk)
st
      m [DiskSnapshot] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Monad.void (m [DiskSnapshot] -> m ()) -> m [DiskSnapshot] -> m ()
forall a b. (a -> b) -> a -> b
$
        Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m -> SnapshotPolicy -> m [DiskSnapshot]
forall (m :: * -> *) r.
Monad m =>
Tracer m (TraceSnapshotEvent r)
-> SomeHasFS m -> SnapshotPolicy -> m [DiskSnapshot]
trimSnapshots
          (TraceSnapshotEvent blk -> TraceEvent blk
forall blk. TraceSnapshotEvent blk -> TraceEvent blk
LedgerDBSnapshotEvent (TraceSnapshotEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceSnapshotEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< LedgerDBEnv m l blk -> Tracer m (TraceEvent blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> Tracer m (TraceEvent blk)
ldbTracer LedgerDBEnv m l blk
env)
          (LedgerDBEnv m l blk -> SomeHasFS m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SomeHasFS m
ldbHasFS LedgerDBEnv m l blk
env)
          (LedgerDBEnv m l blk -> SnapshotPolicy
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotPolicy
ldbSnapshotPolicy LedgerDBEnv m l blk
env)
      (Maybe Time -> Word64 -> SnapCounters
`SnapCounters` Word64
0) (Maybe Time -> SnapCounters)
-> (Time -> Maybe Time) -> Time -> SnapCounters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time -> Maybe Time
forall a. a -> Maybe a
Just (Time -> SnapCounters) -> m Time -> m SnapCounters
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Time -> ((Time, Time) -> m Time) -> Maybe (Time, Time) -> m Time
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime (Time -> m Time
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> m Time)
-> ((Time, Time) -> Time) -> (Time, Time) -> m Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, Time) -> Time
forall a b. (a, b) -> b
snd) Maybe (Time, Time)
mTime
    else
      SnapCounters -> m SnapCounters
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapCounters -> m SnapCounters) -> SnapCounters -> m SnapCounters
forall a b. (a -> b) -> a -> b
$ Maybe Time -> Word64 -> SnapCounters
SnapCounters ((Time, Time) -> Time
forall a b. (a, b) -> a
fst ((Time, Time) -> Time) -> Maybe (Time, Time) -> Maybe Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Time, Time)
mTime) Word64
nrBlocks
 where
  takeSnapshot ::
    CodecConfig blk ->
    Tracer m (TraceSnapshotEvent blk) ->
    SomeHasFS m ->
    StateRef m (ExtLedgerState blk) ->
    m (Maybe (DiskSnapshot, RealPoint blk))
  takeSnapshot :: CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> StateRef m (ExtLedgerState blk)
-> m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot CodecConfig blk
config Tracer m (TraceSnapshotEvent blk)
trcr SomeHasFS m
fs StateRef m (ExtLedgerState blk)
ref = case HandleArgs
bss of
    HandleArgs
InMemoryHandleArgs ->
      CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> Maybe String
-> StateRef m (ExtLedgerState blk)
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk) =>
CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> Maybe String
-> StateRef m (ExtLedgerState blk)
-> m (Maybe (DiskSnapshot, RealPoint blk))
InMemory.takeSnapshot
        CodecConfig blk
config
        Tracer m (TraceSnapshotEvent blk)
trcr
        SomeHasFS m
fs
        Maybe String
forall a. Maybe a
Nothing
        StateRef m (ExtLedgerState blk)
ref
    LSMHandleArgs Void
x -> Void -> m (Maybe (DiskSnapshot, RealPoint blk))
forall a. Void -> a
absurd Void
x

-- In the first version of the LedgerDB for UTxO-HD, there is a need to
-- periodically flush the accumulated differences to the disk. However, in the
-- second version there is no need to do so, and because of that, this function
-- does nothing in this case.
implTryFlush :: Applicative m => LedgerDBEnv m l blk -> m ()
implTryFlush :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
Applicative m =>
LedgerDBEnv m l blk -> m ()
implTryFlush LedgerDBEnv m l blk
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

implCloseDB :: IOLike m => LedgerDBHandle m l blk -> m ()
implCloseDB :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDBHandle m l blk -> m ()
implCloseDB (LDBHandle StrictTVar m (LedgerDBState m l blk)
varState) =
  STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
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 (LedgerDBState m l blk)
-> STM m (LedgerDBState m l blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (LedgerDBState m l blk)
varState STM m (LedgerDBState m l blk)
-> (LedgerDBState m l blk -> STM m ()) -> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- Idempotent
      LedgerDBState m l blk
LedgerDBClosed -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      LedgerDBOpen LedgerDBEnv m l blk
env -> do
        StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
-> Map ForkerKey (ForkerEnv m l blk) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (LedgerDBEnv m l blk
-> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk
-> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
ldbForkers LedgerDBEnv m l blk
env) Map ForkerKey (ForkerEnv m l blk)
forall k a. Map k a
Map.empty
        StrictTVar m (LedgerDBState m l blk)
-> LedgerDBState m l blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (LedgerDBState m l blk)
varState LedgerDBState m l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBState m l blk
LedgerDBClosed

{-------------------------------------------------------------------------------
  The LedgerDBEnv
-------------------------------------------------------------------------------}

type LedgerDBEnv :: (Type -> Type) -> LedgerStateKind -> Type -> Type
data LedgerDBEnv m l blk = LedgerDBEnv
  { forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
ldbSeq :: !(StrictTVar m (LedgerSeq m l))
  -- ^ INVARIANT: the tip of the 'LedgerDB' is always in sync with the tip of
  -- the current chain of the ChainDB.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
ldbPrevApplied :: !(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.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk
-> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
ldbForkers :: !(StrictTVar m (Map ForkerKey (ForkerEnv m l blk)))
  -- ^ Open forkers.
  --
  -- INVARIANT: a forker is open iff its 'ForkerKey' is in this 'Map.
  --
  -- The resources that could possibly be held by these forkers will
  -- be released by each one of the client's registries. This means
  -- that for example ChainSelection will, upon closing its registry,
  -- release its forker and any resources associated.
  --
  -- Upon closing the LedgerDB we will overwrite this variable such
  -- that existing forkers can only be closed, as closing doesn't
  -- involve accessing this map (other than possibly removing the
  -- forker from it if the map still exists).
  --
  -- As the LedgerDB should outlive any clients, this is fine.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m ForkerKey
ldbNextForkerKey :: !(StrictTVar m ForkerKey)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotPolicy
ldbSnapshotPolicy :: !SnapshotPolicy
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> Tracer m (TraceEvent blk)
ldbTracer :: !(Tracer m (TraceEvent blk))
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l
ldbCfg :: !(LedgerDbCfg l)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SomeHasFS m
ldbHasFS :: !(SomeHasFS m)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> ResolveBlock m blk
ldbResolveBlock :: !(ResolveBlock m blk)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> QueryBatchSize
ldbQueryBatchSize :: !QueryBatchSize
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> RAWLock m ()
ldbOpenHandlesLock :: !(RAWLock m ())
  -- ^ While holding a read lock (at least), all handles in the 'ldbSeq' are
  -- guaranteed to be open. During this time, the handle can be duplicated and
  -- then be used independently, see 'getStateRef' and 'withStateRef'.
  --
  -- Therefore, closing any handles which were previously in 'ldbSeq' requires
  -- acquiring a write lock. Concretely, both of the following approaches are
  -- fine:
  --
  --  * Modify 'ldbSeq' without any locking, and then close the removed handles
  --    while holding a write lock. See e.g. 'closeForkerEnv'.
  --
  --  * Modify 'ldbSeq' while holding a write lock, and then close the removed
  --    handles without any locking.
  }
  deriving (forall x. LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x)
-> (forall x. Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk)
-> Generic (LedgerDBEnv m l blk)
forall x. Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
forall x. LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) (l :: LedgerStateKind) blk x.
Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk x.
LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
$cfrom :: forall (m :: * -> *) (l :: LedgerStateKind) blk x.
LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
from :: forall x. LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
$cto :: forall (m :: * -> *) (l :: LedgerStateKind) blk x.
Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
to :: forall x. Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
Generic

deriving instance
  ( IOLike m
  , LedgerSupportsProtocol blk
  , NoThunks (l EmptyMK)
  , NoThunks (TxIn l)
  , NoThunks (TxOut l)
  , NoThunks (LedgerCfg l)
  ) =>
  NoThunks (LedgerDBEnv m l blk)

{-------------------------------------------------------------------------------
  The LedgerDBHandle
-------------------------------------------------------------------------------}

type LedgerDBHandle :: (Type -> Type) -> LedgerStateKind -> Type -> Type
newtype LedgerDBHandle m l blk
  = LDBHandle (StrictTVar m (LedgerDBState m l blk))
  deriving (forall x.
 LedgerDBHandle m l blk -> Rep (LedgerDBHandle m l blk) x)
-> (forall x.
    Rep (LedgerDBHandle m l blk) x -> LedgerDBHandle m l blk)
-> Generic (LedgerDBHandle m l blk)
forall x. Rep (LedgerDBHandle m l blk) x -> LedgerDBHandle m l blk
forall x. LedgerDBHandle m l blk -> Rep (LedgerDBHandle m l blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) (l :: LedgerStateKind) blk x.
Rep (LedgerDBHandle m l blk) x -> LedgerDBHandle m l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk x.
LedgerDBHandle m l blk -> Rep (LedgerDBHandle m l blk) x
$cfrom :: forall (m :: * -> *) (l :: LedgerStateKind) blk x.
LedgerDBHandle m l blk -> Rep (LedgerDBHandle m l blk) x
from :: forall x. LedgerDBHandle m l blk -> Rep (LedgerDBHandle m l blk) x
$cto :: forall (m :: * -> *) (l :: LedgerStateKind) blk x.
Rep (LedgerDBHandle m l blk) x -> LedgerDBHandle m l blk
to :: forall x. Rep (LedgerDBHandle m l blk) x -> LedgerDBHandle m l blk
Generic

data LedgerDBState m l blk
  = LedgerDBOpen !(LedgerDBEnv m l blk)
  | LedgerDBClosed
  deriving (forall x. LedgerDBState m l blk -> Rep (LedgerDBState m l blk) x)
-> (forall x.
    Rep (LedgerDBState m l blk) x -> LedgerDBState m l blk)
-> Generic (LedgerDBState m l blk)
forall x. Rep (LedgerDBState m l blk) x -> LedgerDBState m l blk
forall x. LedgerDBState m l blk -> Rep (LedgerDBState m l blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) (l :: LedgerStateKind) blk x.
Rep (LedgerDBState m l blk) x -> LedgerDBState m l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk x.
LedgerDBState m l blk -> Rep (LedgerDBState m l blk) x
$cfrom :: forall (m :: * -> *) (l :: LedgerStateKind) blk x.
LedgerDBState m l blk -> Rep (LedgerDBState m l blk) x
from :: forall x. LedgerDBState m l blk -> Rep (LedgerDBState m l blk) x
$cto :: forall (m :: * -> *) (l :: LedgerStateKind) blk x.
Rep (LedgerDBState m l blk) x -> LedgerDBState m l blk
to :: forall x. Rep (LedgerDBState m l blk) x -> LedgerDBState m l blk
Generic

deriving instance
  ( IOLike m
  , LedgerSupportsProtocol blk
  , NoThunks (l EmptyMK)
  , NoThunks (TxIn l)
  , NoThunks (TxOut l)
  , NoThunks (LedgerCfg l)
  ) =>
  NoThunks (LedgerDBState m l blk)

-- | Check if the LedgerDB is open, if so, executing the given function on the
-- 'LedgerDBEnv', otherwise, throw a 'CloseDBError'.
getEnv ::
  forall m l blk r.
  (IOLike m, HasCallStack, HasHeader blk) =>
  LedgerDBHandle m l blk ->
  (LedgerDBEnv m l blk -> m r) ->
  m r
getEnv :: forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv (LDBHandle StrictTVar m (LedgerDBState m l blk)
varState) LedgerDBEnv m l blk -> m r
f =
  StrictTVar m (LedgerDBState m l blk) -> m (LedgerDBState m l blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (LedgerDBState m l blk)
varState m (LedgerDBState m l blk) -> (LedgerDBState m l blk -> m r) -> m r
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    LedgerDBOpen LedgerDBEnv m l blk
env -> LedgerDBEnv m l blk -> m r
f LedgerDBEnv m l blk
env
    LedgerDBState m l blk
LedgerDBClosed -> LedgerDbError blk -> m r
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (LedgerDbError blk -> m r) -> LedgerDbError blk -> m r
forall a b. (a -> b) -> a -> b
$ forall blk. PrettyCallStack -> LedgerDbError blk
forall {k} (blk :: k). PrettyCallStack -> LedgerDbError blk
ClosedDBError @blk PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack

-- | Variant 'of 'getEnv' for functions taking two arguments.
getEnv2 ::
  (IOLike m, HasCallStack, HasHeader blk) =>
  LedgerDBHandle m l blk ->
  (LedgerDBEnv m l blk -> a -> b -> m r) ->
  a ->
  b ->
  m r
getEnv2 :: forall (m :: * -> *) blk (l :: LedgerStateKind) a b r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> b -> m r) -> a -> b -> m r
getEnv2 LedgerDBHandle m l blk
h LedgerDBEnv m l blk -> a -> b -> m r
f a
a b
b = LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m l blk
h (\LedgerDBEnv m l blk
env -> LedgerDBEnv m l blk -> a -> b -> m r
f LedgerDBEnv m l blk
env a
a b
b)

-- | Variant 'of 'getEnv' for functions taking five arguments.
getEnv5 ::
  (IOLike m, HasCallStack, HasHeader blk) =>
  LedgerDBHandle m l blk ->
  (LedgerDBEnv m l blk -> a -> b -> c -> d -> e -> m r) ->
  a ->
  b ->
  c ->
  d ->
  e ->
  m r
getEnv5 :: forall (m :: * -> *) blk (l :: LedgerStateKind) a b c d e r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> b -> c -> d -> e -> m r)
-> a
-> b
-> c
-> d
-> e
-> m r
getEnv5 LedgerDBHandle m l blk
h LedgerDBEnv m l blk -> a -> b -> c -> d -> e -> m r
f a
a b
b c
c d
d e
e = LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m l blk
h (\LedgerDBEnv m l blk
env -> LedgerDBEnv m l blk -> a -> b -> c -> d -> e -> m r
f LedgerDBEnv m l blk
env a
a b
b c
c d
d e
e)

-- | Variant of 'getEnv' that works in 'STM'.
getEnvSTM ::
  forall m l blk r.
  (IOLike m, HasCallStack, HasHeader blk) =>
  LedgerDBHandle m l blk ->
  (LedgerDBEnv m l blk -> STM m r) ->
  STM m r
getEnvSTM :: forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m r) -> STM m r
getEnvSTM (LDBHandle StrictTVar m (LedgerDBState m l blk)
varState) LedgerDBEnv m l blk -> STM m r
f =
  StrictTVar m (LedgerDBState m l blk)
-> STM m (LedgerDBState m l blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (LedgerDBState m l blk)
varState STM m (LedgerDBState m l blk)
-> (LedgerDBState m l blk -> STM m r) -> STM m r
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    LedgerDBOpen LedgerDBEnv m l blk
env -> LedgerDBEnv m l blk -> STM m r
f LedgerDBEnv m l blk
env
    LedgerDBState m l blk
LedgerDBClosed -> LedgerDbError blk -> STM m r
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (LedgerDbError blk -> STM m r) -> LedgerDbError blk -> STM m r
forall a b. (a -> b) -> a -> b
$ forall blk. PrettyCallStack -> LedgerDbError blk
forall {k} (blk :: k). PrettyCallStack -> LedgerDbError blk
ClosedDBError @blk PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack

{-------------------------------------------------------------------------------
  Acquiring consistent views
-------------------------------------------------------------------------------}

-- | Get a 'StateRef' from the 'LedgerSeq' in the 'LedgerDBEnv', with the
-- 'LedgerTablesHandle' having been duplicated (such that the original can be
-- closed). The caller is responsible for closing the handle.
--
-- For more flexibility, an arbitrary 'Traversable' of the 'StateRef' can be
-- returned; for the simple use case of getting a single 'StateRef', use @t ~
-- 'Solo'@.
getStateRef ::
  (IOLike m, Traversable t) =>
  LedgerDBEnv m l blk ->
  (LedgerSeq m l -> t (StateRef m l)) ->
  m (t (StateRef m l))
getStateRef :: forall (m :: * -> *) (t :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, Traversable t) =>
LedgerDBEnv m l blk
-> (LedgerSeq m l -> t (StateRef m l)) -> m (t (StateRef m l))
getStateRef LedgerDBEnv m l blk
ldbEnv LedgerSeq m l -> t (StateRef m l)
project =
  RAWLock m ()
-> (() -> m (t (StateRef m l))) -> m (t (StateRef m l))
forall (m :: * -> *) st a.
(MonadSTM m, MonadCatch m, MonadThrow (STM m)) =>
RAWLock m st -> (st -> m a) -> m a
RAWLock.withReadAccess (LedgerDBEnv m l blk -> RAWLock m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> RAWLock m ()
ldbOpenHandlesLock LedgerDBEnv m l blk
ldbEnv) ((() -> m (t (StateRef m l))) -> m (t (StateRef m l)))
-> (() -> m (t (StateRef m l))) -> m (t (StateRef m l))
forall a b. (a -> b) -> a -> b
$ \() -> do
    tst <- LedgerSeq m l -> t (StateRef m l)
project (LedgerSeq m l -> t (StateRef m l))
-> m (LedgerSeq m l) -> m (t (StateRef m l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (LedgerSeq m l) -> m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
ldbSeq LedgerDBEnv m l blk
ldbEnv)
    for tst $ \StateRef m l
st -> do
      tables' <- LedgerTablesHandle m l -> m (LedgerTablesHandle m l)
forall (m :: * -> *) (l :: LedgerStateKind).
LedgerTablesHandle m l -> m (LedgerTablesHandle m l)
duplicate (LedgerTablesHandle m l -> m (LedgerTablesHandle m l))
-> LedgerTablesHandle m l -> m (LedgerTablesHandle m l)
forall a b. (a -> b) -> a -> b
$ StateRef m l -> LedgerTablesHandle m l
forall (m :: * -> *) (l :: LedgerStateKind).
StateRef m l -> LedgerTablesHandle m l
tables StateRef m l
st
      pure st{tables = tables'}

-- | Like 'StateRef', but takes care of closing the handle when the given action
-- returns or errors.
withStateRef ::
  (IOLike m, Traversable t) =>
  LedgerDBEnv m l blk ->
  (LedgerSeq m l -> t (StateRef m l)) ->
  (t (StateRef m l) -> m a) ->
  m a
withStateRef :: forall (m :: * -> *) (t :: * -> *) (l :: LedgerStateKind) blk a.
(IOLike m, Traversable t) =>
LedgerDBEnv m l blk
-> (LedgerSeq m l -> t (StateRef m l))
-> (t (StateRef m l) -> m a)
-> m a
withStateRef LedgerDBEnv m l blk
ldbEnv LedgerSeq m l -> t (StateRef m l)
project =
  m (t (StateRef m l))
-> (t (StateRef m l) -> m ()) -> (t (StateRef m l) -> m a) -> m a
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (LedgerDBEnv m l blk
-> (LedgerSeq m l -> t (StateRef m l)) -> m (t (StateRef m l))
forall (m :: * -> *) (t :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, Traversable t) =>
LedgerDBEnv m l blk
-> (LedgerSeq m l -> t (StateRef m l)) -> m (t (StateRef m l))
getStateRef LedgerDBEnv m l blk
ldbEnv LedgerSeq m l -> t (StateRef m l)
project) ((StateRef m l -> m ()) -> t (StateRef m l) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (LedgerTablesHandle m l -> m ()
forall (m :: * -> *) (l :: LedgerStateKind).
LedgerTablesHandle m l -> m ()
close (LedgerTablesHandle m l -> m ())
-> (StateRef m l -> LedgerTablesHandle m l) -> StateRef m l -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef m l -> LedgerTablesHandle m l
forall (m :: * -> *) (l :: LedgerStateKind).
StateRef m l -> LedgerTablesHandle m l
tables))

acquireAtTarget ::
  ( HeaderHash l ~ HeaderHash blk
  , IOLike m
  , GetTip l
  , StandardHash l
  , LedgerSupportsProtocol blk
  ) =>
  LedgerDBEnv m l blk ->
  Either Word64 (Target (Point blk)) ->
  m (Either GetForkerError (StateRef m l))
acquireAtTarget :: forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, GetTip l, StandardHash l,
 LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> m (Either GetForkerError (StateRef m l))
acquireAtTarget LedgerDBEnv m l blk
ldbEnv Either Word64 (Target (Point blk))
target =
  LedgerDBEnv m l blk
-> (LedgerSeq m l -> Either GetForkerError (StateRef m l))
-> m (Either GetForkerError (StateRef m l))
forall (m :: * -> *) (t :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, Traversable t) =>
LedgerDBEnv m l blk
-> (LedgerSeq m l -> t (StateRef m l)) -> m (t (StateRef m l))
getStateRef LedgerDBEnv m l blk
ldbEnv ((LedgerSeq m l -> Either GetForkerError (StateRef m l))
 -> m (Either GetForkerError (StateRef m l)))
-> (LedgerSeq m l -> Either GetForkerError (StateRef m l))
-> m (Either GetForkerError (StateRef m l))
forall a b. (a -> b) -> a -> b
$ \LedgerSeq m l
l -> case Either Word64 (Target (Point blk))
target of
    Right Target (Point blk)
VolatileTip -> StateRef m l -> Either GetForkerError (StateRef m l)
forall a. a -> Either GetForkerError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateRef m l -> Either GetForkerError (StateRef m l))
-> StateRef m l -> Either GetForkerError (StateRef m l)
forall a b. (a -> b) -> a -> b
$ LedgerSeq m l -> StateRef m l
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> StateRef m l
currentHandle LedgerSeq m l
l
    Right Target (Point blk)
ImmutableTip -> StateRef m l -> Either GetForkerError (StateRef m l)
forall a. a -> Either GetForkerError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateRef m l -> Either GetForkerError (StateRef m l))
-> StateRef m l -> Either GetForkerError (StateRef m l)
forall a b. (a -> b) -> a -> b
$ LedgerSeq m l -> StateRef m l
forall (m :: * -> *) (l :: LedgerStateKind).
LedgerSeq m l -> StateRef m l
anchorHandle LedgerSeq m l
l
    Right (SpecificPoint Point blk
pt) -> do
      let immTip :: Point l
immTip = l EmptyMK -> Point l
forall (mk :: MapKind). l mk -> Point l
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip (l EmptyMK -> Point l) -> l EmptyMK -> Point l
forall a b. (a -> b) -> a -> b
$ LedgerSeq m l -> l EmptyMK
forall (m :: * -> *) (l :: LedgerStateKind).
LedgerSeq m l -> l EmptyMK
anchor LedgerSeq m l
l
      case Point blk -> LedgerSeq m l -> Maybe (LedgerSeq m l)
forall blk (l :: LedgerStateKind) (m :: * -> *).
(HasHeader blk, GetTip l, HeaderHash l ~ HeaderHash blk,
 StandardHash l) =>
Point blk -> LedgerSeq m l -> Maybe (LedgerSeq m l)
rollback Point blk
pt LedgerSeq m l
l of
        Maybe (LedgerSeq m l)
Nothing
          | Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
pt WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< Point l -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point l
immTip -> GetForkerError -> Either GetForkerError (StateRef m l)
forall a. GetForkerError -> Either GetForkerError a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GetForkerError -> Either GetForkerError (StateRef m l))
-> GetForkerError -> Either GetForkerError (StateRef m l)
forall a b. (a -> b) -> a -> b
$ Maybe ExceededRollback -> GetForkerError
PointTooOld Maybe ExceededRollback
forall a. Maybe a
Nothing
          | Bool
otherwise -> GetForkerError -> Either GetForkerError (StateRef m l)
forall a. GetForkerError -> Either GetForkerError a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GetForkerError
PointNotOnChain
        Just LedgerSeq m l
t' -> StateRef m l -> Either GetForkerError (StateRef m l)
forall a. a -> Either GetForkerError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateRef m l -> Either GetForkerError (StateRef m l))
-> StateRef m l -> Either GetForkerError (StateRef m l)
forall a b. (a -> b) -> a -> b
$ LedgerSeq m l -> StateRef m l
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> StateRef m l
currentHandle LedgerSeq m l
t'
    Left Word64
n -> case Word64 -> LedgerSeq m l -> Maybe (LedgerSeq m l)
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
Word64 -> LedgerSeq m l -> Maybe (LedgerSeq m l)
rollbackN Word64
n LedgerSeq m l
l of
      Maybe (LedgerSeq m l)
Nothing ->
        GetForkerError -> Either GetForkerError (StateRef m l)
forall a. GetForkerError -> Either GetForkerError a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GetForkerError -> Either GetForkerError (StateRef m l))
-> GetForkerError -> Either GetForkerError (StateRef m l)
forall a b. (a -> b) -> a -> b
$
          Maybe ExceededRollback -> GetForkerError
PointTooOld (Maybe ExceededRollback -> GetForkerError)
-> Maybe ExceededRollback -> GetForkerError
forall a b. (a -> b) -> a -> b
$
            ExceededRollback -> Maybe ExceededRollback
forall a. a -> Maybe a
Just
              ExceededRollback
                { rollbackMaximum :: Word64
rollbackMaximum = LedgerSeq m l -> Word64
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> Word64
maxRollback LedgerSeq m l
l
                , rollbackRequested :: Word64
rollbackRequested = Word64
n
                }
      Just LedgerSeq m l
l' -> StateRef m l -> Either GetForkerError (StateRef m l)
forall a. a -> Either GetForkerError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateRef m l -> Either GetForkerError (StateRef m l))
-> StateRef m l -> Either GetForkerError (StateRef m l)
forall a b. (a -> b) -> a -> b
$ LedgerSeq m l -> StateRef m l
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> StateRef m l
currentHandle LedgerSeq m l
l'

newForkerAtTarget ::
  ( HeaderHash l ~ HeaderHash blk
  , IOLike m
  , IsLedger l
  , HasLedgerTables l
  , LedgerSupportsProtocol blk
  , StandardHash l
  ) =>
  LedgerDBHandle m l blk ->
  ResourceRegistry m ->
  Target (Point blk) ->
  m (Either GetForkerError (Forker m l blk))
newForkerAtTarget :: forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 HasLedgerTables l, LedgerSupportsProtocol blk, StandardHash l) =>
LedgerDBHandle m l blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (Forker m l blk))
newForkerAtTarget LedgerDBHandle m l blk
h ResourceRegistry m
rr Target (Point blk)
pt = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk
    -> m (Either GetForkerError (Forker m l blk)))
-> m (Either GetForkerError (Forker m l blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m l blk
h ((LedgerDBEnv m l blk
  -> m (Either GetForkerError (Forker m l blk)))
 -> m (Either GetForkerError (Forker m l blk)))
-> (LedgerDBEnv m l blk
    -> m (Either GetForkerError (Forker m l blk)))
-> m (Either GetForkerError (Forker m l blk))
forall a b. (a -> b) -> a -> b
$ \LedgerDBEnv m l blk
ldbEnv ->
  LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> m (Either GetForkerError (StateRef m l))
forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, GetTip l, StandardHash l,
 LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> m (Either GetForkerError (StateRef m l))
acquireAtTarget LedgerDBEnv m l blk
ldbEnv (Target (Point blk) -> Either Word64 (Target (Point blk))
forall a b. b -> Either a b
Right Target (Point blk)
pt) m (Either GetForkerError (StateRef m l))
-> (Either GetForkerError (StateRef m l)
    -> m (Either GetForkerError (Forker m l blk)))
-> m (Either GetForkerError (Forker m l blk))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (StateRef m l -> m (Forker m l blk))
-> Either GetForkerError (StateRef m l)
-> m (Either GetForkerError (Forker m l blk))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> Either GetForkerError a -> f (Either GetForkerError b)
traverse (LedgerDBHandle m l blk
-> LedgerDBEnv m l blk
-> ResourceRegistry m
-> StateRef m l
-> m (Forker m l blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasLedgerTables l, LedgerSupportsProtocol blk,
 NoThunks (l EmptyMK), GetTip l, StandardHash l) =>
LedgerDBHandle m l blk
-> LedgerDBEnv m l blk
-> ResourceRegistry m
-> StateRef m l
-> m (Forker m l blk)
newForker LedgerDBHandle m l blk
h LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr)

newForkerByRollback ::
  ( HeaderHash l ~ HeaderHash blk
  , IOLike m
  , IsLedger l
  , StandardHash l
  , HasLedgerTables l
  , LedgerSupportsProtocol blk
  ) =>
  LedgerDBHandle m l blk ->
  ResourceRegistry m ->
  Word64 ->
  m (Either GetForkerError (Forker m l blk))
newForkerByRollback :: forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBHandle m l blk
-> ResourceRegistry m
-> Word64
-> m (Either GetForkerError (Forker m l blk))
newForkerByRollback LedgerDBHandle m l blk
h ResourceRegistry m
rr Word64
n = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk
    -> m (Either GetForkerError (Forker m l blk)))
-> m (Either GetForkerError (Forker m l blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m l blk
h ((LedgerDBEnv m l blk
  -> m (Either GetForkerError (Forker m l blk)))
 -> m (Either GetForkerError (Forker m l blk)))
-> (LedgerDBEnv m l blk
    -> m (Either GetForkerError (Forker m l blk)))
-> m (Either GetForkerError (Forker m l blk))
forall a b. (a -> b) -> a -> b
$ \LedgerDBEnv m l blk
ldbEnv ->
  LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> m (Either GetForkerError (StateRef m l))
forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, GetTip l, StandardHash l,
 LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> m (Either GetForkerError (StateRef m l))
acquireAtTarget LedgerDBEnv m l blk
ldbEnv (Word64 -> Either Word64 (Target (Point blk))
forall a b. a -> Either a b
Left Word64
n) m (Either GetForkerError (StateRef m l))
-> (Either GetForkerError (StateRef m l)
    -> m (Either GetForkerError (Forker m l blk)))
-> m (Either GetForkerError (Forker m l blk))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (StateRef m l -> m (Forker m l blk))
-> Either GetForkerError (StateRef m l)
-> m (Either GetForkerError (Forker m l blk))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> Either GetForkerError a -> f (Either GetForkerError b)
traverse (LedgerDBHandle m l blk
-> LedgerDBEnv m l blk
-> ResourceRegistry m
-> StateRef m l
-> m (Forker m l blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasLedgerTables l, LedgerSupportsProtocol blk,
 NoThunks (l EmptyMK), GetTip l, StandardHash l) =>
LedgerDBHandle m l blk
-> LedgerDBEnv m l blk
-> ResourceRegistry m
-> StateRef m l
-> m (Forker m l blk)
newForker LedgerDBHandle m l blk
h LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr)

closeForkerEnv ::
  IOLike m => ForkerEnv m l blk -> m ()
closeForkerEnv :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
ForkerEnv m l blk -> m ()
closeForkerEnv ForkerEnv{foeResourcesToRelease :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk
-> (RAWLock m (), ResourceKey m, StrictTVar m (m ()))
foeResourcesToRelease = (RAWLock m ()
lock, ResourceKey m
key, StrictTVar m (m ())
toRelease)} =
  RAWLock m () -> (() -> m ((), ())) -> m ()
forall (m :: * -> *) st a.
(MonadSTM m, MonadCatch m, MonadThrow (STM m)) =>
RAWLock m st -> (st -> m (a, st)) -> m a
RAWLock.withWriteAccess RAWLock m ()
lock ((() -> m ((), ())) -> m ()) -> (() -> m ((), ())) -> m ()
forall a b. (a -> b) -> a -> b
$
    m ((), ()) -> () -> m ((), ())
forall a b. a -> b -> a
const (m ((), ()) -> () -> m ((), ())) -> m ((), ()) -> () -> m ((), ())
forall a b. (a -> b) -> a -> b
$ do
      m () -> m ()
forall a. a -> a
id (m () -> m ()) -> m (m ()) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM m (m ()) -> m (m ())
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (m ()) -> m () -> STM m (m ())
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m a
swapTVar StrictTVar m (m ())
toRelease (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
      _ <- ResourceKey m -> m (Maybe (Context m))
forall (m :: * -> *).
(MonadMask m, MonadSTM m, MonadThread m, HasCallStack) =>
ResourceKey m -> m (Maybe (Context m))
release ResourceKey m
key
      pure ((), ())

getForkerEnv ::
  forall m l blk r.
  (IOLike m, HasCallStack, HasHeader blk) =>
  LedgerDBHandle m l blk ->
  ForkerKey ->
  (ForkerEnv m l blk -> m r) ->
  m r
getForkerEnv :: forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> ForkerKey -> (ForkerEnv m l blk -> m r) -> m r
getForkerEnv (LDBHandle StrictTVar m (LedgerDBState m l blk)
varState) ForkerKey
forkerKey ForkerEnv m l blk -> m r
f = do
  forkerEnv <-
    STM m (ForkerEnv m l blk) -> m (ForkerEnv m l blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ForkerEnv m l blk) -> m (ForkerEnv m l blk))
-> STM m (ForkerEnv m l blk) -> m (ForkerEnv m l blk)
forall a b. (a -> b) -> a -> b
$
      StrictTVar m (LedgerDBState m l blk)
-> STM m (LedgerDBState m l blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (LedgerDBState m l blk)
varState STM m (LedgerDBState m l blk)
-> (LedgerDBState m l blk -> STM m (ForkerEnv m l blk))
-> STM m (ForkerEnv m l blk)
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        LedgerDBState m l blk
LedgerDBClosed -> LedgerDbError blk -> STM m (ForkerEnv m l blk)
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (LedgerDbError blk -> STM m (ForkerEnv m l blk))
-> LedgerDbError blk -> STM m (ForkerEnv m l blk)
forall a b. (a -> b) -> a -> b
$ forall blk. PrettyCallStack -> LedgerDbError blk
forall {k} (blk :: k). PrettyCallStack -> LedgerDbError blk
ClosedDBError @blk PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
        LedgerDBOpen LedgerDBEnv m l blk
env ->
          StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
-> STM m (Map ForkerKey (ForkerEnv m l blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (LedgerDBEnv m l blk
-> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk
-> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
ldbForkers LedgerDBEnv m l blk
env)
            STM m (Map ForkerKey (ForkerEnv m l blk))
-> (Map ForkerKey (ForkerEnv m l blk) -> STM m (ForkerEnv m l blk))
-> STM m (ForkerEnv m l blk)
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ( ForkerKey
-> Map ForkerKey (ForkerEnv m l blk) -> Maybe (ForkerEnv m l blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ForkerKey
forkerKey (Map ForkerKey (ForkerEnv m l blk) -> Maybe (ForkerEnv m l blk))
-> (Maybe (ForkerEnv m l blk) -> STM m (ForkerEnv m l blk))
-> Map ForkerKey (ForkerEnv m l blk)
-> STM m (ForkerEnv m l blk)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
                    Maybe (ForkerEnv m l blk)
Nothing -> LedgerDbError blk -> STM m (ForkerEnv m l blk)
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (LedgerDbError blk -> STM m (ForkerEnv m l blk))
-> LedgerDbError blk -> STM m (ForkerEnv m l blk)
forall a b. (a -> b) -> a -> b
$ forall blk. ForkerKey -> PrettyCallStack -> LedgerDbError blk
forall {k} (blk :: k).
ForkerKey -> PrettyCallStack -> LedgerDbError blk
ClosedForkerError @blk ForkerKey
forkerKey PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
                    Just ForkerEnv m l blk
forkerEnv -> ForkerEnv m l blk -> STM m (ForkerEnv m l blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForkerEnv m l blk
forkerEnv
                )
  f forkerEnv

getForkerEnv1 ::
  (IOLike m, HasCallStack, HasHeader blk) =>
  LedgerDBHandle m l blk ->
  ForkerKey ->
  (ForkerEnv m l blk -> a -> m r) ->
  a ->
  m r
getForkerEnv1 :: forall (m :: * -> *) blk (l :: LedgerStateKind) a r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> ForkerKey -> (ForkerEnv m l blk -> a -> m r) -> a -> m r
getForkerEnv1 LedgerDBHandle m l blk
h ForkerKey
forkerKey ForkerEnv m l blk -> a -> m r
f a
a = LedgerDBHandle m l blk
-> ForkerKey -> (ForkerEnv m l blk -> m r) -> m r
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> ForkerKey -> (ForkerEnv m l blk -> m r) -> m r
getForkerEnv LedgerDBHandle m l blk
h ForkerKey
forkerKey (ForkerEnv m l blk -> a -> m r
`f` a
a)

getForkerEnvSTM ::
  forall m l blk r.
  (IOLike m, HasCallStack, HasHeader blk) =>
  LedgerDBHandle m l blk ->
  ForkerKey ->
  (ForkerEnv m l blk -> STM m r) ->
  STM m r
getForkerEnvSTM :: forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> ForkerKey -> (ForkerEnv m l blk -> STM m r) -> STM m r
getForkerEnvSTM (LDBHandle StrictTVar m (LedgerDBState m l blk)
varState) ForkerKey
forkerKey ForkerEnv m l blk -> STM m r
f =
  StrictTVar m (LedgerDBState m l blk)
-> STM m (LedgerDBState m l blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (LedgerDBState m l blk)
varState STM m (LedgerDBState m l blk)
-> (LedgerDBState m l blk -> STM m r) -> STM m r
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    LedgerDBState m l blk
LedgerDBClosed -> LedgerDbError blk -> STM m r
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (LedgerDbError blk -> STM m r) -> LedgerDbError blk -> STM m r
forall a b. (a -> b) -> a -> b
$ forall blk. PrettyCallStack -> LedgerDbError blk
forall {k} (blk :: k). PrettyCallStack -> LedgerDbError blk
ClosedDBError @blk PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
    LedgerDBOpen LedgerDBEnv m l blk
env ->
      StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
-> STM m (Map ForkerKey (ForkerEnv m l blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (LedgerDBEnv m l blk
-> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk
-> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
ldbForkers LedgerDBEnv m l blk
env)
        STM m (Map ForkerKey (ForkerEnv m l blk))
-> (Map ForkerKey (ForkerEnv m l blk) -> STM m r) -> STM m r
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ( ForkerKey
-> Map ForkerKey (ForkerEnv m l blk) -> Maybe (ForkerEnv m l blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ForkerKey
forkerKey (Map ForkerKey (ForkerEnv m l blk) -> Maybe (ForkerEnv m l blk))
-> (Maybe (ForkerEnv m l blk) -> STM m r)
-> Map ForkerKey (ForkerEnv m l blk)
-> STM m r
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
                Maybe (ForkerEnv m l blk)
Nothing -> LedgerDbError blk -> STM m r
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (LedgerDbError blk -> STM m r) -> LedgerDbError blk -> STM m r
forall a b. (a -> b) -> a -> b
$ forall blk. ForkerKey -> PrettyCallStack -> LedgerDbError blk
forall {k} (blk :: k).
ForkerKey -> PrettyCallStack -> LedgerDbError blk
ClosedForkerError @blk ForkerKey
forkerKey PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
                Just ForkerEnv m l blk
forkerEnv -> ForkerEnv m l blk -> STM m r
f ForkerEnv m l blk
forkerEnv
            )

-- | Will release all handles in the 'foeLedgerSeq'.
--
-- This function receives an environment instead of reading it from
-- the DB such that we can close the forker even if the LedgerDB is
-- closed. In fact this should never happen as clients of the LedgerDB
-- (which are the ones opening forkers) should never outlive the
-- LedgerDB.
implForkerClose ::
  IOLike m =>
  LedgerDBHandle m l blk ->
  ForkerKey ->
  ForkerEnv m l blk ->
  m ()
implForkerClose :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDBHandle m l blk -> ForkerKey -> ForkerEnv m l blk -> m ()
implForkerClose (LDBHandle StrictTVar m (LedgerDBState m l blk)
varState) ForkerKey
forkerKey ForkerEnv m l blk
forkerEnv = do
  frk <-
    STM m (Maybe (ForkerEnv m l blk)) -> m (Maybe (ForkerEnv m l blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (ForkerEnv m l blk))
 -> m (Maybe (ForkerEnv m l blk)))
-> STM m (Maybe (ForkerEnv m l blk))
-> m (Maybe (ForkerEnv m l blk))
forall a b. (a -> b) -> a -> b
$
      StrictTVar m (LedgerDBState m l blk)
-> STM m (LedgerDBState m l blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (LedgerDBState m l blk)
varState STM m (LedgerDBState m l blk)
-> (LedgerDBState m l blk -> STM m (Maybe (ForkerEnv m l blk)))
-> STM m (Maybe (ForkerEnv m l blk))
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        LedgerDBState m l blk
LedgerDBClosed -> Maybe (ForkerEnv m l blk) -> STM m (Maybe (ForkerEnv m l blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ForkerEnv m l blk)
forall a. Maybe a
Nothing
        LedgerDBOpen LedgerDBEnv m l blk
ldbEnv -> do
          StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
-> (Map ForkerKey (ForkerEnv m l blk)
    -> (Maybe (ForkerEnv m l blk), Map ForkerKey (ForkerEnv m l blk)))
-> STM m (Maybe (ForkerEnv m l blk))
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar
            (LedgerDBEnv m l blk
-> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk
-> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
ldbForkers LedgerDBEnv m l blk
ldbEnv)
            (\Map ForkerKey (ForkerEnv m l blk)
m -> (ForkerKey -> ForkerEnv m l blk -> Maybe (ForkerEnv m l blk))
-> ForkerKey
-> Map ForkerKey (ForkerEnv m l blk)
-> (Maybe (ForkerEnv m l blk), Map ForkerKey (ForkerEnv m l blk))
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\ForkerKey
_ ForkerEnv m l blk
_ -> Maybe (ForkerEnv m l blk)
forall a. Maybe a
Nothing) ForkerKey
forkerKey Map ForkerKey (ForkerEnv m l blk)
m)

  case frk of
    Maybe (ForkerEnv m l blk)
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just ForkerEnv m l blk
e -> Tracer m TraceForkerEvent -> TraceForkerEvent -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (ForkerEnv m l blk -> Tracer m TraceForkerEvent
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> Tracer m TraceForkerEvent
foeTracer ForkerEnv m l blk
e) TraceForkerEvent
DanglingForkerClosed

  closeForkerEnv forkerEnv

newForker ::
  ( IOLike m
  , HasLedgerTables l
  , LedgerSupportsProtocol blk
  , NoThunks (l EmptyMK)
  , GetTip l
  , StandardHash l
  ) =>
  LedgerDBHandle m l blk ->
  LedgerDBEnv m l blk ->
  ResourceRegistry m ->
  StateRef m l ->
  m (Forker m l blk)
newForker :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasLedgerTables l, LedgerSupportsProtocol blk,
 NoThunks (l EmptyMK), GetTip l, StandardHash l) =>
LedgerDBHandle m l blk
-> LedgerDBEnv m l blk
-> ResourceRegistry m
-> StateRef m l
-> m (Forker m l blk)
newForker LedgerDBHandle m l blk
h LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr StateRef m l
st = do
  forkerKey <- STM m ForkerKey -> m ForkerKey
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m ForkerKey -> m ForkerKey) -> STM m ForkerKey -> m ForkerKey
forall a b. (a -> b) -> a -> b
$ StrictTVar m ForkerKey
-> (ForkerKey -> (ForkerKey, ForkerKey)) -> STM m ForkerKey
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar (LedgerDBEnv m l blk -> StrictTVar m ForkerKey
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m ForkerKey
ldbNextForkerKey LedgerDBEnv m l blk
ldbEnv) ((ForkerKey -> (ForkerKey, ForkerKey)) -> STM m ForkerKey)
-> (ForkerKey -> (ForkerKey, ForkerKey)) -> STM m ForkerKey
forall a b. (a -> b) -> a -> b
$ \ForkerKey
r -> (ForkerKey
r, ForkerKey
r ForkerKey -> ForkerKey -> ForkerKey
forall a. Num a => a -> a -> a
+ ForkerKey
1)
  let tr = TraceForkerEventWithKey -> TraceEvent blk
forall blk. TraceForkerEventWithKey -> TraceEvent blk
LedgerDBForkerEvent (TraceForkerEventWithKey -> TraceEvent blk)
-> (TraceForkerEvent -> TraceForkerEventWithKey)
-> TraceForkerEvent
-> TraceEvent blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForkerKey -> TraceForkerEvent -> TraceForkerEventWithKey
TraceForkerEventWithKey ForkerKey
forkerKey (TraceForkerEvent -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m TraceForkerEvent
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< LedgerDBEnv m l blk -> Tracer m (TraceEvent blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> Tracer m (TraceEvent blk)
ldbTracer LedgerDBEnv m l blk
ldbEnv
  traceWith tr ForkerOpen
  lseqVar <- newTVarIO . LedgerSeq . AS.Empty $ st
  (k, toRelease) <- allocate rr (\ResourceId
_ -> m () -> m (StrictTVar m (m ()))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())) (readTVarIO Monad.>=> id)
  let forkerEnv =
        ForkerEnv
          { foeLedgerSeq :: StrictTVar m (LedgerSeq m l)
foeLedgerSeq = StrictTVar m (LedgerSeq m l)
lseqVar
          , foeSwitchVar :: StrictTVar m (LedgerSeq m l)
foeSwitchVar = LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
ldbSeq LedgerDBEnv m l blk
ldbEnv
          , foeSecurityParam :: SecurityParam
foeSecurityParam = LedgerDbCfgF Identity l -> HKD Identity SecurityParam
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f SecurityParam
ledgerDbCfgSecParam (LedgerDbCfgF Identity l -> HKD Identity SecurityParam)
-> LedgerDbCfgF Identity l -> HKD Identity SecurityParam
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> LedgerDbCfgF Identity l
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l
ldbCfg LedgerDBEnv m l blk
ldbEnv
          , foeTracer :: Tracer m TraceForkerEvent
foeTracer = Tracer m TraceForkerEvent
tr
          , foeResourcesToRelease :: (RAWLock m (), ResourceKey m, StrictTVar m (m ()))
foeResourcesToRelease = (LedgerDBEnv m l blk -> RAWLock m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> RAWLock m ()
ldbOpenHandlesLock LedgerDBEnv m l blk
ldbEnv, ResourceKey m
k, StrictTVar m (m ())
toRelease)
          }
  atomically $ modifyTVar (ldbForkers ldbEnv) $ Map.insert forkerKey forkerEnv
  pure $
    Forker
      { forkerReadTables = getForkerEnv1 h forkerKey implForkerReadTables
      , forkerRangeReadTables =
          getForkerEnv1 h forkerKey (implForkerRangeReadTables (ldbQueryBatchSize ldbEnv))
      , forkerGetLedgerState = getForkerEnvSTM h forkerKey implForkerGetLedgerState
      , forkerReadStatistics = getForkerEnv h forkerKey implForkerReadStatistics
      , forkerPush = getForkerEnv1 h forkerKey implForkerPush
      , forkerCommit = getForkerEnvSTM h forkerKey implForkerCommit
      , forkerClose = implForkerClose h forkerKey forkerEnv
      }