{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Many functions here are very similar to the ones in
-- "Ouroboros.Consensus.Storage.LedgerDB.V2". When we delete V1, this
-- module will be gone.
module Ouroboros.Consensus.Storage.LedgerDB.V1 (mkInitDb) where

import           Control.Arrow ((>>>))
import           Control.Monad
import           Control.Monad.Except
import           Control.ResourceRegistry
import           Control.Tracer
import           Data.Bifunctor (first)
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.Maybe (isJust)
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Word
import           GHC.Generics (Generic)
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.Ledger.Tables.Utils
import           Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache
import           Ouroboros.Consensus.Storage.LedgerDB.API
import           Ouroboros.Consensus.Storage.LedgerDB.Args
import           Ouroboros.Consensus.Storage.LedgerDB.Forker
import           Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import           Ouroboros.Consensus.Storage.LedgerDB.TraceEvent
import           Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1
import           Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as BS
import           Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog as DbCh
                     (empty, flushableLength)
import           Ouroboros.Consensus.Storage.LedgerDB.V1.Forker
import           Ouroboros.Consensus.Storage.LedgerDB.V1.Lock
import           Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots
import           Ouroboros.Consensus.Util
import           Ouroboros.Consensus.Util.Args
import           Ouroboros.Consensus.Util.CallStack
import           Ouroboros.Consensus.Util.IOLike
import qualified Ouroboros.Network.AnchoredSeq as AS
import           Ouroboros.Network.Protocol.LocalStateQuery.Type
import           System.FS.API

mkInitDb ::
  forall m blk.
  ( LedgerSupportsProtocol blk
  , IOLike m
  , LedgerDbSerialiseConstraints blk
  , HasHardForkHistory blk
  , LedgerSupportsLedgerDB blk
  )
  => Complete LedgerDbArgs m blk
  -> Complete V1.LedgerDbFlavorArgs m
  -> ResolveBlock m blk
  -> InitDB (DbChangelog' blk, BackingStore' m blk) m blk
mkInitDb :: forall (m :: * -> *) blk.
(LedgerSupportsProtocol blk, IOLike m,
 LedgerDbSerialiseConstraints blk, HasHardForkHistory blk,
 LedgerSupportsLedgerDB blk) =>
Complete LedgerDbArgs m blk
-> Complete LedgerDbFlavorArgs m
-> ResolveBlock m blk
-> InitDB (DbChangelog' blk, BackingStore' m blk) m blk
mkInitDb Complete LedgerDbArgs m blk
args Complete LedgerDbFlavorArgs m
bss ResolveBlock m blk
getBlock =
  InitDB {
    initFromGenesis :: m (DbChangelog (ExtLedgerState blk),
   LedgerBackingStore m (ExtLedgerState blk))
initFromGenesis = do
      st <- m (ExtLedgerState blk ValuesMK)
HKD Identity (m (ExtLedgerState blk ValuesMK))
lgrGenesis
      let genesis = ExtLedgerState blk ValuesMK -> ExtLedgerState blk EmptyMK
forall (l :: LedgerStateKind) (mk :: MapKind).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables ExtLedgerState blk ValuesMK
st
          chlog = ExtLedgerState blk EmptyMK -> DbChangelog (ExtLedgerState blk)
forall (l :: LedgerStateKind).
(HasLedgerTables l, GetTip l) =>
l EmptyMK -> DbChangelog l
DbCh.empty ExtLedgerState blk EmptyMK
genesis
      (_, backingStore) <-
        allocate
          lgrRegistry
          (\ResourceId
_ -> Tracer m FlavorImplSpecificTrace
-> Complete BackingStoreArgs m
-> SnapshotsFS m
-> ExtLedgerState blk EmptyMK
-> LedgerTables (ExtLedgerState blk) ValuesMK
-> m (LedgerBackingStore m (ExtLedgerState blk))
forall (m :: * -> *) (l :: LedgerStateKind).
(IOLike m, HasLedgerTables l, HasCallStack,
 CanUpgradeLedgerTables l, MemPackIdx l EmptyMK ~ l EmptyMK,
 SerializeTablesWithHint l) =>
Tracer m FlavorImplSpecificTrace
-> Complete BackingStoreArgs m
-> SnapshotsFS m
-> l EmptyMK
-> LedgerTables l ValuesMK
-> m (LedgerBackingStore m l)
newBackingStore Tracer m FlavorImplSpecificTrace
bsTracer Complete BackingStoreArgs m
baArgs SnapshotsFS m
lgrHasFS' ExtLedgerState blk EmptyMK
genesis (ExtLedgerState blk ValuesMK
-> LedgerTables (ExtLedgerState blk) ValuesMK
forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
ExtLedgerState blk mk -> LedgerTables (ExtLedgerState blk) mk
forall (l :: LedgerStateKind) (mk :: MapKind).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l mk -> LedgerTables l mk
projectLedgerTables ExtLedgerState blk ValuesMK
st))
          bsClose
      pure (chlog, backingStore)
  , initFromSnapshot :: DiskSnapshot
-> m (Either
        (SnapshotFailure blk)
        ((DbChangelog (ExtLedgerState blk),
          LedgerBackingStore m (ExtLedgerState blk)),
         RealPoint blk))
initFromSnapshot =
      ExceptT
  (SnapshotFailure blk)
  m
  ((DbChangelog (ExtLedgerState blk),
    LedgerBackingStore m (ExtLedgerState blk)),
   RealPoint blk)
-> m (Either
        (SnapshotFailure blk)
        ((DbChangelog (ExtLedgerState blk),
          LedgerBackingStore m (ExtLedgerState blk)),
         RealPoint blk))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   (SnapshotFailure blk)
   m
   ((DbChangelog (ExtLedgerState blk),
     LedgerBackingStore m (ExtLedgerState blk)),
    RealPoint blk)
 -> m (Either
         (SnapshotFailure blk)
         ((DbChangelog (ExtLedgerState blk),
           LedgerBackingStore m (ExtLedgerState blk)),
          RealPoint blk)))
-> (DiskSnapshot
    -> ExceptT
         (SnapshotFailure blk)
         m
         ((DbChangelog (ExtLedgerState blk),
           LedgerBackingStore m (ExtLedgerState blk)),
          RealPoint blk))
-> DiskSnapshot
-> m (Either
        (SnapshotFailure blk)
        ((DbChangelog (ExtLedgerState blk),
          LedgerBackingStore m (ExtLedgerState blk)),
         RealPoint blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracer m FlavorImplSpecificTrace
-> Complete BackingStoreArgs m
-> CodecConfig blk
-> SnapshotsFS m
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     ((DbChangelog (ExtLedgerState blk),
       LedgerBackingStore m (ExtLedgerState blk)),
      RealPoint blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk, LedgerSupportsLedgerDB blk) =>
Tracer m FlavorImplSpecificTrace
-> Complete BackingStoreArgs m
-> CodecConfig blk
-> SnapshotsFS m
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     ((DbChangelog' blk, LedgerBackingStore m (ExtLedgerState blk)),
      RealPoint blk)
loadSnapshot Tracer m FlavorImplSpecificTrace
bsTracer Complete BackingStoreArgs m
baArgs (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) SnapshotsFS m
lgrHasFS'
  , closeDb :: (DbChangelog (ExtLedgerState blk),
 LedgerBackingStore m (ExtLedgerState blk))
-> m ()
closeDb = LedgerBackingStore m (ExtLedgerState blk) -> m ()
forall (m :: * -> *) keys values diff.
BackingStore m keys values diff -> m ()
bsClose (LedgerBackingStore m (ExtLedgerState blk) -> m ())
-> ((DbChangelog (ExtLedgerState blk),
     LedgerBackingStore m (ExtLedgerState blk))
    -> LedgerBackingStore m (ExtLedgerState blk))
-> (DbChangelog (ExtLedgerState blk),
    LedgerBackingStore m (ExtLedgerState blk))
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DbChangelog (ExtLedgerState blk),
 LedgerBackingStore m (ExtLedgerState blk))
-> LedgerBackingStore m (ExtLedgerState blk)
forall a b. (a, b) -> b
snd
  , initReapplyBlock :: LedgerDbCfg (ExtLedgerState blk)
-> blk
-> (DbChangelog (ExtLedgerState blk),
    LedgerBackingStore m (ExtLedgerState blk))
-> m (DbChangelog (ExtLedgerState blk),
      LedgerBackingStore m (ExtLedgerState blk))
initReapplyBlock = \LedgerDbCfg (ExtLedgerState blk)
cfg blk
blk (DbChangelog (ExtLedgerState blk)
chlog, LedgerBackingStore m (ExtLedgerState blk)
bstore) -> do
      !chlog' <- LedgerDbCfg (ExtLedgerState blk)
-> blk
-> KeySetsReader m (ExtLedgerState blk)
-> DbChangelog (ExtLedgerState blk)
-> m (DbChangelog (ExtLedgerState blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(Monad m, ApplyBlock l blk) =>
LedgerDbCfg l
-> blk -> KeySetsReader m l -> DbChangelog l -> m (DbChangelog l)
reapplyThenPush LedgerDbCfg (ExtLedgerState blk)
cfg blk
blk (LedgerBackingStore m (ExtLedgerState blk)
-> KeySetsReader m (ExtLedgerState blk)
forall (m :: * -> *) (l :: LedgerStateKind).
IOLike m =>
LedgerBackingStore m l -> KeySetsReader m l
readKeySets LedgerBackingStore m (ExtLedgerState blk)
bstore) DbChangelog (ExtLedgerState blk)
chlog
      -- It's OK to flush without a lock here, since the `LedgerDB` has not
      -- finished initializing, only this thread has access to the backing
      -- store.
      chlog'' <- unsafeIgnoreWriteLock
        $ if shouldFlush flushFreq (flushableLength chlog')
          then do
            let (toFlush, toKeep) = splitForFlushing chlog'
            mapM_ (flushIntoBackingStore bstore) toFlush
            pure toKeep
          else pure chlog'
      pure (chlog'', bstore)
  , currentTip :: (DbChangelog (ExtLedgerState blk),
 LedgerBackingStore m (ExtLedgerState 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)
-> ((DbChangelog (ExtLedgerState blk),
     LedgerBackingStore m (ExtLedgerState blk))
    -> ExtLedgerState blk EmptyMK)
-> (DbChangelog (ExtLedgerState blk),
    LedgerBackingStore m (ExtLedgerState blk))
-> LedgerState blk EmptyMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbChangelog (ExtLedgerState blk) -> ExtLedgerState blk EmptyMK
forall (l :: LedgerStateKind).
GetTip l =>
DbChangelog l -> l EmptyMK
current (DbChangelog (ExtLedgerState blk) -> ExtLedgerState blk EmptyMK)
-> ((DbChangelog (ExtLedgerState blk),
     LedgerBackingStore m (ExtLedgerState blk))
    -> DbChangelog (ExtLedgerState blk))
-> (DbChangelog (ExtLedgerState blk),
    LedgerBackingStore m (ExtLedgerState blk))
-> ExtLedgerState blk EmptyMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DbChangelog (ExtLedgerState blk),
 LedgerBackingStore m (ExtLedgerState blk))
-> DbChangelog (ExtLedgerState blk)
forall a b. (a, b) -> a
fst
  , pruneDb :: (DbChangelog (ExtLedgerState blk),
 LedgerBackingStore m (ExtLedgerState blk))
-> m (DbChangelog (ExtLedgerState blk),
      LedgerBackingStore m (ExtLedgerState blk))
pruneDb = (DbChangelog (ExtLedgerState blk),
 LedgerBackingStore m (ExtLedgerState blk))
-> m (DbChangelog (ExtLedgerState blk),
      LedgerBackingStore m (ExtLedgerState blk))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((DbChangelog (ExtLedgerState blk),
  LedgerBackingStore m (ExtLedgerState blk))
 -> m (DbChangelog (ExtLedgerState blk),
       LedgerBackingStore m (ExtLedgerState blk)))
-> ((DbChangelog (ExtLedgerState blk),
     LedgerBackingStore m (ExtLedgerState blk))
    -> (DbChangelog (ExtLedgerState blk),
        LedgerBackingStore m (ExtLedgerState blk)))
-> (DbChangelog (ExtLedgerState blk),
    LedgerBackingStore m (ExtLedgerState blk))
-> m (DbChangelog (ExtLedgerState blk),
      LedgerBackingStore m (ExtLedgerState blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DbChangelog (ExtLedgerState blk)
 -> DbChangelog (ExtLedgerState blk))
-> (DbChangelog (ExtLedgerState blk),
    LedgerBackingStore m (ExtLedgerState blk))
-> (DbChangelog (ExtLedgerState blk),
    LedgerBackingStore m (ExtLedgerState blk))
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: MapKind) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DbChangelog (ExtLedgerState blk)
-> DbChangelog (ExtLedgerState blk)
forall (l :: LedgerStateKind).
GetTip l =>
DbChangelog l -> DbChangelog l
pruneToImmTipOnly
  , mkLedgerDb :: (DbChangelog (ExtLedgerState blk),
 LedgerBackingStore m (ExtLedgerState blk))
-> m (LedgerDB m (ExtLedgerState blk) blk,
      TestInternals m (ExtLedgerState blk) blk)
mkLedgerDb = \(DbChangelog (ExtLedgerState blk)
db, LedgerBackingStore m (ExtLedgerState blk)
lgrBackingStore) -> do
      (varDB, prevApplied) <-
        (,) (StrictTVar m (DbChangelog (ExtLedgerState blk))
 -> StrictTVar m (Set (RealPoint blk))
 -> (StrictTVar m (DbChangelog (ExtLedgerState blk)),
     StrictTVar m (Set (RealPoint blk))))
-> m (StrictTVar m (DbChangelog (ExtLedgerState blk)))
-> m (StrictTVar m (Set (RealPoint blk))
      -> (StrictTVar m (DbChangelog (ExtLedgerState blk)),
          StrictTVar m (Set (RealPoint blk))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DbChangelog (ExtLedgerState blk)
-> m (StrictTVar m (DbChangelog (ExtLedgerState blk)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO DbChangelog (ExtLedgerState blk)
db m (StrictTVar m (Set (RealPoint blk))
   -> (StrictTVar m (DbChangelog (ExtLedgerState blk)),
       StrictTVar m (Set (RealPoint blk))))
-> m (StrictTVar m (Set (RealPoint blk)))
-> m (StrictTVar m (DbChangelog (ExtLedgerState blk)),
      StrictTVar m (Set (RealPoint blk)))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set (RealPoint blk) -> m (StrictTVar m (Set (RealPoint blk)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Set (RealPoint blk)
forall a. Set a
Set.empty
      flushLock <- mkLedgerDBLock
      forkers <- newTVarIO Map.empty
      nextForkerKey <- newTVarIO (ForkerKey 0)
      let env = LedgerDBEnv {
                 ldbChangelog :: StrictTVar m (DbChangelog (ExtLedgerState blk))
ldbChangelog       = StrictTVar m (DbChangelog (ExtLedgerState blk))
varDB
               , ldbBackingStore :: LedgerBackingStore m (ExtLedgerState blk)
ldbBackingStore    = LedgerBackingStore m (ExtLedgerState blk)
lgrBackingStore
               , ldbLock :: LedgerDBLock m
ldbLock            = LedgerDBLock m
flushLock
               , 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 :: SnapshotsFS m
ldbHasFS           = SnapshotsFS m
lgrHasFS'
               , ldbShouldFlush :: Word64 -> Bool
ldbShouldFlush     = FlushFrequency -> Word64 -> Bool
shouldFlush FlushFrequency
flushFreq
               , ldbQueryBatchSize :: QueryBatchSize
ldbQueryBatchSize  = QueryBatchSize
lgrQueryBatchSize
               , ldbResolveBlock :: ResolveBlock m blk
ldbResolveBlock    = ResolveBlock m blk
getBlock
               }
      h <- LDBHandle <$> newTVarIO (LedgerDBOpen env)
      pure $ implMkLedgerDb h
  }
  where
    bsTracer :: Tracer m FlavorImplSpecificTrace
bsTracer = 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
FlavorImplSpecificTraceV1 (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

    LedgerDbArgs {
        HKD Identity (SomeHasFS m)
lgrHasFS :: HKD Identity (SomeHasFS m)
lgrHasFS :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (SomeHasFS m)
lgrHasFS
      , Tracer m (TraceEvent blk)
lgrTracer :: Tracer m (TraceEvent blk)
lgrTracer :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> Tracer m (TraceEvent blk)
lgrTracer
      , SnapshotPolicyArgs
lgrSnapshotPolicyArgs :: SnapshotPolicyArgs
lgrSnapshotPolicyArgs :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> SnapshotPolicyArgs
lgrSnapshotPolicyArgs
      , 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 (ResourceRegistry m)
lgrRegistry :: HKD Identity (ResourceRegistry m)
lgrRegistry :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (ResourceRegistry m)
lgrRegistry
      , QueryBatchSize
lgrQueryBatchSize :: QueryBatchSize
lgrQueryBatchSize :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> QueryBatchSize
lgrQueryBatchSize
      } = Complete LedgerDbArgs m blk
args

    lgrHasFS' :: SnapshotsFS m
lgrHasFS' = SomeHasFS m -> SnapshotsFS m
forall (m :: * -> *). SomeHasFS m -> SnapshotsFS m
SnapshotsFS SomeHasFS m
HKD Identity (SomeHasFS m)
lgrHasFS

    V1Args FlushFrequency
flushFreq Complete BackingStoreArgs m
baArgs = Complete LedgerDbFlavorArgs m
bss

implMkLedgerDb ::
     forall m l blk.
     ( IOLike m
     , HasCallStack
     , StandardHash l
     , LedgerDbSerialiseConstraints blk
     , LedgerSupportsProtocol blk
     , ApplyBlock l blk
     , l ~ ExtLedgerState blk
     , HasHardForkHistory blk
     )
  => LedgerDBHandle m l blk
  -> (LedgerDB' m blk, TestInternals' m blk)
implMkLedgerDb :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasCallStack, StandardHash l,
 LedgerDbSerialiseConstraints blk, LedgerSupportsProtocol blk,
 ApplyBlock l blk, l ~ ExtLedgerState blk,
 HasHardForkHistory blk) =>
LedgerDBHandle m l blk -> (LedgerDB' m blk, TestInternals' m blk)
implMkLedgerDb LedgerDBHandle m l blk
h = (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        = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk
    -> Point blk -> STM m (Maybe (ExtLedgerState blk EmptyMK)))
-> Point blk
-> STM m (Maybe (ExtLedgerState blk EmptyMK))
forall (m :: * -> *) (l :: LedgerStateKind) blk a r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> STM m r) -> a -> STM m r
getEnvSTM1 LedgerDBHandle m l blk
h 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,
 HasLedgerTables l, HeaderHash l ~ HeaderHash blk) =>
LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l EmptyMK))
implGetPastLedgerState
    , 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,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
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            = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> SlotNo -> STM m ())
-> SlotNo
-> STM m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk a r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> STM m r) -> a -> STM m r
getEnvSTM1 LedgerDBHandle m l blk
h LedgerDBEnv m l blk -> SlotNo -> STM m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
MonadSTM m =>
LedgerDBEnv m l blk -> SlotNo -> STM m ()
implGarbageCollect
    , 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 LedgerDBEnv m l blk
-> Maybe (Time, Time) -> Word64 -> m SnapCounters
forall (l :: LedgerStateKind) blk (m :: * -> *).
(l ~ ExtLedgerState blk, IOLike m,
 LedgerDbSerialiseConstraints blk, LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> Maybe (Time, Time) -> Word64 -> m SnapCounters
implTryTakeSnapshot
    , 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.
(IOLike m, HasLedgerTables l, GetTip l) =>
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
    }, LedgerDBHandle m (ExtLedgerState blk) blk -> TestInternals' m blk
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk, ApplyBlock (ExtLedgerState blk) blk) =>
LedgerDBHandle m (ExtLedgerState blk) blk -> TestInternals' m blk
mkInternals LedgerDBHandle m l blk
LedgerDBHandle m (ExtLedgerState blk) blk
h)

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 = (DbChangelog l -> l EmptyMK)
-> STM m (DbChangelog 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 DbChangelog l -> l EmptyMK
forall (l :: LedgerStateKind).
GetTip l =>
DbChangelog l -> l EmptyMK
current (STM m (DbChangelog l) -> STM m (l EmptyMK))
-> (LedgerDBEnv m l blk -> STM m (DbChangelog l))
-> LedgerDBEnv m l blk
-> STM m (l EmptyMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictTVar m (DbChangelog l) -> STM m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (StrictTVar m (DbChangelog l) -> STM m (DbChangelog l))
-> (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l))
-> LedgerDBEnv m l blk
-> STM m (DbChangelog l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog

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 = (DbChangelog l -> l EmptyMK)
-> STM m (DbChangelog 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 DbChangelog l -> l EmptyMK
forall (l :: LedgerStateKind). DbChangelog l -> l EmptyMK
anchor (STM m (DbChangelog l) -> STM m (l EmptyMK))
-> (LedgerDBEnv m l blk -> STM m (DbChangelog l))
-> LedgerDBEnv m l blk
-> STM m (l EmptyMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictTVar m (DbChangelog l) -> STM m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (StrictTVar m (DbChangelog l) -> STM m (DbChangelog l))
-> (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l))
-> LedgerDBEnv m l blk
-> STM m (DbChangelog l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog

implGetPastLedgerState ::
     ( MonadSTM m , HasHeader blk, IsLedger l, StandardHash l
     , HasLedgerTables 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,
 HasLedgerTables 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 -> DbChangelog l -> Maybe (l EmptyMK)
forall blk (l :: LedgerStateKind).
(HasHeader blk, IsLedger l, HeaderHash l ~ HeaderHash blk,
 StandardHash l, HasLedgerTables l) =>
Point blk -> DbChangelog l -> Maybe (l EmptyMK)
getPastLedgerAt Point blk
point (DbChangelog l -> Maybe (l EmptyMK))
-> STM m (DbChangelog l) -> STM m (Maybe (l EmptyMK))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (DbChangelog l) -> STM m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog 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 (DbChangelog l) -> STM m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog 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
$ DbChangelog (ExtLedgerState blk) -> ExtLedgerState blk EmptyMK
forall (l :: LedgerStateKind).
GetTip l =>
DbChangelog l -> l EmptyMK
current DbChangelog (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)
-> (ExtLedgerState blk EmptyMK -> HeaderState blk)
-> ExtLedgerState blk EmptyMK
-> 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
    pure
      . HeaderStateHistory
      . AS.bimap mkHeaderStateWithTime' mkHeaderStateWithTime'
      $ changelogStates 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 ::
     ( l ~ ExtLedgerState blk
     , IOLike m, LedgerDbSerialiseConstraints blk, LedgerSupportsProtocol blk
     )
  => LedgerDBEnv m l blk -> Maybe (Time, Time) -> Word64 -> m SnapCounters
implTryTakeSnapshot :: forall (l :: LedgerStateKind) blk (m :: * -> *).
(l ~ ExtLedgerState blk, IOLike m,
 LedgerDbSerialiseConstraints blk, LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> Maybe (Time, Time) -> Word64 -> m SnapCounters
implTryTakeSnapshot 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
      m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (DiskSnapshot, RealPoint blk)) -> m ())
-> m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall a b. (a -> b) -> a -> b
$ LedgerDBLock m
-> ReadLocked m (Maybe (DiskSnapshot, RealPoint blk))
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) a.
IOLike m =>
LedgerDBLock m -> ReadLocked m a -> m a
withReadLock (LedgerDBEnv m l blk -> LedgerDBLock m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDBLock m
ldbLock LedgerDBEnv m l blk
env) (StrictTVar m (DbChangelog' blk)
-> CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SnapshotsFS m
-> BackingStore' m blk
-> Maybe String
-> ReadLocked m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk) =>
StrictTVar m (DbChangelog' blk)
-> CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SnapshotsFS m
-> BackingStore' m blk
-> Maybe String
-> ReadLocked m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot
                                          (LedgerDBEnv m (ExtLedgerState blk) blk
-> StrictTVar m (DbChangelog' blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
LedgerDBEnv m (ExtLedgerState blk) blk
env)
                                          (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 -> SnapshotsFS m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotsFS m
ldbHasFS LedgerDBEnv m l blk
env)
                                          (LedgerDBEnv m (ExtLedgerState blk) blk -> BackingStore' m blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerBackingStore m l
ldbBackingStore LedgerDBEnv m l blk
LedgerDBEnv m (ExtLedgerState blk) blk
env)
                                          Maybe String
forall a. Maybe a
Nothing
                                        )
      m [DiskSnapshot] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
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)
                (SnapshotsFS m -> SomeHasFS m
forall (m :: * -> *). SnapshotsFS m -> SomeHasFS m
snapshotsFs (SnapshotsFS m -> SomeHasFS m) -> SnapshotsFS m -> SomeHasFS m
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> SnapshotsFS m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotsFS 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

-- If the DbChangelog in the LedgerDB can flush (based on the SnapshotPolicy
-- with which this LedgerDB was opened), flush differences to the backing
-- store. Note this acquires a write lock on the backing store.
implTryFlush ::
     (IOLike m, HasLedgerTables l, GetTip l)
  => LedgerDBEnv m l blk -> m ()
implTryFlush :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasLedgerTables l, GetTip l) =>
LedgerDBEnv m l blk -> m ()
implTryFlush LedgerDBEnv m l blk
env = do
    ldb <- StrictTVar m (DbChangelog l) -> m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (StrictTVar m (DbChangelog l) -> m (DbChangelog l))
-> StrictTVar m (DbChangelog l) -> m (DbChangelog l)
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
env
    when (ldbShouldFlush env $ DbCh.flushableLength ldb)
        (withWriteLock
          (ldbLock env)
          (flushLedgerDB (ldbChangelog env) (ldbBackingStore env))
        )

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) = do
    mbOpenEnv <- STM m (Maybe (LedgerDBEnv m l blk))
-> m (Maybe (LedgerDBEnv 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 (LedgerDBEnv m l blk))
 -> m (Maybe (LedgerDBEnv m l blk)))
-> STM m (Maybe (LedgerDBEnv m l blk))
-> m (Maybe (LedgerDBEnv 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 (LedgerDBEnv m l blk)))
-> STM m (Maybe (LedgerDBEnv 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
      -- Idempotent
      LedgerDBState m l blk
LedgerDBClosed   -> Maybe (LedgerDBEnv m l blk) -> STM m (Maybe (LedgerDBEnv m l blk))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LedgerDBEnv m l blk)
forall a. Maybe a
Nothing
      LedgerDBOpen LedgerDBEnv m l blk
env -> do
        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
        Maybe (LedgerDBEnv m l blk) -> STM m (Maybe (LedgerDBEnv m l blk))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (LedgerDBEnv m l blk)
 -> STM m (Maybe (LedgerDBEnv m l blk)))
-> Maybe (LedgerDBEnv m l blk)
-> STM m (Maybe (LedgerDBEnv m l blk))
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> Maybe (LedgerDBEnv m l blk)
forall a. a -> Maybe a
Just LedgerDBEnv m l blk
env

    -- Only when the LedgerDB was open
    whenJust mbOpenEnv $ \LedgerDBEnv m l blk
env -> do
      LedgerDBEnv m l blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDBEnv m l blk -> m ()
closeAllForkers LedgerDBEnv m l blk
env
      BackingStore
  m
  (LedgerTables l KeysMK)
  (LedgerTables l ValuesMK)
  (LedgerTables l DiffMK)
-> m ()
forall (m :: * -> *) keys values diff.
BackingStore m keys values diff -> m ()
bsClose (LedgerDBEnv m l blk
-> BackingStore
     m
     (LedgerTables l KeysMK)
     (LedgerTables l ValuesMK)
     (LedgerTables l DiffMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerBackingStore m l
ldbBackingStore LedgerDBEnv m l blk
env)

mkInternals ::
     ( IOLike m
     , LedgerDbSerialiseConstraints blk
     , LedgerSupportsProtocol blk
     , ApplyBlock (ExtLedgerState blk) blk
     )
  => LedgerDBHandle m (ExtLedgerState blk) blk
  -> TestInternals' m blk
mkInternals :: forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk, ApplyBlock (ExtLedgerState blk) blk) =>
LedgerDBHandle m (ExtLedgerState blk) blk -> TestInternals' m blk
mkInternals LedgerDBHandle m (ExtLedgerState blk) blk
h = TestInternals {
      takeSnapshotNOW :: WhereToTakeSnapshot -> Maybe String -> m ()
takeSnapshotNOW = LedgerDBHandle m (ExtLedgerState blk) blk
-> (LedgerDBEnv m (ExtLedgerState blk) blk
    -> WhereToTakeSnapshot -> Maybe String -> m ())
-> WhereToTakeSnapshot
-> Maybe String
-> m ()
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 (ExtLedgerState blk) blk
h LedgerDBEnv m (ExtLedgerState blk) blk
-> WhereToTakeSnapshot -> Maybe String -> m ()
forall (m :: * -> *) blk (l :: LedgerStateKind).
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk, l ~ ExtLedgerState blk) =>
LedgerDBEnv m l blk -> WhereToTakeSnapshot -> Maybe String -> m ()
implIntTakeSnapshot
    , push :: ExtLedgerState blk DiffMK -> m ()
push = LedgerDBHandle m (ExtLedgerState blk) blk
-> (LedgerDBEnv m (ExtLedgerState blk) blk
    -> ExtLedgerState blk DiffMK -> m ())
-> ExtLedgerState blk DiffMK
-> m ()
forall (m :: * -> *) blk (l :: LedgerStateKind) a r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> m r) -> a -> m r
getEnv1 LedgerDBHandle m (ExtLedgerState blk) blk
h LedgerDBEnv m (ExtLedgerState blk) blk
-> ExtLedgerState blk DiffMK -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, ApplyBlock l blk, l ~ ExtLedgerState blk) =>
LedgerDBEnv m l blk -> l DiffMK -> m ()
implIntPush
    , reapplyThenPushNOW :: blk -> m ()
reapplyThenPushNOW = LedgerDBHandle m (ExtLedgerState blk) blk
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> blk -> m ())
-> blk
-> m ()
forall (m :: * -> *) blk (l :: LedgerStateKind) a r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> m r) -> a -> m r
getEnv1 LedgerDBHandle m (ExtLedgerState blk) blk
h LedgerDBEnv m (ExtLedgerState blk) blk -> blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, ApplyBlock l blk, l ~ ExtLedgerState blk) =>
LedgerDBEnv m l blk -> blk -> m ()
implIntReapplyThenPush
    , 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
$ m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ())
-> LedgerDBEnv m (ExtLedgerState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
. SnapshotsFS m -> SomeHasFS m
forall (m :: * -> *). SnapshotsFS m -> SomeHasFS m
snapshotsFs (SnapshotsFS m -> SomeHasFS m)
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> SnapshotsFS m)
-> LedgerDBEnv m (ExtLedgerState blk) blk
-> SomeHasFS m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBEnv m (ExtLedgerState blk) blk -> SnapshotsFS m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotsFS m
ldbHasFS
    , closeLedgerDB :: m ()
closeLedgerDB = 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
$ BackingStore
  m
  (LedgerTables (ExtLedgerState blk) KeysMK)
  (LedgerTables (ExtLedgerState blk) ValuesMK)
  (LedgerTables (ExtLedgerState blk) DiffMK)
-> m ()
forall (m :: * -> *) keys values diff.
BackingStore m keys values diff -> m ()
bsClose (BackingStore
   m
   (LedgerTables (ExtLedgerState blk) KeysMK)
   (LedgerTables (ExtLedgerState blk) ValuesMK)
   (LedgerTables (ExtLedgerState blk) DiffMK)
 -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk
    -> BackingStore
         m
         (LedgerTables (ExtLedgerState blk) KeysMK)
         (LedgerTables (ExtLedgerState blk) ValuesMK)
         (LedgerTables (ExtLedgerState blk) DiffMK))
-> LedgerDBEnv m (ExtLedgerState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBEnv m (ExtLedgerState blk) blk
-> BackingStore
     m
     (LedgerTables (ExtLedgerState blk) KeysMK)
     (LedgerTables (ExtLedgerState blk) ValuesMK)
     (LedgerTables (ExtLedgerState blk) DiffMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerBackingStore m l
ldbBackingStore
    , 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
$ m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ())
-> LedgerDBEnv m (ExtLedgerState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapshotsFS m -> m ()
forall (m :: * -> *). MonadThrow m => SnapshotsFS m -> m ()
implIntTruncateSnapshots (SnapshotsFS m -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> SnapshotsFS m)
-> LedgerDBEnv m (ExtLedgerState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBEnv m (ExtLedgerState blk) blk -> SnapshotsFS m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotsFS m
ldbHasFS
    }

-- | Testing only! Truncate all snapshots in the DB.
implIntTruncateSnapshots :: MonadThrow m => SnapshotsFS m -> m ()
implIntTruncateSnapshots :: forall (m :: * -> *). MonadThrow m => SnapshotsFS m -> m ()
implIntTruncateSnapshots (SnapshotsFS (SomeHasFS HasFS m h
fs)) = do
  dirs <- Set String -> Maybe String
forall a. Set a -> Maybe a
Set.lookupMax (Set String -> Maybe String)
-> (Set String -> Set String) -> Set String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> Set String -> Set String
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Maybe DiskSnapshot -> Bool
forall a. Maybe a -> Bool
isJust (Maybe DiskSnapshot -> Bool)
-> (String -> Maybe DiskSnapshot) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe DiskSnapshot
snapshotFromPath) (Set String -> Maybe String) -> m (Set String) -> m (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 [])
  mapM_ (truncateRecursively . (:[])) dirs
  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

implIntTakeSnapshot ::
     ( IOLike m
     , LedgerDbSerialiseConstraints blk
     , LedgerSupportsProtocol blk
     , l ~ ExtLedgerState blk
     )
  => LedgerDBEnv m l blk -> WhereToTakeSnapshot -> Maybe String -> m ()
implIntTakeSnapshot :: forall (m :: * -> *) blk (l :: LedgerStateKind).
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk, l ~ ExtLedgerState blk) =>
LedgerDBEnv m l blk -> WhereToTakeSnapshot -> Maybe String -> m ()
implIntTakeSnapshot LedgerDBEnv m l blk
env WhereToTakeSnapshot
whereTo Maybe String
suffix = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WhereToTakeSnapshot
whereTo WhereToTakeSnapshot -> WhereToTakeSnapshot -> Bool
forall a. Eq a => a -> a -> Bool
== WhereToTakeSnapshot
TakeAtVolatileTip) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ 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 (DbChangelog l)
-> (DbChangelog l -> DbChangelog l) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
env) DbChangelog l -> DbChangelog l
forall (l :: LedgerStateKind).
GetTip l =>
DbChangelog l -> DbChangelog l
pruneToImmTipOnly
  LedgerDBLock m -> WriteLocked m () -> m ()
forall (m :: * -> *) a.
IOLike m =>
LedgerDBLock m -> WriteLocked m a -> m a
withWriteLock
          (LedgerDBEnv m l blk -> LedgerDBLock m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDBLock m
ldbLock LedgerDBEnv m l blk
env)
          (StrictTVar m (DbChangelog l)
-> LedgerBackingStore m l -> WriteLocked m ()
forall (m :: * -> *) (l :: LedgerStateKind).
(MonadSTM m, GetTip l, HasLedgerTables l) =>
StrictTVar m (DbChangelog l)
-> LedgerBackingStore m l -> WriteLocked m ()
flushLedgerDB (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
env) (LedgerDBEnv m l blk -> LedgerBackingStore m l
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerBackingStore m l
ldbBackingStore LedgerDBEnv m l blk
env))
  m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (DiskSnapshot, RealPoint blk)) -> m ())
-> m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall a b. (a -> b) -> a -> b
$ LedgerDBLock m
-> ReadLocked m (Maybe (DiskSnapshot, RealPoint blk))
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) a.
IOLike m =>
LedgerDBLock m -> ReadLocked m a -> m a
withReadLock (LedgerDBEnv m l blk -> LedgerDBLock m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDBLock m
ldbLock LedgerDBEnv m l blk
env) (ReadLocked m (Maybe (DiskSnapshot, RealPoint blk))
 -> m (Maybe (DiskSnapshot, RealPoint blk)))
-> ReadLocked m (Maybe (DiskSnapshot, RealPoint blk))
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall a b. (a -> b) -> a -> b
$
    StrictTVar m (DbChangelog' blk)
-> CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SnapshotsFS m
-> BackingStore' m blk
-> Maybe String
-> ReadLocked m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk) =>
StrictTVar m (DbChangelog' blk)
-> CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SnapshotsFS m
-> BackingStore' m blk
-> Maybe String
-> ReadLocked m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot
      (LedgerDBEnv m (ExtLedgerState blk) blk
-> StrictTVar m (DbChangelog' blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
LedgerDBEnv m (ExtLedgerState blk) blk
env)
      (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 -> SnapshotsFS m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotsFS m
ldbHasFS LedgerDBEnv m l blk
env)
      (LedgerDBEnv m (ExtLedgerState blk) blk -> BackingStore' m blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerBackingStore m l
ldbBackingStore LedgerDBEnv m l blk
LedgerDBEnv m (ExtLedgerState blk) blk
env)
      Maybe String
suffix

implIntPush ::
     ( IOLike m
     , ApplyBlock l blk
     , l ~ ExtLedgerState blk
     )
  => LedgerDBEnv m l blk -> l DiffMK -> m ()
implIntPush :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, ApplyBlock l blk, l ~ ExtLedgerState blk) =>
LedgerDBEnv m l blk -> l DiffMK -> m ()
implIntPush LedgerDBEnv m l blk
env l DiffMK
st = do
  chlog <- StrictTVar m (DbChangelog l) -> m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (StrictTVar m (DbChangelog l) -> m (DbChangelog l))
-> StrictTVar m (DbChangelog l) -> m (DbChangelog l)
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
env
  let chlog' = LedgerDbPrune -> DbChangelog l -> DbChangelog l
forall (l :: LedgerStateKind).
GetTip l =>
LedgerDbPrune -> DbChangelog l -> DbChangelog l
prune (SecurityParam -> LedgerDbPrune
LedgerDbPruneKeeping (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
env)) (DbChangelog l -> DbChangelog l) -> DbChangelog l -> DbChangelog l
forall a b. (a -> b) -> a -> b
$ l DiffMK -> DbChangelog l -> DbChangelog l
forall (l :: LedgerStateKind).
(GetTip l, HasLedgerTables l) =>
l DiffMK -> DbChangelog l -> DbChangelog l
extend l DiffMK
st DbChangelog l
chlog
  atomically $ writeTVar (ldbChangelog env) chlog'

implIntReapplyThenPush ::
     ( IOLike m
     , ApplyBlock l blk
     , l ~ ExtLedgerState blk
     )
  => LedgerDBEnv m l blk -> blk -> m ()
implIntReapplyThenPush :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, ApplyBlock l blk, l ~ ExtLedgerState blk) =>
LedgerDBEnv m l blk -> blk -> m ()
implIntReapplyThenPush LedgerDBEnv m l blk
env blk
blk = do
  chlog <- StrictTVar m (DbChangelog l) -> m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (StrictTVar m (DbChangelog l) -> m (DbChangelog l))
-> StrictTVar m (DbChangelog l) -> m (DbChangelog l)
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
env
  chlog' <- reapplyThenPush (ldbCfg env)  blk (readKeySets (ldbBackingStore env)) chlog
  atomically $ writeTVar (ldbChangelog env) chlog'

{-------------------------------------------------------------------------------
  Flushing
-------------------------------------------------------------------------------}

flushLedgerDB :: (MonadSTM m, GetTip l, HasLedgerTables l)
              => StrictTVar m (DbChangelog l)
              -> LedgerBackingStore m l
              -> WriteLocked m ()
flushLedgerDB :: forall (m :: * -> *) (l :: LedgerStateKind).
(MonadSTM m, GetTip l, HasLedgerTables l) =>
StrictTVar m (DbChangelog l)
-> LedgerBackingStore m l -> WriteLocked m ()
flushLedgerDB StrictTVar m (DbChangelog l)
chlogVar LedgerBackingStore m l
bstore = do
  diffs <- m (Maybe (DiffsToFlush l))
-> WriteLocked m (Maybe (DiffsToFlush l))
forall (m :: * -> *) a. m a -> WriteLocked m a
writeLocked (m (Maybe (DiffsToFlush l))
 -> WriteLocked m (Maybe (DiffsToFlush l)))
-> m (Maybe (DiffsToFlush l))
-> WriteLocked m (Maybe (DiffsToFlush l))
forall a b. (a -> b) -> a -> b
$ STM m (Maybe (DiffsToFlush l)) -> m (Maybe (DiffsToFlush l))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (DiffsToFlush l)) -> m (Maybe (DiffsToFlush l)))
-> STM m (Maybe (DiffsToFlush l)) -> m (Maybe (DiffsToFlush l))
forall a b. (a -> b) -> a -> b
$ do
    ldb' <- StrictTVar m (DbChangelog l) -> STM m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (DbChangelog l)
chlogVar
    let (toFlush, toKeep) = splitForFlushing ldb'
    case toFlush of
      Maybe (DiffsToFlush l)
Nothing -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just {} -> StrictTVar m (DbChangelog l) -> DbChangelog l -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (DbChangelog l)
chlogVar DbChangelog l
toKeep
    pure toFlush
  mapM_ (flushIntoBackingStore bstore) diffs

-- | Flush **all the changes in this DbChangelog** into the backing store
--
-- Note that 'flush' must have been called to split the 'DbChangelog' on the
-- immutable tip and produce two 'DbChangelog's, one to flush and one to keep.
--
-- The write lock must be held before calling this function.
flushIntoBackingStore :: LedgerBackingStore m l -> DiffsToFlush l -> WriteLocked m ()
flushIntoBackingStore :: forall (m :: * -> *) (l :: LedgerStateKind).
LedgerBackingStore m l -> DiffsToFlush l -> WriteLocked m ()
flushIntoBackingStore LedgerBackingStore m l
backingStore DiffsToFlush l
dblog = m () -> WriteLocked m ()
forall (m :: * -> *) a. m a -> WriteLocked m a
writeLocked (m () -> WriteLocked m ()) -> m () -> WriteLocked m ()
forall a b. (a -> b) -> a -> b
$
  LedgerBackingStore m l
-> SlotNo
-> WriteHint (LedgerTables l DiffMK)
-> LedgerTables l DiffMK
-> m ()
forall (m :: * -> *) keys values diff.
BackingStore m keys values diff
-> SlotNo -> WriteHint diff -> diff -> m ()
bsWrite
    LedgerBackingStore m l
backingStore
    (DiffsToFlush l -> SlotNo
forall (l :: LedgerStateKind). DiffsToFlush l -> SlotNo
toFlushSlot DiffsToFlush l
dblog)
    (DiffsToFlush l -> (l EmptyMK, l EmptyMK)
forall (l :: LedgerStateKind).
DiffsToFlush l -> (l EmptyMK, l EmptyMK)
toFlushState DiffsToFlush l
dblog)
    (DiffsToFlush l -> LedgerTables l DiffMK
forall (l :: LedgerStateKind).
DiffsToFlush l -> LedgerTables l DiffMK
toFlushDiffs DiffsToFlush l
dblog)

{-------------------------------------------------------------------------------
  LedgerDB internal state
-------------------------------------------------------------------------------}

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)

type LedgerDBEnv :: (Type -> Type) -> LedgerStateKind -> Type -> Type
data LedgerDBEnv m l blk = LedgerDBEnv {
    -- | 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 (DbChangelog l)
ldbChangelog      :: !(StrictTVar m (DbChangelog l))
    -- | Handle to the ledger's backing store, containing the parts that grow too
    -- big for in-memory residency
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerBackingStore m l
ldbBackingStore   :: !(LedgerBackingStore m l)
    -- | The flush lock to the 'BackingStore'. This lock is crucial when it
    -- comes to keeping the data in memory consistent with the data on-disk.
    --
    -- This lock should be held whenever we want to keep a consistent view of
    -- the backing store for some time. In particular we use this:
    --
    -- - when performing a query on the ledger state, we need to hold a
    --   'LocalStateQueryView' which, while live, must maintain a consistent view
    --   of the DB, and therefore we acquire a Read lock.
    --
    -- - when taking a snapshot of the ledger db, we need to prevent others (eg
    --   ChainSel) from altering the backing store at the same time, thus we
    --   acquire a Write lock.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDBLock m
ldbLock           :: !(LedgerDBLock m)
    -- | 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 (Set (RealPoint blk))
ldbPrevApplied    :: !(StrictTVar m (Set (RealPoint blk)))
    -- | Open forkers.
    --
    -- INVARIANT: a forker is open iff its 'ForkerKey' is in this 'Map.
  , 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)))
  , 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 -> SnapshotsFS m
ldbHasFS          :: !(SnapshotsFS m)
    -- | Determine whether we should flush depending on the number of flushable
    -- diffs that we currently have in the LedgerDB, based on the flush
    -- frequency that was provided when opening the LedgerDB.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> Word64 -> Bool
ldbShouldFlush    :: !(Word64 -> Bool)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> QueryBatchSize
ldbQueryBatchSize :: !QueryBatchSize
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> ResolveBlock m blk
ldbResolveBlock   :: !(ResolveBlock m blk)
  } 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)

-- | 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 one argument.
getEnv1 ::
     (IOLike m, HasCallStack, HasHeader blk)
  => LedgerDBHandle m l blk
  -> (LedgerDBEnv m l blk -> a -> m r)
  -> a -> m r
getEnv1 :: forall (m :: * -> *) blk (l :: LedgerStateKind) a r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> m r) -> a -> m r
getEnv1 LedgerDBHandle m l blk
h LedgerDBEnv m l blk -> a -> m r
f a
a = 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 -> a -> m r
`f` a
a)

-- | 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

-- | Variant of 'getEnv1' that works in 'STM'.
getEnvSTM1 ::
     forall m l blk a r. (IOLike m, HasCallStack, HasHeader blk)
  => LedgerDBHandle m l blk
  -> (LedgerDBEnv m l blk -> a -> STM m r)
  -> a -> STM m r
getEnvSTM1 :: forall (m :: * -> *) (l :: LedgerStateKind) blk a r.
(IOLike m, HasCallStack, HasHeader blk) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> STM m r) -> a -> STM m r
getEnvSTM1 (LDBHandle StrictTVar m (LedgerDBState m l blk)
varState) LedgerDBEnv m l blk -> a -> STM m r
f a
a = 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 -> a -> STM m r
f LedgerDBEnv m l blk
env a
a
    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

{-------------------------------------------------------------------------------
  Forkers
-------------------------------------------------------------------------------}

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 -> (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))
-> STM m (Map ForkerKey (ForkerEnv m l blk))
-> STM m (Maybe (ForkerEnv m l blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (Maybe (ForkerEnv m l blk))
-> (Maybe (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
>>= \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 call 'error' if the point is not on the LedgerDB
newForkerAtTarget ::
     ( HeaderHash l ~ HeaderHash blk
     , IOLike m
     , IsLedger l
     , StandardHash l
     , HasLedgerTables l
     , LedgerSupportsProtocol blk
     )
  => 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,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
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 ->
    LedgerDBLock m
-> ReadLocked m (Either GetForkerError (Resources m l))
-> m (Either GetForkerError (Resources m l))
forall (m :: * -> *) a.
IOLike m =>
LedgerDBLock m -> ReadLocked m a -> m a
withReadLock (LedgerDBEnv m l blk -> LedgerDBLock m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDBLock m
ldbLock LedgerDBEnv m l blk
ldbEnv) (LedgerDBEnv m l blk
-> ResourceRegistry m
-> Either Word64 (Target (Point blk))
-> ReadLocked m (Either GetForkerError (Resources m l))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> ResourceRegistry m
-> Either Word64 (Target (Point blk))
-> ReadLocked m (Either GetForkerError (Resources m l))
acquireAtTarget LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr (Target (Point blk) -> Either Word64 (Target (Point blk))
forall a b. b -> Either a b
Right Target (Point blk)
pt)) m (Either GetForkerError (Resources m l))
-> (Either GetForkerError (Resources 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
>>= (Resources m l -> m (Forker m l blk))
-> Either GetForkerError (Resources 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 -> Resources m l -> m (Forker m l blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasLedgerTables l, LedgerSupportsProtocol blk,
 NoThunks (l EmptyMK), GetTip l) =>
LedgerDBHandle m l blk
-> LedgerDBEnv m l blk -> Resources m l -> m (Forker m l blk)
newForker LedgerDBHandle m l blk
h LedgerDBEnv m l blk
ldbEnv)

newForkerByRollback ::
     ( HeaderHash l ~ HeaderHash blk
     , IOLike m
     , IsLedger l
     , StandardHash l
     , HasLedgerTables l
     , LedgerSupportsProtocol blk
     )
  => LedgerDBHandle m l blk
  -> ResourceRegistry m
     -- | How many blocks to rollback from the tip
  -> 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 -> do
    LedgerDBLock m
-> ReadLocked m (Either GetForkerError (Resources m l))
-> m (Either GetForkerError (Resources m l))
forall (m :: * -> *) a.
IOLike m =>
LedgerDBLock m -> ReadLocked m a -> m a
withReadLock (LedgerDBEnv m l blk -> LedgerDBLock m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDBLock m
ldbLock LedgerDBEnv m l blk
ldbEnv) (LedgerDBEnv m l blk
-> ResourceRegistry m
-> Either Word64 (Target (Point blk))
-> ReadLocked m (Either GetForkerError (Resources m l))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> ResourceRegistry m
-> Either Word64 (Target (Point blk))
-> ReadLocked m (Either GetForkerError (Resources m l))
acquireAtTarget LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr (Word64 -> Either Word64 (Target (Point blk))
forall a b. a -> Either a b
Left Word64
n)) m (Either GetForkerError (Resources m l))
-> (Either GetForkerError (Resources 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
>>= (Resources m l -> m (Forker m l blk))
-> Either GetForkerError (Resources 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 -> Resources m l -> m (Forker m l blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasLedgerTables l, LedgerSupportsProtocol blk,
 NoThunks (l EmptyMK), GetTip l) =>
LedgerDBHandle m l blk
-> LedgerDBEnv m l blk -> Resources m l -> m (Forker m l blk)
newForker LedgerDBHandle m l blk
h LedgerDBEnv m l blk
ldbEnv)

-- | Close all open block and header 'Forker's.
closeAllForkers ::
     IOLike m
  => LedgerDBEnv m l blk
  -> m ()
closeAllForkers :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDBEnv m l blk -> m ()
closeAllForkers LedgerDBEnv m l blk
ldbEnv =
  do
    forkerEnvs <- 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
$ do
      forkerEnvs <- Map ForkerKey (ForkerEnv m l blk) -> [ForkerEnv m l blk]
forall k a. Map k a -> [a]
Map.elems (Map ForkerKey (ForkerEnv m l blk) -> [ForkerEnv m l blk])
-> STM m (Map ForkerKey (ForkerEnv m l blk))
-> STM m [ForkerEnv m l blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
forkersVar
      writeTVar forkersVar Map.empty
      return forkerEnvs
    mapM_ closeForkerEnv forkerEnvs
  where
    forkersVar :: StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
forkersVar = 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

type Resources m l =
    (LedgerBackingStoreValueHandle m l, DbChangelog l)

-- | Acquire both a value handle and a db changelog at the tip. Holds a read lock
-- while doing so.
acquireAtTarget ::
     forall m l blk. (
       HeaderHash l ~ HeaderHash blk
     , IOLike m
     , IsLedger l
     , StandardHash l
     , HasLedgerTables l
     , LedgerSupportsProtocol blk
     )
  => LedgerDBEnv m l blk
  -> ResourceRegistry m
  -> Either Word64 (Target (Point blk))
  -> ReadLocked m (Either GetForkerError (Resources m l))
acquireAtTarget :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> ResourceRegistry m
-> Either Word64 (Target (Point blk))
-> ReadLocked m (Either GetForkerError (Resources m l))
acquireAtTarget LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr (Right Target (Point blk)
VolatileTip) =
    m (Either GetForkerError (Resources m l))
-> ReadLocked m (Either GetForkerError (Resources m l))
forall (m :: * -> *) a. m a -> ReadLocked m a
readLocked (m (Either GetForkerError (Resources m l))
 -> ReadLocked m (Either GetForkerError (Resources m l)))
-> m (Either GetForkerError (Resources m l))
-> ReadLocked m (Either GetForkerError (Resources m l))
forall a b. (a -> b) -> a -> b
$ do
      dblog <- StrictTVar m (DbChangelog l) -> m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
ldbEnv)
      Right . (,dblog) <$> acquire ldbEnv rr dblog
acquireAtTarget LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr (Right Target (Point blk)
ImmutableTip) =
    m (Either GetForkerError (Resources m l))
-> ReadLocked m (Either GetForkerError (Resources m l))
forall (m :: * -> *) a. m a -> ReadLocked m a
readLocked (m (Either GetForkerError (Resources m l))
 -> ReadLocked m (Either GetForkerError (Resources m l)))
-> m (Either GetForkerError (Resources m l))
-> ReadLocked m (Either GetForkerError (Resources m l))
forall a b. (a -> b) -> a -> b
$ do
      dblog <- StrictTVar m (DbChangelog l) -> m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
ldbEnv)
      Right . (, rollbackToAnchor dblog)
        <$> acquire ldbEnv rr dblog
acquireAtTarget LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr (Right (SpecificPoint Point blk
pt)) =
    m (Either GetForkerError (Resources m l))
-> ReadLocked m (Either GetForkerError (Resources m l))
forall (m :: * -> *) a. m a -> ReadLocked m a
readLocked (m (Either GetForkerError (Resources m l))
 -> ReadLocked m (Either GetForkerError (Resources m l)))
-> m (Either GetForkerError (Resources m l))
-> ReadLocked m (Either GetForkerError (Resources m l))
forall a b. (a -> b) -> a -> b
$ do
      dblog <- StrictTVar m (DbChangelog l) -> m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
ldbEnv)
      let 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
$ DbChangelog l -> l EmptyMK
forall (l :: LedgerStateKind). DbChangelog l -> l EmptyMK
anchor DbChangelog l
dblog
      case rollback pt dblog of
        Maybe (DbChangelog 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 -> Either GetForkerError (Resources m l)
-> m (Either GetForkerError (Resources m l))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either GetForkerError (Resources m l)
 -> m (Either GetForkerError (Resources m l)))
-> Either GetForkerError (Resources m l)
-> m (Either GetForkerError (Resources m l))
forall a b. (a -> b) -> a -> b
$ GetForkerError -> Either GetForkerError (Resources m l)
forall a b. a -> Either a b
Left (GetForkerError -> Either GetForkerError (Resources m l))
-> GetForkerError -> Either GetForkerError (Resources m l)
forall a b. (a -> b) -> a -> b
$ Maybe ExceededRollback -> GetForkerError
PointTooOld Maybe ExceededRollback
forall a. Maybe a
Nothing
                    | Bool
otherwise   -> Either GetForkerError (Resources m l)
-> m (Either GetForkerError (Resources m l))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either GetForkerError (Resources m l)
 -> m (Either GetForkerError (Resources m l)))
-> Either GetForkerError (Resources m l)
-> m (Either GetForkerError (Resources m l))
forall a b. (a -> b) -> a -> b
$ GetForkerError -> Either GetForkerError (Resources m l)
forall a b. a -> Either a b
Left GetForkerError
PointNotOnChain
        Just DbChangelog l
dblog' -> Resources m l -> Either GetForkerError (Resources m l)
forall a b. b -> Either a b
Right (Resources m l -> Either GetForkerError (Resources m l))
-> (LedgerBackingStoreValueHandle m l -> Resources m l)
-> LedgerBackingStoreValueHandle m l
-> Either GetForkerError (Resources m l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,DbChangelog l
dblog') (LedgerBackingStoreValueHandle m l
 -> Either GetForkerError (Resources m l))
-> m (LedgerBackingStoreValueHandle m l)
-> m (Either GetForkerError (Resources m l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerDBEnv m l blk
-> ResourceRegistry m
-> DbChangelog l
-> m (LedgerBackingStoreValueHandle m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, GetTip l) =>
LedgerDBEnv m l blk
-> ResourceRegistry m
-> DbChangelog l
-> m (LedgerBackingStoreValueHandle m l)
acquire LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr DbChangelog l
dblog'
acquireAtTarget LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr (Left Word64
n) = m (Either GetForkerError (Resources m l))
-> ReadLocked m (Either GetForkerError (Resources m l))
forall (m :: * -> *) a. m a -> ReadLocked m a
readLocked (m (Either GetForkerError (Resources m l))
 -> ReadLocked m (Either GetForkerError (Resources m l)))
-> m (Either GetForkerError (Resources m l))
-> ReadLocked m (Either GetForkerError (Resources m l))
forall a b. (a -> b) -> a -> b
$ do
      dblog <- StrictTVar m (DbChangelog l) -> m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
ldbEnv)
      case rollbackN n dblog of
        Maybe (DbChangelog l)
Nothing ->
          Either GetForkerError (Resources m l)
-> m (Either GetForkerError (Resources m l))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GetForkerError (Resources m l)
 -> m (Either GetForkerError (Resources m l)))
-> Either GetForkerError (Resources m l)
-> m (Either GetForkerError (Resources m l))
forall a b. (a -> b) -> a -> b
$ GetForkerError -> Either GetForkerError (Resources m l)
forall a b. a -> Either a b
Left (GetForkerError -> Either GetForkerError (Resources m l))
-> GetForkerError -> Either GetForkerError (Resources 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 -> Maybe ExceededRollback)
-> ExceededRollback -> Maybe ExceededRollback
forall a b. (a -> b) -> a -> b
$ ExceededRollback {
              rollbackMaximum :: Word64
rollbackMaximum   = DbChangelog l -> Word64
forall (l :: LedgerStateKind). GetTip l => DbChangelog l -> Word64
maxRollback DbChangelog l
dblog
            , rollbackRequested :: Word64
rollbackRequested = Word64
n
            }
        Just DbChangelog l
dblog' ->
           Resources m l -> Either GetForkerError (Resources m l)
forall a b. b -> Either a b
Right (Resources m l -> Either GetForkerError (Resources m l))
-> (LedgerBackingStoreValueHandle m l -> Resources m l)
-> LedgerBackingStoreValueHandle m l
-> Either GetForkerError (Resources m l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,DbChangelog l
dblog') (LedgerBackingStoreValueHandle m l
 -> Either GetForkerError (Resources m l))
-> m (LedgerBackingStoreValueHandle m l)
-> m (Either GetForkerError (Resources m l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerDBEnv m l blk
-> ResourceRegistry m
-> DbChangelog l
-> m (LedgerBackingStoreValueHandle m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, GetTip l) =>
LedgerDBEnv m l blk
-> ResourceRegistry m
-> DbChangelog l
-> m (LedgerBackingStoreValueHandle m l)
acquire LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr DbChangelog l
dblog'

acquire ::
     (IOLike m, GetTip l)
  => LedgerDBEnv m l blk
  -> ResourceRegistry m
  -> DbChangelog l
  -> m (LedgerBackingStoreValueHandle m l)
acquire :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, GetTip l) =>
LedgerDBEnv m l blk
-> ResourceRegistry m
-> DbChangelog l
-> m (LedgerBackingStoreValueHandle m l)
acquire LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr DbChangelog l
dblog =  do
  -- bsvhClose is idempotent, so we let the resource call it even if the value
  -- handle might have been closed somewhere else
  (_, vh) <- ResourceRegistry m
-> (ResourceId
    -> m (BackingStoreValueHandle
            m (LedgerTables l KeysMK) (LedgerTables l ValuesMK)))
-> (BackingStoreValueHandle
      m (LedgerTables l KeysMK) (LedgerTables l ValuesMK)
    -> m ())
-> m (ResourceKey m,
      BackingStoreValueHandle
        m (LedgerTables l KeysMK) (LedgerTables l ValuesMK))
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
ResourceRegistry m
-> (ResourceId -> m a) -> (a -> m ()) -> m (ResourceKey m, a)
allocate ResourceRegistry m
rr (\ResourceId
_ -> BackingStore
  m
  (LedgerTables l KeysMK)
  (LedgerTables l ValuesMK)
  (LedgerTables l DiffMK)
-> m (BackingStoreValueHandle
        m (LedgerTables l KeysMK) (LedgerTables l ValuesMK))
forall (m :: * -> *) keys values diff.
BackingStore m keys values diff
-> m (BackingStoreValueHandle m keys values)
bsValueHandle (BackingStore
   m
   (LedgerTables l KeysMK)
   (LedgerTables l ValuesMK)
   (LedgerTables l DiffMK)
 -> m (BackingStoreValueHandle
         m (LedgerTables l KeysMK) (LedgerTables l ValuesMK)))
-> BackingStore
     m
     (LedgerTables l KeysMK)
     (LedgerTables l ValuesMK)
     (LedgerTables l DiffMK)
-> m (BackingStoreValueHandle
        m (LedgerTables l KeysMK) (LedgerTables l ValuesMK))
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk
-> BackingStore
     m
     (LedgerTables l KeysMK)
     (LedgerTables l ValuesMK)
     (LedgerTables l DiffMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerBackingStore m l
ldbBackingStore LedgerDBEnv m l blk
ldbEnv) BackingStoreValueHandle
  m (LedgerTables l KeysMK) (LedgerTables l ValuesMK)
-> m ()
forall (m :: * -> *) keys values.
BackingStoreValueHandle m keys values -> m ()
bsvhClose
  let dblogSlot = l EmptyMK -> WithOrigin SlotNo
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot (DbChangelog l -> l EmptyMK
forall (l :: LedgerStateKind). DbChangelog l -> l EmptyMK
changelogLastFlushedState DbChangelog l
dblog)
  if bsvhAtSlot vh == dblogSlot
    then pure vh
    else bsvhClose vh >>
         error (  "Critical error: Value handles are created at "
                <> show (bsvhAtSlot vh)
                <> " while the db changelog is at "
                <> show dblogSlot
                <> ". There is either a race condition or a logic bug"
                )

{-------------------------------------------------------------------------------
  Make forkers from consistent views
-------------------------------------------------------------------------------}

newForker ::
     ( IOLike m
     , HasLedgerTables l
     , LedgerSupportsProtocol blk
     , NoThunks (l EmptyMK)
     , GetTip l
     )
  => LedgerDBHandle m l blk
  -> LedgerDBEnv m l blk
  -> Resources m l
  -> m (Forker m l blk)
newForker :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasLedgerTables l, LedgerSupportsProtocol blk,
 NoThunks (l EmptyMK), GetTip l) =>
LedgerDBHandle m l blk
-> LedgerDBEnv m l blk -> Resources m l -> m (Forker m l blk)
newForker LedgerDBHandle m l blk
h LedgerDBEnv m l blk
ldbEnv (LedgerBackingStoreValueHandle m l
vh, DbChangelog l
dblog) = do
  dblogVar     <- DbChangelog l -> m (StrictTVar m (DbChangelog l))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO DbChangelog l
dblog
  forkerKey    <- atomically $ stateTVar (ldbNextForkerKey ldbEnv) $ \ForkerKey
r -> (ForkerKey
r, ForkerKey
r ForkerKey -> ForkerKey -> ForkerKey
forall a. Num a => a -> a -> a
+ ForkerKey
1)
  let forkerEnv = ForkerEnv {
      foeBackingStoreValueHandle :: LedgerBackingStoreValueHandle m l
foeBackingStoreValueHandle = LedgerBackingStoreValueHandle m l
vh
    , foeChangelog :: StrictTVar m (DbChangelog l)
foeChangelog               = StrictTVar m (DbChangelog l)
dblogVar
    , foeSwitchVar :: StrictTVar m (DbChangelog l)
foeSwitchVar               = LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog 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                  = 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
    }
  atomically $ modifyTVar (ldbForkers ldbEnv) $ Map.insert forkerKey forkerEnv
  traceWith (foeTracer forkerEnv) ForkerOpen
  pure $ mkForker h (ldbQueryBatchSize ldbEnv) forkerKey

mkForker ::
     ( IOLike m
     , HasHeader blk
     , HasLedgerTables l
     , GetTip l
     )
  => LedgerDBHandle m l blk
  -> QueryBatchSize
  -> ForkerKey
  -> Forker m l blk
mkForker :: forall (m :: * -> *) blk (l :: LedgerStateKind).
(IOLike m, HasHeader blk, HasLedgerTables l, GetTip l) =>
LedgerDBHandle m l blk
-> QueryBatchSize -> ForkerKey -> Forker m l blk
mkForker LedgerDBHandle m l blk
h QueryBatchSize
qbs ForkerKey
forkerKey = Forker {
      forkerClose :: m ()
forkerClose                  = LedgerDBHandle m l blk -> ForkerKey -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDBHandle m l blk -> ForkerKey -> m ()
implForkerClose LedgerDBHandle m l blk
h ForkerKey
forkerKey
    , forkerReadTables :: LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
forkerReadTables             = LedgerDBHandle m l blk
-> ForkerKey
-> (ForkerEnv m l blk
    -> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK))
-> LedgerTables l KeysMK
-> m (LedgerTables l ValuesMK)
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
-> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, HasLedgerTables l, GetTip l) =>
ForkerEnv m l blk
-> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
implForkerReadTables
    , forkerRangeReadTables :: RangeQueryPrevious l -> m (LedgerTables l ValuesMK)
forkerRangeReadTables        = LedgerDBHandle m l blk
-> ForkerKey
-> (ForkerEnv m l blk
    -> RangeQueryPrevious l -> m (LedgerTables l ValuesMK))
-> RangeQueryPrevious l
-> m (LedgerTables l ValuesMK)
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 (QueryBatchSize
-> ForkerEnv m l blk
-> RangeQueryPrevious l
-> m (LedgerTables l ValuesMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, HasLedgerTables l) =>
QueryBatchSize
-> ForkerEnv m l blk
-> RangeQueryPrevious l
-> m (LedgerTables l ValuesMK)
implForkerRangeReadTables QueryBatchSize
qbs)
    , forkerGetLedgerState :: STM m (l EmptyMK)
forkerGetLedgerState         = LedgerDBHandle m l blk
-> ForkerKey
-> (ForkerEnv m l blk -> STM m (l EmptyMK))
-> STM m (l EmptyMK)
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 LedgerDBHandle m l blk
h ForkerKey
forkerKey ForkerEnv m l blk -> STM m (l EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l) =>
ForkerEnv m l blk -> STM m (l EmptyMK)
implForkerGetLedgerState
    , forkerReadStatistics :: m (Maybe Statistics)
forkerReadStatistics         = LedgerDBHandle m l blk
-> ForkerKey
-> (ForkerEnv m l blk -> m (Maybe Statistics))
-> m (Maybe Statistics)
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 -> m (Maybe Statistics)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, HasLedgerTables l, GetTip l) =>
ForkerEnv m l blk -> m (Maybe Statistics)
implForkerReadStatistics
    , forkerPush :: l DiffMK -> m ()
forkerPush                   = LedgerDBHandle m l blk
-> ForkerKey
-> (ForkerEnv m l blk -> l DiffMK -> m ())
-> l DiffMK
-> m ()
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 -> l DiffMK -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l, HasLedgerTables l) =>
ForkerEnv m l blk -> l DiffMK -> m ()
implForkerPush
    , forkerCommit :: STM m ()
forkerCommit                 = LedgerDBHandle m l blk
-> ForkerKey -> (ForkerEnv m l blk -> STM m ()) -> STM m ()
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 LedgerDBHandle m l blk
h ForkerKey
forkerKey ForkerEnv m l blk -> STM m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l, HasLedgerTables l) =>
ForkerEnv m l blk -> STM m ()
implForkerCommit
    }

implForkerClose ::
     IOLike m
  => LedgerDBHandle m l blk
  -> ForkerKey
  -> m ()
implForkerClose :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDBHandle m l blk -> ForkerKey -> m ()
implForkerClose (LDBHandle StrictTVar m (LedgerDBState m l blk)
varState) ForkerKey
forkerKey = do
    envMay <- 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)
            ((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)
    whenJust envMay closeForkerEnv