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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Remove all points with a slot older than the given slot from the set of
-- previously applied points.
implGarbageCollect :: MonadSTM m => LedgerDBEnv m l blk -> SlotNo -> STM m ()
implGarbageCollect :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
MonadSTM m =>
LedgerDBEnv m l blk -> SlotNo -> STM m ()
implGarbageCollect LedgerDBEnv m l blk
env SlotNo
slotNo =
  StrictTVar m (Set (RealPoint blk))
-> (Set (RealPoint blk) -> Set (RealPoint blk)) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
ldbPrevApplied LedgerDBEnv m l blk
env) ((Set (RealPoint blk) -> Set (RealPoint blk)) -> STM m ())
-> (Set (RealPoint blk) -> Set (RealPoint blk)) -> STM m ()
forall a b. (a -> b) -> a -> b
$
    (RealPoint blk -> Bool)
-> Set (RealPoint blk) -> Set (RealPoint blk)
forall a. (a -> Bool) -> Set a -> Set a
Set.dropWhileAntitone ((SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
slotNo) (SlotNo -> Bool)
-> (RealPoint blk -> SlotNo) -> RealPoint blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot)

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

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

implCloseDB :: IOLike m => LedgerDBHandle m l blk -> m ()
implCloseDB :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDBHandle m l blk -> m ()
implCloseDB (LDBHandle StrictTVar m (LedgerDBState m l blk)
varState) = do
  mbOpenEnv <-
    STM m (Maybe (LedgerDBEnv m l blk))
-> m (Maybe (LedgerDBEnv m l blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (LedgerDBEnv m l blk))
 -> m (Maybe (LedgerDBEnv m l blk)))
-> STM m (Maybe (LedgerDBEnv m l blk))
-> m (Maybe (LedgerDBEnv m l blk))
forall a b. (a -> b) -> a -> b
$
      StrictTVar m (LedgerDBState m l blk)
-> STM m (LedgerDBState m l blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (LedgerDBState m l blk)
varState STM m (LedgerDBState m l blk)
-> (LedgerDBState m l blk -> STM m (Maybe (LedgerDBEnv m l blk)))
-> STM m (Maybe (LedgerDBEnv m l blk))
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- Idempotent
        LedgerDBState m l blk
LedgerDBClosed -> Maybe (LedgerDBEnv m l blk) -> STM m (Maybe (LedgerDBEnv m l blk))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LedgerDBEnv m l blk)
forall a. Maybe a
Nothing
        LedgerDBOpen LedgerDBEnv m l blk
env -> do
          StrictTVar m (LedgerDBState m l blk)
-> LedgerDBState m l blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (LedgerDBState m l blk)
varState LedgerDBState m l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBState m l blk
LedgerDBClosed
          Maybe (LedgerDBEnv m l blk) -> STM m (Maybe (LedgerDBEnv m l blk))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (LedgerDBEnv m l blk)
 -> STM m (Maybe (LedgerDBEnv m l blk)))
-> Maybe (LedgerDBEnv m l blk)
-> STM m (Maybe (LedgerDBEnv m l blk))
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> Maybe (LedgerDBEnv m l blk)
forall a. a -> Maybe a
Just LedgerDBEnv m l blk
env

  -- Only when the LedgerDB was open
  whenJust mbOpenEnv $ \LedgerDBEnv m l blk
env -> do
    LedgerDBEnv m l blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDBEnv m l blk -> m ()
closeAllForkers LedgerDBEnv m l blk
env

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

data LDBLock = LDBLock deriving ((forall x. LDBLock -> Rep LDBLock x)
-> (forall x. Rep LDBLock x -> LDBLock) -> Generic LDBLock
forall x. Rep LDBLock x -> LDBLock
forall x. LDBLock -> Rep LDBLock x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LDBLock -> Rep LDBLock x
from :: forall x. LDBLock -> Rep LDBLock x
$cto :: forall x. Rep LDBLock x -> LDBLock
to :: forall x. Rep LDBLock x -> LDBLock
Generic, [String] -> LDBLock -> IO (Maybe ThunkInfo)
Proxy LDBLock -> String
([String] -> LDBLock -> IO (Maybe ThunkInfo))
-> ([String] -> LDBLock -> IO (Maybe ThunkInfo))
-> (Proxy LDBLock -> String)
-> NoThunks LDBLock
forall a.
([String] -> a -> IO (Maybe ThunkInfo))
-> ([String] -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: [String] -> LDBLock -> IO (Maybe ThunkInfo)
noThunks :: [String] -> LDBLock -> IO (Maybe ThunkInfo)
$cwNoThunks :: [String] -> LDBLock -> IO (Maybe ThunkInfo)
wNoThunks :: [String] -> LDBLock -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy LDBLock -> String
showTypeOf :: Proxy LDBLock -> String
NoThunks)

type LedgerDBEnv :: (Type -> Type) -> LedgerStateKind -> Type -> Type
data LedgerDBEnv m l blk = LedgerDBEnv
  { forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
ldbSeq :: !(StrictTVar m (LedgerSeq m l))
  -- ^ INVARIANT: the tip of the 'LedgerDB' is always in sync with the tip of
  -- the current chain of the ChainDB.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
ldbPrevApplied :: !(StrictTVar m (Set (RealPoint blk)))
  -- ^ INVARIANT: this set contains only points that are in the
  -- VolatileDB.
  --
  -- INVARIANT: all points on the current chain fragment are in this set.
  --
  -- The VolatileDB might contain invalid blocks, these will not be in
  -- this set.
  --
  -- When a garbage-collection is performed on the VolatileDB, the points
  -- of the blocks eligible for garbage-collection should be removed from
  -- this set.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk
-> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
ldbForkers :: !(StrictTVar m (Map ForkerKey (ForkerEnv m l blk)))
  -- ^ Open forkers.
  --
  -- INVARIANT: a forker is open iff its 'ForkerKey' is in this 'Map.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m ForkerKey
ldbNextForkerKey :: !(StrictTVar m ForkerKey)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotPolicy
ldbSnapshotPolicy :: !SnapshotPolicy
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> Tracer m (TraceEvent blk)
ldbTracer :: !(Tracer m (TraceEvent blk))
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l
ldbCfg :: !(LedgerDbCfg l)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SomeHasFS m
ldbHasFS :: !(SomeHasFS m)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> ResolveBlock m blk
ldbResolveBlock :: !(ResolveBlock m blk)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> QueryBatchSize
ldbQueryBatchSize :: !QueryBatchSize
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> RAWLock m LDBLock
ldbOpenHandlesLock :: !(RAWLock m LDBLock)
  }
  deriving (forall x. LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x)
-> (forall x. Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk)
-> Generic (LedgerDBEnv m l blk)
forall x. Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
forall x. LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) (l :: LedgerStateKind) blk x.
Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk x.
LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
$cfrom :: forall (m :: * -> *) (l :: LedgerStateKind) blk x.
LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
from :: forall x. LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
$cto :: forall (m :: * -> *) (l :: LedgerStateKind) blk x.
Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
to :: forall x. Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
Generic

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

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

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

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

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

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

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

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

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

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

-- | This function must hold the 'LDBLock' such that handles are not released
-- before they are duplicated.
acquireAtTarget ::
  ( HeaderHash l ~ HeaderHash blk
  , IOLike m
  , GetTip l
  , StandardHash l
  , LedgerSupportsProtocol blk
  ) =>
  LedgerDBEnv m l blk ->
  Either Word64 (Target (Point blk)) ->
  LDBLock ->
  m (Either GetForkerError (StateRef m l))
acquireAtTarget :: forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, GetTip l, StandardHash l,
 LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> LDBLock
-> m (Either GetForkerError (StateRef m l))
acquireAtTarget LedgerDBEnv m l blk
ldbEnv (Right Target (Point blk)
VolatileTip) LDBLock
_ = do
  l <- StrictTVar m (LedgerSeq m l) -> m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
ldbSeq LedgerDBEnv m l blk
ldbEnv)
  let StateRef st tbs = currentHandle l
  t <- duplicate tbs
  pure $ Right $ StateRef st t
acquireAtTarget LedgerDBEnv m l blk
ldbEnv (Right Target (Point blk)
ImmutableTip) LDBLock
_ = do
  l <- StrictTVar m (LedgerSeq m l) -> m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
ldbSeq LedgerDBEnv m l blk
ldbEnv)
  let StateRef st tbs = anchorHandle l
  t <- duplicate tbs
  pure $ Right $ StateRef st t
acquireAtTarget LedgerDBEnv m l blk
ldbEnv (Right (SpecificPoint Point blk
pt)) LDBLock
_ = do
  dblog <- StrictTVar m (LedgerSeq m l) -> m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
ldbSeq LedgerDBEnv m l blk
ldbEnv)
  let immTip = l EmptyMK -> Point l
forall (mk :: MapKind). l mk -> Point l
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip (l EmptyMK -> Point l) -> l EmptyMK -> Point l
forall a b. (a -> b) -> a -> b
$ LedgerSeq m l -> l EmptyMK
forall (m :: * -> *) (l :: LedgerStateKind).
LedgerSeq m l -> l EmptyMK
anchor LedgerSeq m l
dblog
  case currentHandle <$> rollback pt dblog of
    Maybe (StateRef m l)
Nothing
      | Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
pt WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< Point l -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point l
immTip -> Either GetForkerError (StateRef m l)
-> m (Either GetForkerError (StateRef m l))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either GetForkerError (StateRef m l)
 -> m (Either GetForkerError (StateRef m l)))
-> Either GetForkerError (StateRef m l)
-> m (Either GetForkerError (StateRef m l))
forall a b. (a -> b) -> a -> b
$ GetForkerError -> Either GetForkerError (StateRef m l)
forall a b. a -> Either a b
Left (GetForkerError -> Either GetForkerError (StateRef m l))
-> GetForkerError -> Either GetForkerError (StateRef m l)
forall a b. (a -> b) -> a -> b
$ Maybe ExceededRollback -> GetForkerError
PointTooOld Maybe ExceededRollback
forall a. Maybe a
Nothing
      | Bool
otherwise -> Either GetForkerError (StateRef m l)
-> m (Either GetForkerError (StateRef m l))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either GetForkerError (StateRef m l)
 -> m (Either GetForkerError (StateRef m l)))
-> Either GetForkerError (StateRef m l)
-> m (Either GetForkerError (StateRef m l))
forall a b. (a -> b) -> a -> b
$ GetForkerError -> Either GetForkerError (StateRef m l)
forall a b. a -> Either a b
Left GetForkerError
PointNotOnChain
    Just (StateRef l EmptyMK
st LedgerTablesHandle m l
tbs) ->
      StateRef m l -> Either GetForkerError (StateRef m l)
forall a b. b -> Either a b
Right (StateRef m l -> Either GetForkerError (StateRef m l))
-> (LedgerTablesHandle m l -> StateRef m l)
-> LedgerTablesHandle m l
-> Either GetForkerError (StateRef m l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l EmptyMK -> LedgerTablesHandle m l -> StateRef m l
forall (m :: * -> *) (l :: LedgerStateKind).
l EmptyMK -> LedgerTablesHandle m l -> StateRef m l
StateRef l EmptyMK
st (LedgerTablesHandle m l -> Either GetForkerError (StateRef m l))
-> m (LedgerTablesHandle m l)
-> m (Either GetForkerError (StateRef m l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerTablesHandle m l -> m (LedgerTablesHandle m l)
forall (m :: * -> *) (l :: LedgerStateKind).
LedgerTablesHandle m l -> m (LedgerTablesHandle m l)
duplicate LedgerTablesHandle m l
tbs
acquireAtTarget LedgerDBEnv m l blk
ldbEnv (Left Word64
n) LDBLock
_ = do
  dblog <- StrictTVar m (LedgerSeq m l) -> m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
ldbSeq LedgerDBEnv m l blk
ldbEnv)
  case currentHandle <$> rollbackN n dblog of
    Maybe (StateRef m l)
Nothing ->
      Either GetForkerError (StateRef m l)
-> m (Either GetForkerError (StateRef m l))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GetForkerError (StateRef m l)
 -> m (Either GetForkerError (StateRef m l)))
-> Either GetForkerError (StateRef m l)
-> m (Either GetForkerError (StateRef m l))
forall a b. (a -> b) -> a -> b
$
        GetForkerError -> Either GetForkerError (StateRef m l)
forall a b. a -> Either a b
Left (GetForkerError -> Either GetForkerError (StateRef m l))
-> GetForkerError -> Either GetForkerError (StateRef m l)
forall a b. (a -> b) -> a -> b
$
          Maybe ExceededRollback -> GetForkerError
PointTooOld (Maybe ExceededRollback -> GetForkerError)
-> Maybe ExceededRollback -> GetForkerError
forall a b. (a -> b) -> a -> b
$
            ExceededRollback -> Maybe ExceededRollback
forall a. a -> Maybe a
Just (ExceededRollback -> Maybe ExceededRollback)
-> ExceededRollback -> Maybe ExceededRollback
forall a b. (a -> b) -> a -> b
$
              ExceededRollback
                { rollbackMaximum :: Word64
rollbackMaximum = LedgerSeq m l -> Word64
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> Word64
maxRollback LedgerSeq m l
dblog
                , rollbackRequested :: Word64
rollbackRequested = Word64
n
                }
    Just (StateRef l EmptyMK
st LedgerTablesHandle m l
tbs) ->
      StateRef m l -> Either GetForkerError (StateRef m l)
forall a b. b -> Either a b
Right (StateRef m l -> Either GetForkerError (StateRef m l))
-> (LedgerTablesHandle m l -> StateRef m l)
-> LedgerTablesHandle m l
-> Either GetForkerError (StateRef m l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l EmptyMK -> LedgerTablesHandle m l -> StateRef m l
forall (m :: * -> *) (l :: LedgerStateKind).
l EmptyMK -> LedgerTablesHandle m l -> StateRef m l
StateRef l EmptyMK
st (LedgerTablesHandle m l -> Either GetForkerError (StateRef m l))
-> m (LedgerTablesHandle m l)
-> m (Either GetForkerError (StateRef m l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerTablesHandle m l -> m (LedgerTablesHandle m l)
forall (m :: * -> *) (l :: LedgerStateKind).
LedgerTablesHandle m l -> m (LedgerTablesHandle m l)
duplicate LedgerTablesHandle m l
tbs

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

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

-- | Close all open 'Forker's.
closeAllForkers ::
  IOLike m =>
  LedgerDBEnv m l blk ->
  m ()
closeAllForkers :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDBEnv m l blk -> m ()
closeAllForkers LedgerDBEnv m l blk
ldbEnv = do
  toClose <- (ForkerEnv m l blk -> (LedgerDBEnv m l blk, ForkerEnv m l blk))
-> Map ForkerKey (ForkerEnv m l blk)
-> Map ForkerKey (LedgerDBEnv m l blk, ForkerEnv m l blk)
forall a b. (a -> b) -> Map ForkerKey a -> Map ForkerKey b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LedgerDBEnv m l blk
ldbEnv,) (Map ForkerKey (ForkerEnv m l blk)
 -> Map ForkerKey (LedgerDBEnv m l blk, ForkerEnv m l blk))
-> m (Map ForkerKey (ForkerEnv m l blk))
-> m (Map ForkerKey (LedgerDBEnv m l blk, ForkerEnv m l blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (STM m (Map ForkerKey (ForkerEnv m l blk))
-> m (Map ForkerKey (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 (Map ForkerKey (ForkerEnv m l blk))
 -> m (Map ForkerKey (ForkerEnv m l blk)))
-> STM m (Map ForkerKey (ForkerEnv m l blk))
-> m (Map ForkerKey (ForkerEnv m l blk))
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
-> (Map ForkerKey (ForkerEnv m l blk)
    -> (Map ForkerKey (ForkerEnv m l blk),
        Map ForkerKey (ForkerEnv m l blk)))
-> STM m (Map ForkerKey (ForkerEnv m l blk))
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
forkersVar (,Map ForkerKey (ForkerEnv m l blk)
forall k a. Map k a
Map.empty))
  mapM_ closeForkerEnv toClose
 where
  forkersVar :: StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
forkersVar = LedgerDBEnv m l blk
-> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk
-> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
ldbForkers LedgerDBEnv m l blk
ldbEnv

closeForkerEnv :: IOLike m => (LedgerDBEnv m l blk, ForkerEnv m l blk) -> m ()
closeForkerEnv :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
(LedgerDBEnv m l blk, ForkerEnv m l blk) -> m ()
closeForkerEnv (LedgerDBEnv{RAWLock m LDBLock
ldbOpenHandlesLock :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> RAWLock m LDBLock
ldbOpenHandlesLock :: RAWLock m LDBLock
ldbOpenHandlesLock}, ForkerEnv m l blk
frkEnv) =
  RAWLock m LDBLock -> (LDBLock -> m ((), LDBLock)) -> m ()
forall (m :: * -> *) st a.
(MonadSTM m, MonadCatch m, MonadThrow (STM m)) =>
RAWLock m st -> (st -> m (a, st)) -> m a
RAWLock.withWriteAccess RAWLock m LDBLock
ldbOpenHandlesLock ((LDBLock -> m ((), LDBLock)) -> m ())
-> (LDBLock -> m ((), LDBLock)) -> m ()
forall a b. (a -> b) -> a -> b
$
    m ((), LDBLock) -> LDBLock -> m ((), LDBLock)
forall a b. a -> b -> a
const (m ((), LDBLock) -> LDBLock -> m ((), LDBLock))
-> m ((), LDBLock) -> LDBLock -> m ((), LDBLock)
forall a b. (a -> b) -> a -> b
$ do
      m () -> m ()
forall a. a -> a
id (m () -> m ()) -> m (m ()) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StrictTVar m (m ()) -> m (m ())
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (ForkerEnv m l blk -> StrictTVar m (m ())
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> StrictTVar m (m ())
foeResourcesToRelease ForkerEnv m l blk
frkEnv)
      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 (m ()) -> m () -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ForkerEnv m l blk -> StrictTVar m (m ())
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> StrictTVar m (m ())
foeResourcesToRelease ForkerEnv m l blk
frkEnv) (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      ((), LDBLock) -> m ((), LDBLock)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), LDBLock
LDBLock)

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

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

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

-- | Will release all handles in the 'foeLedgerSeq'.
implForkerClose ::
  IOLike m =>
  LedgerDBHandle m l blk ->
  ForkerKey ->
  m ()
implForkerClose :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDBHandle m l blk -> ForkerKey -> m ()
implForkerClose (LDBHandle StrictTVar m (LedgerDBState m l blk)
varState) ForkerKey
forkerKey = do
  menv <-
    STM m (Maybe (LedgerDBEnv m l blk, ForkerEnv m l blk))
-> m (Maybe (LedgerDBEnv m l blk, 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 (LedgerDBEnv m l blk, ForkerEnv m l blk))
 -> m (Maybe (LedgerDBEnv m l blk, ForkerEnv m l blk)))
-> STM m (Maybe (LedgerDBEnv m l blk, ForkerEnv m l blk))
-> m (Maybe (LedgerDBEnv m l blk, 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 (LedgerDBEnv m l blk, ForkerEnv m l blk)))
-> STM m (Maybe (LedgerDBEnv m l blk, 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 (LedgerDBEnv m l blk, ForkerEnv m l blk)
-> STM m (Maybe (LedgerDBEnv m l blk, ForkerEnv m l blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (LedgerDBEnv m l blk, ForkerEnv m l blk)
forall a. Maybe a
Nothing
        LedgerDBOpen LedgerDBEnv m l blk
ldbEnv ->
          (ForkerEnv m l blk -> (LedgerDBEnv m l blk, ForkerEnv m l blk))
-> Maybe (ForkerEnv m l blk)
-> Maybe (LedgerDBEnv m l blk, ForkerEnv m l blk)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LedgerDBEnv m l blk
ldbEnv,)
            (Maybe (ForkerEnv m l blk)
 -> Maybe (LedgerDBEnv m l blk, ForkerEnv m l blk))
-> STM m (Maybe (ForkerEnv m l blk))
-> STM m (Maybe (LedgerDBEnv m l blk, ForkerEnv m l blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
-> (Map ForkerKey (ForkerEnv m l blk)
    -> (Maybe (ForkerEnv m l blk), Map ForkerKey (ForkerEnv m l blk)))
-> STM m (Maybe (ForkerEnv m l blk))
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar
              (LedgerDBEnv m l blk
-> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk
-> StrictTVar m (Map ForkerKey (ForkerEnv m l blk))
ldbForkers LedgerDBEnv m l blk
ldbEnv)
              ((ForkerKey -> ForkerEnv m l blk -> Maybe (ForkerEnv m l blk))
-> ForkerKey
-> Map ForkerKey (ForkerEnv m l blk)
-> (Maybe (ForkerEnv m l blk), Map ForkerKey (ForkerEnv m l blk))
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\ForkerKey
_ ForkerEnv m l blk
_ -> Maybe (ForkerEnv m l blk)
forall a. Maybe a
Nothing) ForkerKey
forkerKey)
  whenJust menv closeForkerEnv

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