{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# 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.Monad.Trans (lift)
import Control.ResourceRegistry
import Control.Tracer
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, ResourceKey m, 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, ResourceKey m, 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), ResourceKey m,
   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
        (bsKey, 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, bsKey, backingStore)
    , initFromSnapshot :: DiskSnapshot
-> m (Either
        (SnapshotFailure blk)
        ((DbChangelog (ExtLedgerState blk), ResourceKey m,
          LedgerBackingStore m (ExtLedgerState blk)),
         RealPoint blk))
initFromSnapshot =
        ExceptT
  (SnapshotFailure blk)
  m
  ((DbChangelog (ExtLedgerState blk), ResourceKey m,
    LedgerBackingStore m (ExtLedgerState blk)),
   RealPoint blk)
-> m (Either
        (SnapshotFailure blk)
        ((DbChangelog (ExtLedgerState blk), ResourceKey m,
          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), ResourceKey m,
     LedgerBackingStore m (ExtLedgerState blk)),
    RealPoint blk)
 -> m (Either
         (SnapshotFailure blk)
         ((DbChangelog (ExtLedgerState blk), ResourceKey m,
           LedgerBackingStore m (ExtLedgerState blk)),
          RealPoint blk)))
-> (DiskSnapshot
    -> ExceptT
         (SnapshotFailure blk)
         m
         ((DbChangelog (ExtLedgerState blk), ResourceKey m,
           LedgerBackingStore m (ExtLedgerState blk)),
          RealPoint blk))
-> DiskSnapshot
-> m (Either
        (SnapshotFailure blk)
        ((DbChangelog (ExtLedgerState blk), ResourceKey m,
          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
-> ResourceRegistry m
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     ((DbChangelog (ExtLedgerState blk), ResourceKey m,
       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
-> ResourceRegistry m
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     ((DbChangelog' blk, ResourceKey m,
       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'
            ResourceRegistry m
HKD Identity (ResourceRegistry m)
lgrRegistry
    , closeDb :: (DbChangelog (ExtLedgerState blk), ResourceKey m,
 LedgerBackingStore m (ExtLedgerState blk))
-> m ()
closeDb = \(DbChangelog (ExtLedgerState blk)
_, ResourceKey m
r, LedgerBackingStore m (ExtLedgerState blk)
_) -> m (Maybe (Context m)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (Context m)) -> m ()) -> m (Maybe (Context m)) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceKey m -> m (Maybe (Context m))
forall (m :: * -> *).
(MonadMask m, MonadSTM m, MonadThread m, HasCallStack) =>
ResourceKey m -> m (Maybe (Context m))
release ResourceKey m
r
    , initReapplyBlock :: LedgerDbCfg (ExtLedgerState blk)
-> blk
-> (DbChangelog (ExtLedgerState blk), ResourceKey m,
    LedgerBackingStore m (ExtLedgerState blk))
-> m (DbChangelog (ExtLedgerState blk), ResourceKey m,
      LedgerBackingStore m (ExtLedgerState blk))
initReapplyBlock = \LedgerDbCfg (ExtLedgerState blk)
cfg blk
blk (DbChangelog (ExtLedgerState blk)
chlog, ResourceKey m
r, 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'', r, bstore)
    , currentTip :: (DbChangelog (ExtLedgerState blk), ResourceKey m,
 LedgerBackingStore m (ExtLedgerState blk))
-> LedgerState blk EmptyMK
currentTip = \(DbChangelog (ExtLedgerState blk)
ch, ResourceKey m
_, LedgerBackingStore m (ExtLedgerState blk)
_) -> 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) -> ExtLedgerState blk EmptyMK)
-> DbChangelog (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) -> LedgerState blk EmptyMK)
-> DbChangelog (ExtLedgerState blk) -> LedgerState blk EmptyMK
forall a b. (a -> b) -> a -> b
$ DbChangelog (ExtLedgerState blk)
ch
    , pruneDb :: (DbChangelog (ExtLedgerState blk), ResourceKey m,
 LedgerBackingStore m (ExtLedgerState blk))
-> m (DbChangelog (ExtLedgerState blk), ResourceKey m,
      LedgerBackingStore m (ExtLedgerState blk))
pruneDb = \(DbChangelog (ExtLedgerState blk)
ch, ResourceKey m
r, LedgerBackingStore m (ExtLedgerState blk)
bs) -> (DbChangelog (ExtLedgerState blk), ResourceKey m,
 LedgerBackingStore m (ExtLedgerState blk))
-> m (DbChangelog (ExtLedgerState blk), ResourceKey m,
      LedgerBackingStore m (ExtLedgerState blk))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DbChangelog (ExtLedgerState blk)
-> DbChangelog (ExtLedgerState blk)
forall (l :: LedgerStateKind).
GetTip l =>
DbChangelog l -> DbChangelog l
pruneToImmTipOnly DbChangelog (ExtLedgerState blk)
ch, ResourceKey m
r, LedgerBackingStore m (ExtLedgerState blk)
bs)
    , mkLedgerDb :: (DbChangelog (ExtLedgerState blk), ResourceKey m,
 LedgerBackingStore m (ExtLedgerState blk))
-> m (LedgerDB m (ExtLedgerState blk) blk,
      TestInternals m (ExtLedgerState blk) blk)
mkLedgerDb = \(DbChangelog (ExtLedgerState blk)
db, ResourceKey m
ldbBackingStoreKey, LedgerBackingStore m (ExtLedgerState blk)
ldbBackingStore) -> 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)
ldbBackingStore
                , ldbBackingStoreKey :: ResourceKey m
ldbBackingStoreKey = ResourceKey m
ldbBackingStoreKey
                , 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
          -- By writing this tvar, we already make sure that no
          -- forkers can perform operations other than closing, as
          -- they rely on accessing the LedgerDB, which is now closed.
          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 $ void . release . ldbBackingStoreKey

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
$ m (Maybe (Context m)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (Context m)) -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk
    -> m (Maybe (Context m)))
-> LedgerDBEnv m (ExtLedgerState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResourceKey m -> m (Maybe (Context m))
forall (m :: * -> *).
(MonadMask m, MonadSTM m, MonadThread m, HasCallStack) =>
ResourceKey m -> m (Maybe (Context m))
release (ResourceKey m -> m (Maybe (Context m)))
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> ResourceKey m)
-> LedgerDBEnv m (ExtLedgerState blk) blk
-> m (Maybe (Context m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBEnv m (ExtLedgerState blk) blk -> ResourceKey m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> ResourceKey m
ldbBackingStoreKey
    , 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
    , getNumLedgerTablesHandles :: m Word64
getNumLedgerTablesHandles = Word64 -> m Word64
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
0
    }

-- | 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
  { forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog :: !(StrictTVar m (DbChangelog l))
  -- ^ INVARIANT: the tip of the 'LedgerDB' is always in sync with the tip of
  -- the current chain of the ChainDB.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerBackingStore m l
ldbBackingStore :: !(LedgerBackingStore m 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 -> ResourceKey m
ldbBackingStoreKey :: !(ResourceKey m)
  -- ^ When deallocating the backing store upon closing the LedgerDB
  -- (via the ChainDB shutting down), we will release the backing
  -- store with this action.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDBLock m
ldbLock :: !(LedgerDBLock m)
  -- ^ 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 -> StrictTVar m (Set (RealPoint blk))
ldbPrevApplied :: !(StrictTVar m (Set (RealPoint blk)))
  -- ^ INVARIANT: this set contains only points that are in the
  -- VolatileDB.
  --
  -- INVARIANT: all points on the current chain fragment are in this set.
  --
  -- The VolatileDB might contain invalid blocks, these will not be in
  -- this set.
  --
  -- When a garbage-collection is performed on the VolatileDB, the points
  -- of the blocks eligible for garbage-collection should be removed from
  -- this set.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk
-> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
ldbForkers :: !(StrictTVar m (Map ForkerKey (ForkerEnv m l blk)))
  -- ^ Open forkers.
  --
  -- INVARIANT: a forker is open iff its 'ForkerKey' is in this 'Map.
  --
  -- The resources that could possibly be held by these forkers will
  -- be released by each one of the client's registries. This means
  -- that for example ChainSelection will, upon closing its registry,
  -- release its forker and any resources associated.
  --
  -- Upon closing the LedgerDB we will overwrite this variable such
  -- that existing forkers can only be closed, as closing doesn't
  -- involve accessing this map (other than possibly removing the
  -- forker from it if the map still exists).
  --
  -- As the LedgerDB should outlive any clients, this is fine.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m ForkerKey
ldbNextForkerKey :: !(StrictTVar m ForkerKey)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotPolicy
ldbSnapshotPolicy :: !SnapshotPolicy
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> Tracer m (TraceEvent blk)
ldbTracer :: !(Tracer m (TraceEvent blk))
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l
ldbCfg :: !(LedgerDbCfg l)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotsFS m
ldbHasFS :: !(SnapshotsFS m)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> Word64 -> Bool
ldbShouldFlush :: !(Word64 -> Bool)
  -- ^ 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 -> 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 (Forker m l blk))
-> m (Either GetForkerError (Forker m l 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
ldbEnv)
    ( LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> ReadLocked m (Either GetForkerError (DbChangelog l))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> ReadLocked m (Either GetForkerError (DbChangelog l))
acquireAtTarget LedgerDBEnv m l blk
ldbEnv (Target (Point blk) -> Either Word64 (Target (Point blk))
forall a b. b -> Either a b
Right Target (Point blk)
pt)
        ReadLocked m (Either GetForkerError (DbChangelog l))
-> (Either GetForkerError (DbChangelog l)
    -> ReadLocked m (Either GetForkerError (Forker m l blk)))
-> ReadLocked m (Either GetForkerError (Forker m l blk))
forall a b.
ReadLocked m a -> (a -> ReadLocked m b) -> ReadLocked m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (DbChangelog l -> ReadLocked m (Forker m l blk))
-> Either GetForkerError (DbChangelog l)
-> ReadLocked m (Either GetForkerError (Forker m l blk))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> Either GetForkerError a -> f (Either GetForkerError b)
traverse (LedgerDBHandle m l blk
-> LedgerDBEnv m l blk
-> ResourceRegistry m
-> DbChangelog l
-> ReadLocked 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
-> ResourceRegistry m
-> DbChangelog l
-> ReadLocked m (Forker m l blk)
newForker LedgerDBHandle m l blk
h LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr)
    )

newForkerByRollback ::
  ( HeaderHash l ~ HeaderHash blk
  , IOLike m
  , IsLedger l
  , StandardHash l
  , HasLedgerTables l
  , LedgerSupportsProtocol blk
  ) =>
  LedgerDBHandle m l blk ->
  ResourceRegistry m ->
  -- | 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 (Forker m l blk))
-> m (Either GetForkerError (Forker m l 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
ldbEnv) (LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> ReadLocked m (Either GetForkerError (DbChangelog l))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> ReadLocked m (Either GetForkerError (DbChangelog l))
acquireAtTarget LedgerDBEnv m l blk
ldbEnv (Word64 -> Either Word64 (Target (Point blk))
forall a b. a -> Either a b
Left Word64
n) ReadLocked m (Either GetForkerError (DbChangelog l))
-> (Either GetForkerError (DbChangelog l)
    -> ReadLocked m (Either GetForkerError (Forker m l blk)))
-> ReadLocked m (Either GetForkerError (Forker m l blk))
forall a b.
ReadLocked m a -> (a -> ReadLocked m b) -> ReadLocked m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (DbChangelog l -> ReadLocked m (Forker m l blk))
-> Either GetForkerError (DbChangelog l)
-> ReadLocked m (Either GetForkerError (Forker m l blk))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> Either GetForkerError a -> f (Either GetForkerError b)
traverse (LedgerDBHandle m l blk
-> LedgerDBEnv m l blk
-> ResourceRegistry m
-> DbChangelog l
-> ReadLocked 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
-> ResourceRegistry m
-> DbChangelog l
-> ReadLocked m (Forker m l blk)
newForker LedgerDBHandle m l blk
h LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr))

-- | 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 ->
  Either Word64 (Target (Point blk)) ->
  ReadLocked m (Either GetForkerError (DbChangelog 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
-> Either Word64 (Target (Point blk))
-> ReadLocked m (Either GetForkerError (DbChangelog l))
acquireAtTarget LedgerDBEnv m l blk
ldbEnv Either Word64 (Target (Point blk))
target = m (Either GetForkerError (DbChangelog l))
-> ReadLocked m (Either GetForkerError (DbChangelog l))
forall (m :: * -> *) a. m a -> ReadLocked m a
readLocked (m (Either GetForkerError (DbChangelog l))
 -> ReadLocked m (Either GetForkerError (DbChangelog l)))
-> m (Either GetForkerError (DbChangelog l))
-> ReadLocked m (Either GetForkerError (DbChangelog l))
forall a b. (a -> b) -> a -> b
$ ExceptT GetForkerError m (DbChangelog l)
-> m (Either GetForkerError (DbChangelog l))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT GetForkerError m (DbChangelog l)
 -> m (Either GetForkerError (DbChangelog l)))
-> ExceptT GetForkerError m (DbChangelog l)
-> m (Either GetForkerError (DbChangelog l))
forall a b. (a -> b) -> a -> b
$ do
  dblog <- m (DbChangelog l) -> ExceptT GetForkerError m (DbChangelog l)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT GetForkerError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (DbChangelog l) -> ExceptT GetForkerError m (DbChangelog l))
-> m (DbChangelog l) -> ExceptT GetForkerError m (DbChangelog l)
forall a b. (a -> b) -> a -> b
$ 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)
  -- Get the prefix of the dblog ending in the specified target.
  case target of
    Right Target (Point blk)
VolatileTip -> DbChangelog l -> ExceptT GetForkerError m (DbChangelog l)
forall a. a -> ExceptT GetForkerError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DbChangelog l
dblog
    Right Target (Point blk)
ImmutableTip -> DbChangelog l -> ExceptT GetForkerError m (DbChangelog l)
forall a. a -> ExceptT GetForkerError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DbChangelog l -> ExceptT GetForkerError m (DbChangelog l))
-> DbChangelog l -> ExceptT GetForkerError m (DbChangelog l)
forall a b. (a -> b) -> a -> b
$ DbChangelog l -> DbChangelog l
forall (l :: LedgerStateKind).
(GetTip l, HasLedgerTables l) =>
DbChangelog l -> DbChangelog l
rollbackToAnchor DbChangelog l
dblog
    Right (SpecificPoint Point blk
pt) -> do
      let immTip :: Point l
immTip = l EmptyMK -> Point l
forall (mk :: MapKind). l mk -> Point l
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip (l EmptyMK -> Point l) -> l EmptyMK -> Point l
forall a b. (a -> b) -> a -> b
$ DbChangelog l -> l EmptyMK
forall (l :: LedgerStateKind). DbChangelog l -> l EmptyMK
anchor DbChangelog l
dblog
      case Point blk -> DbChangelog l -> Maybe (DbChangelog l)
forall blk (l :: LedgerStateKind).
(HasHeader blk, IsLedger l, HeaderHash l ~ HeaderHash blk,
 StandardHash l, HasLedgerTables l) =>
Point blk -> DbChangelog l -> Maybe (DbChangelog l)
rollback Point blk
pt DbChangelog l
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 -> GetForkerError -> ExceptT GetForkerError m (DbChangelog l)
forall a. GetForkerError -> ExceptT GetForkerError m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GetForkerError -> ExceptT GetForkerError m (DbChangelog l))
-> GetForkerError -> ExceptT GetForkerError m (DbChangelog l)
forall a b. (a -> b) -> a -> b
$ Maybe ExceededRollback -> GetForkerError
PointTooOld Maybe ExceededRollback
forall a. Maybe a
Nothing
          | Bool
otherwise -> GetForkerError -> ExceptT GetForkerError m (DbChangelog l)
forall a. GetForkerError -> ExceptT GetForkerError m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GetForkerError
PointNotOnChain
        Just DbChangelog l
dblog' -> DbChangelog l -> ExceptT GetForkerError m (DbChangelog l)
forall a. a -> ExceptT GetForkerError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DbChangelog l
dblog'
    Left Word64
n -> case Word64 -> DbChangelog l -> Maybe (DbChangelog l)
forall (l :: LedgerStateKind).
(GetTip l, HasLedgerTables l) =>
Word64 -> DbChangelog l -> Maybe (DbChangelog l)
rollbackN Word64
n DbChangelog l
dblog of
      Maybe (DbChangelog l)
Nothing ->
        GetForkerError -> ExceptT GetForkerError m (DbChangelog l)
forall a. GetForkerError -> ExceptT GetForkerError m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GetForkerError -> ExceptT GetForkerError m (DbChangelog l))
-> GetForkerError -> ExceptT GetForkerError m (DbChangelog l)
forall a b. (a -> b) -> a -> b
$
          Maybe ExceededRollback -> GetForkerError
PointTooOld (Maybe ExceededRollback -> GetForkerError)
-> Maybe ExceededRollback -> GetForkerError
forall a b. (a -> b) -> a -> b
$
            ExceededRollback -> Maybe ExceededRollback
forall a. a -> Maybe a
Just
              ExceededRollback
                { rollbackMaximum :: Word64
rollbackMaximum = DbChangelog l -> Word64
forall (l :: LedgerStateKind). GetTip l => DbChangelog l -> Word64
maxRollback DbChangelog l
dblog
                , rollbackRequested :: Word64
rollbackRequested = Word64
n
                }
      Just DbChangelog l
dblog' -> DbChangelog l -> ExceptT GetForkerError m (DbChangelog l)
forall a. a -> ExceptT GetForkerError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DbChangelog l
dblog'

{-------------------------------------------------------------------------------
  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 ->
  ResourceRegistry m ->
  DbChangelog l ->
  ReadLocked 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
-> ResourceRegistry m
-> DbChangelog l
-> ReadLocked m (Forker m l blk)
newForker LedgerDBHandle m l blk
h LedgerDBEnv m l blk
ldbEnv ResourceRegistry m
rr DbChangelog l
dblog = m (Forker m l blk) -> ReadLocked m (Forker m l blk)
forall (m :: * -> *) a. m a -> ReadLocked m a
readLocked (m (Forker m l blk) -> ReadLocked m (Forker m l blk))
-> m (Forker m l blk) -> ReadLocked m (Forker m l blk)
forall a b. (a -> b) -> a -> b
$ 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)
  forkerMVar <- newMVar $ Left (ldbLock ldbEnv, ldbBackingStore ldbEnv, rr)
  let forkerEnv =
        ForkerEnv
          { foeBackingStoreValueHandle :: StrictMVar
  m
  (Either
     (LedgerDBLock m, LedgerBackingStore m l, ResourceRegistry m)
     (ResourceKey m, LedgerBackingStoreValueHandle m l))
foeBackingStoreValueHandle = StrictMVar
  m
  (Either
     (LedgerDBLock m, LedgerBackingStore m l, ResourceRegistry m)
     (ResourceKey m, LedgerBackingStoreValueHandle m l))
forkerMVar
          , 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 $ do
    -- We need to make sure to release this read access when we drop the value
    -- handle, so in 'closeForkerEnv' (if it wasn't promoted) or in
    -- 'getValueHandle' (if it was promoted).
    unsafeAcquireReadAccess (ldbLock ldbEnv)

    -- Note that we add the forkerEnv to the 'ldbForkers' so that an exception
    -- which will close all the forkers, also closes this one, releasing the
    -- read access we acquired above.
    modifyTVar (ldbForkers ldbEnv) $ Map.insert forkerKey forkerEnv
  traceWith (foeTracer forkerEnv) ForkerOpen
  pure $ mkForker h (ldbQueryBatchSize ldbEnv) forkerKey forkerEnv

mkForker ::
  ( IOLike m
  , HasHeader blk
  , HasLedgerTables l
  , GetTip l
  ) =>
  LedgerDBHandle m l blk ->
  QueryBatchSize ->
  ForkerKey ->
  ForkerEnv m l blk ->
  Forker m l blk
mkForker :: forall (m :: * -> *) blk (l :: LedgerStateKind).
(IOLike m, HasHeader blk, HasLedgerTables l, GetTip l) =>
LedgerDBHandle m l blk
-> QueryBatchSize
-> ForkerKey
-> ForkerEnv m l blk
-> Forker m l blk
mkForker LedgerDBHandle m l blk
h QueryBatchSize
qbs ForkerKey
forkerKey ForkerEnv m l blk
forkerEnv =
  Forker
    { forkerClose :: m ()
forkerClose = LedgerDBHandle m l blk -> ForkerKey -> ForkerEnv m l blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDBHandle m l blk -> ForkerKey -> ForkerEnv m l blk -> m ()
implForkerClose LedgerDBHandle m l blk
h ForkerKey
forkerKey ForkerEnv m l blk
forkerEnv
    , 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.
(IOLike 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.
(IOLike m, GetTip l, 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.
(IOLike 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
    }

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