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

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

import qualified Control.Monad as Monad (join, void)
import Control.Monad.Except
import Control.RAWLock
import qualified Control.RAWLock as RAWLock
import Control.Tracer
import Data.Bifunctor (first)
import qualified Data.Foldable as Foldable
import Data.Functor.Contravariant ((>$<))
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Traversable (for)
import Data.Tuple (Solo (..))
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.Backend
import Ouroboros.Consensus.Storage.LedgerDB.V2.Forker
import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
import Ouroboros.Consensus.Util (whenJust)
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)

type SnapshotManagerV2 m blk = SnapshotManager m m blk (StateRef m (ExtLedgerState blk))

newtype SnapshotExc blk = SnapshotExc {forall blk. SnapshotExc blk -> SnapshotFailure blk
getSnapshotFailure :: SnapshotFailure blk}
  deriving (Int -> SnapshotExc blk -> ShowS
[SnapshotExc blk] -> ShowS
SnapshotExc blk -> String
(Int -> SnapshotExc blk -> ShowS)
-> (SnapshotExc blk -> String)
-> ([SnapshotExc blk] -> ShowS)
-> Show (SnapshotExc blk)
forall blk. StandardHash blk => Int -> SnapshotExc blk -> ShowS
forall blk. StandardHash blk => [SnapshotExc blk] -> ShowS
forall blk. StandardHash blk => SnapshotExc blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. StandardHash blk => Int -> SnapshotExc blk -> ShowS
showsPrec :: Int -> SnapshotExc blk -> ShowS
$cshow :: forall blk. StandardHash blk => SnapshotExc blk -> String
show :: SnapshotExc blk -> String
$cshowList :: forall blk. StandardHash blk => [SnapshotExc blk] -> ShowS
showList :: [SnapshotExc blk] -> ShowS
Show, Show (SnapshotExc blk)
Typeable (SnapshotExc blk)
(Typeable (SnapshotExc blk), Show (SnapshotExc blk)) =>
(SnapshotExc blk -> SomeException)
-> (SomeException -> Maybe (SnapshotExc blk))
-> (SnapshotExc blk -> String)
-> (SnapshotExc blk -> Bool)
-> Exception (SnapshotExc blk)
SomeException -> Maybe (SnapshotExc blk)
SnapshotExc blk -> Bool
SnapshotExc blk -> String
SnapshotExc blk -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
forall blk.
(StandardHash blk, Typeable blk) =>
Show (SnapshotExc blk)
forall blk.
(StandardHash blk, Typeable blk) =>
Typeable (SnapshotExc blk)
forall blk.
(StandardHash blk, Typeable blk) =>
SomeException -> Maybe (SnapshotExc blk)
forall blk.
(StandardHash blk, Typeable blk) =>
SnapshotExc blk -> Bool
forall blk.
(StandardHash blk, Typeable blk) =>
SnapshotExc blk -> String
forall blk.
(StandardHash blk, Typeable blk) =>
SnapshotExc blk -> SomeException
$ctoException :: forall blk.
(StandardHash blk, Typeable blk) =>
SnapshotExc blk -> SomeException
toException :: SnapshotExc blk -> SomeException
$cfromException :: forall blk.
(StandardHash blk, Typeable blk) =>
SomeException -> Maybe (SnapshotExc blk)
fromException :: SomeException -> Maybe (SnapshotExc blk)
$cdisplayException :: forall blk.
(StandardHash blk, Typeable blk) =>
SnapshotExc blk -> String
displayException :: SnapshotExc blk -> String
$cbacktraceDesired :: forall blk.
(StandardHash blk, Typeable blk) =>
SnapshotExc blk -> Bool
backtraceDesired :: SnapshotExc blk -> Bool
Exception)

mkInitDb ::
  forall m blk backend.
  ( LedgerSupportsProtocol blk
  , HasHardForkHistory blk
  , Backend m backend blk
  , IOLike m
  ) =>
  Complete LedgerDbArgs m blk ->
  ResolveBlock m blk ->
  SnapshotManagerV2 m blk ->
  GetVolatileSuffix m blk ->
  Resources m backend ->
  InitDB (LedgerSeq' m blk) m blk
mkInitDb :: forall (m :: * -> *) blk backend.
(LedgerSupportsProtocol blk, HasHardForkHistory blk,
 Backend m backend blk, IOLike m) =>
Complete LedgerDbArgs m blk
-> ResolveBlock m blk
-> SnapshotManagerV2 m blk
-> GetVolatileSuffix m blk
-> Resources m backend
-> InitDB (LedgerSeq' m blk) m blk
mkInitDb Complete LedgerDbArgs m blk
args ResolveBlock m blk
getBlock SnapshotManagerV2 m blk
snapManager GetVolatileSuffix m blk
getVolatileSuffix Resources m backend
res = do
  InitDB
    { initFromGenesis :: m (LedgerSeq m (ExtLedgerState blk))
initFromGenesis = do
        genesis <- m (ExtLedgerState blk ValuesMK)
HKD Identity (m (ExtLedgerState blk ValuesMK))
lgrGenesis
        sr <- createAndPopulateStateRefFromGenesis v2Tracer res genesis
        pure $ LedgerSeq . AS.Empty $ sr
    , initFromSnapshot :: DiskSnapshot
-> m (Either
        (SnapshotFailure blk)
        (LedgerSeq m (ExtLedgerState blk), RealPoint blk))
initFromSnapshot = \DiskSnapshot
ds ->
        ExceptT
  (SnapshotFailure blk)
  m
  (LedgerSeq m (ExtLedgerState blk), RealPoint blk)
-> m (Either
        (SnapshotFailure blk)
        (LedgerSeq m (ExtLedgerState blk), RealPoint blk))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
          ( (StateRef m (ExtLedgerState blk)
 -> LedgerSeq m (ExtLedgerState blk))
-> (StateRef m (ExtLedgerState blk), RealPoint blk)
-> (LedgerSeq m (ExtLedgerState blk), RealPoint blk)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: MapKind) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (AnchoredSeq
  (WithOrigin SlotNo)
  (StateRef m (ExtLedgerState blk))
  (StateRef m (ExtLedgerState blk))
-> LedgerSeq m (ExtLedgerState blk)
forall (m :: * -> *) (l :: LedgerStateKind).
AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
LedgerSeq (AnchoredSeq
   (WithOrigin SlotNo)
   (StateRef m (ExtLedgerState blk))
   (StateRef m (ExtLedgerState blk))
 -> LedgerSeq m (ExtLedgerState blk))
-> (StateRef m (ExtLedgerState blk)
    -> AnchoredSeq
         (WithOrigin SlotNo)
         (StateRef m (ExtLedgerState blk))
         (StateRef m (ExtLedgerState blk)))
-> StateRef m (ExtLedgerState blk)
-> LedgerSeq m (ExtLedgerState blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef m (ExtLedgerState blk)
-> AnchoredSeq
     (WithOrigin SlotNo)
     (StateRef m (ExtLedgerState blk))
     (StateRef m (ExtLedgerState blk))
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AS.Empty)
              ((StateRef m (ExtLedgerState blk), RealPoint blk)
 -> (LedgerSeq m (ExtLedgerState blk), RealPoint blk))
-> ExceptT
     (SnapshotFailure blk)
     m
     (StateRef m (ExtLedgerState blk), RealPoint blk)
-> ExceptT
     (SnapshotFailure blk)
     m
     (LedgerSeq m (ExtLedgerState blk), RealPoint blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer m LedgerDBV2Trace
-> CodecConfig blk
-> SomeHasFS m
-> Resources m backend
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     (StateRef m (ExtLedgerState blk), RealPoint blk)
forall (m :: * -> *) backend blk.
Backend m backend blk =>
Tracer m LedgerDBV2Trace
-> CodecConfig blk
-> SomeHasFS m
-> Resources m backend
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     (StateRef m (ExtLedgerState blk), RealPoint blk)
openStateRefFromSnapshot
                Tracer m LedgerDBV2Trace
v2Tracer
                (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
                Resources m backend
res
                DiskSnapshot
ds
          )
    , initReapplyBlock :: LedgerDbCfg (ExtLedgerState blk)
-> blk
-> LedgerSeq m (ExtLedgerState blk)
-> m (LedgerSeq m (ExtLedgerState blk))
initReapplyBlock = LedgerDbCfg (ExtLedgerState blk)
-> blk
-> LedgerSeq m (ExtLedgerState blk)
-> m (LedgerSeq m (ExtLedgerState blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, ApplyBlock l blk) =>
LedgerDbCfg l -> blk -> LedgerSeq m l -> m (LedgerSeq m l)
reapplyThenPush
    , currentTip :: LedgerSeq m (ExtLedgerState blk) -> LedgerState blk EmptyMK
currentTip = ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState (ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK)
-> (LedgerSeq m (ExtLedgerState blk) -> ExtLedgerState blk EmptyMK)
-> LedgerSeq m (ExtLedgerState blk)
-> LedgerState blk EmptyMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m (ExtLedgerState blk) -> ExtLedgerState blk EmptyMK
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> l EmptyMK
current
    , mkLedgerDb :: LedgerSeq m (ExtLedgerState blk)
-> m (LedgerDB m (ExtLedgerState blk) blk,
      TestInternals m (ExtLedgerState blk) blk)
mkLedgerDb = \LedgerSeq m (ExtLedgerState blk)
lseq -> do
        varDB <- LedgerSeq m (ExtLedgerState blk)
-> m (StrictTVar m (LedgerSeq m (ExtLedgerState blk)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO LedgerSeq m (ExtLedgerState blk)
lseq
        prevApplied <- newTVarIO Set.empty
        lock <- RAWLock.new ()
        nextForkerKey <- newTVarIO (ForkerKey 0)
        let env =
              LedgerDBEnv
                { ldbSeq :: StrictTVar m (LedgerSeq m (ExtLedgerState blk))
ldbSeq = StrictTVar m (LedgerSeq m (ExtLedgerState blk))
varDB
                , ldbPrevApplied :: StrictTVar m (Set (RealPoint blk))
ldbPrevApplied = StrictTVar m (Set (RealPoint blk))
prevApplied
                , 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)
tr
                , ldbCfg :: LedgerDbCfg (ExtLedgerState blk)
ldbCfg = LedgerDbCfg (ExtLedgerState blk)
lgrConfig
                , ldbHasFS :: SomeHasFS m
ldbHasFS = SomeHasFS m
HKD Identity (SomeHasFS m)
lgrHasFS
                , ldbResolveBlock :: ResolveBlock m blk
ldbResolveBlock = ResolveBlock m blk
getBlock
                , ldbQueryBatchSize :: QueryBatchSize
ldbQueryBatchSize = QueryBatchSize
lgrQueryBatchSize
                , ldbOpenHandlesLock :: RAWLock m ()
ldbOpenHandlesLock = RAWLock m ()
lock
                , ldbGetVolatileSuffix :: GetVolatileSuffix m blk
ldbGetVolatileSuffix = GetVolatileSuffix m blk
getVolatileSuffix
                , ldbBackendResources :: SomeResources m blk
ldbBackendResources = Resources m backend -> SomeResources m blk
forall (m :: * -> *) backend blk.
Backend m backend blk =>
Resources m backend -> SomeResources m blk
SomeResources Resources m backend
res
                }
        h <- LDBHandle <$> newTVarIO (LedgerDBOpen env)
        pure $ implMkLedgerDb h snapManager
    }
 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
    , QueryBatchSize
lgrQueryBatchSize :: QueryBatchSize
lgrQueryBatchSize :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> QueryBatchSize
lgrQueryBatchSize
    } = Complete LedgerDbArgs m blk
args

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

  !tr :: Tracer m (TraceEvent blk)
tr = Complete LedgerDbArgs m blk -> Tracer m (TraceEvent blk)
forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> Tracer m (TraceEvent blk)
lgrTracer Complete LedgerDbArgs m blk
args

implMkLedgerDb ::
  forall m l blk.
  ( IOLike m
  , HasCallStack
  , StandardHash l
  , LedgerSupportsProtocol blk
  , HasHardForkHistory blk
  , ApplyBlock l blk
  ) =>
  LedgerDBHandle m l blk ->
  SnapshotManager m m blk (StateRef m l) ->
  (LedgerDB m l blk, TestInternals m l blk)
implMkLedgerDb :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasCallStack, StandardHash l,
 LedgerSupportsProtocol blk, HasHardForkHistory blk,
 ApplyBlock l blk) =>
LedgerDBHandle m l blk
-> SnapshotManager m m blk (StateRef m l)
-> (LedgerDB m l blk, TestInternals m l blk)
implMkLedgerDb LedgerDBHandle m l blk
h SnapshotManager m m blk (StateRef m l)
snapManager =
  let ldb :: LedgerDB m l blk
ldb =
        LedgerDB
          { getVolatileTip :: STM m (l EmptyMK)
getVolatileTip = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m (l EmptyMK)) -> STM m (l EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
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)
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 (l EmptyMK)) -> STM m (l EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
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)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l) =>
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 (l EmptyMK)))
-> STM m (Maybe (l EmptyMK))
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
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 (l EmptyMK)))
-> Point blk -> LedgerDBEnv m l blk -> STM m (Maybe (l EmptyMK))
forall a b c. (a -> b -> c) -> b -> a -> c
flip LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l 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) =>
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
          , openForkerAtTarget :: Target (Point blk) -> m (Either GetForkerError (Forker m l))
openForkerAtTarget = LedgerDBHandle m l blk
-> Target (Point blk) -> m (Either GetForkerError (Forker m l))
forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 HasLedgerTables l, LedgerSupportsProtocol blk, StandardHash l) =>
LedgerDBHandle m l blk
-> Target (Point blk) -> m (Either GetForkerError (Forker m l))
openNewForkerAtTarget LedgerDBHandle m l blk
h
          , validateFork :: (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> NonEmpty (Header blk)
-> SuccessForkerAction m l
-> m (ValidateResult l blk)
validateFork = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk
    -> (TraceValidateEvent blk -> m ())
    -> BlockCache blk
    -> Word64
    -> NonEmpty (Header blk)
    -> SuccessForkerAction m l
    -> m (ValidateResult l blk))
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> NonEmpty (Header blk)
-> SuccessForkerAction m l
-> m (ValidateResult l blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk a b c d e r.
(IOLike m, HasCallStack) =>
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
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> NonEmpty (Header blk)
-> SuccessForkerAction m l
-> m (ValidateResult l blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasCallStack, ApplyBlock l blk, StandardHash l,
 LedgerSupportsProtocol blk) =>
LedgerDBHandle m l blk
-> LedgerDBEnv m l blk
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> NonEmpty (Header blk)
-> SuccessForkerAction m l
-> m (ValidateResult l 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) =>
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 -> m ()
garbageCollect = \SlotNo
s -> LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m ()) -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m l blk
h ((LedgerDBEnv m l blk -> SlotNo -> m ())
-> SlotNo -> LedgerDBEnv m l blk -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LedgerDBEnv m l blk -> SlotNo -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, GetTip l) =>
LedgerDBEnv m l blk -> SlotNo -> m ()
implGarbageCollect SlotNo
s)
          , tryTakeSnapshot :: m () -> Maybe (Time, Time) -> Word64 -> m SnapCounters
tryTakeSnapshot = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk
    -> m () -> Maybe (Time, Time) -> Word64 -> m SnapCounters)
-> m ()
-> Maybe (Time, Time)
-> Word64
-> m SnapCounters
forall (m :: * -> *) (l :: LedgerStateKind) blk a b c r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> b -> c -> m r)
-> a
-> b
-> c
-> m r
getEnv3 LedgerDBHandle m l blk
h (SnapshotManager m m blk (StateRef m l)
-> LedgerDBEnv m l blk
-> m ()
-> Maybe (Time, Time)
-> Word64
-> m SnapCounters
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, GetTip l) =>
SnapshotManager m m blk (StateRef m l)
-> LedgerDBEnv m l blk
-> m ()
-> Maybe (Time, Time)
-> Word64
-> m SnapCounters
implTryTakeSnapshot SnapshotManager m m blk (StateRef m l)
snapManager)
          , tryFlush :: m ()
tryFlush = LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m ()) -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
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
          }
   in (LedgerDB m l blk
ldb, LedgerDB m l blk
-> LedgerDBHandle m l blk
-> SnapshotManager m m blk (StateRef m l)
-> TestInternals m l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, ApplyBlock l blk) =>
LedgerDB m l blk
-> LedgerDBHandle m l blk
-> SnapshotManager m m blk (StateRef m l)
-> TestInternals m l blk
mkInternals LedgerDB m l blk
ldb LedgerDBHandle m l blk
h SnapshotManager m m blk (StateRef m l)
snapManager)

mkInternals ::
  forall m l blk.
  ( IOLike m
  , ApplyBlock l blk
  ) =>
  LedgerDB m l blk ->
  LedgerDBHandle m l blk ->
  SnapshotManager m m blk (StateRef m l) ->
  TestInternals m l blk
mkInternals :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, ApplyBlock l blk) =>
LedgerDB m l blk
-> LedgerDBHandle m l blk
-> SnapshotManager m m blk (StateRef m l)
-> TestInternals m l blk
mkInternals LedgerDB m l blk
ldb LedgerDBHandle m l blk
h SnapshotManager m m blk (StateRef m l)
snapManager =
  TestInternals
    { takeSnapshotNOW :: WhereToTakeSnapshot -> Maybe String -> m ()
takeSnapshotNOW = \WhereToTakeSnapshot
whereTo Maybe String
suff -> LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m ()) -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m l blk
h ((LedgerDBEnv m l blk -> m ()) -> m ())
-> (LedgerDBEnv m l blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \LedgerDBEnv m l blk
env -> do
        let selectWhereTo :: LedgerSeq m l -> StateRef m l
selectWhereTo = case WhereToTakeSnapshot
whereTo of
              WhereToTakeSnapshot
TakeAtImmutableTip -> LedgerSeq m l -> StateRef m l
forall (m :: * -> *) (l :: LedgerStateKind).
LedgerSeq m l -> StateRef m l
anchorHandle
              WhereToTakeSnapshot
TakeAtVolatileTip -> LedgerSeq m l -> StateRef m l
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> StateRef m l
currentHandle
        LedgerDBEnv m l blk
-> (LedgerSeq m l -> Solo (StateRef m l))
-> (Solo (StateRef m l) -> m ())
-> m ()
forall (m :: * -> *) (t :: * -> *) (l :: LedgerStateKind) blk a.
(IOLike m, Traversable t, GetTip l) =>
LedgerDBEnv m l blk
-> (LedgerSeq m l -> t (StateRef m l))
-> (t (StateRef m l) -> m a)
-> m a
withStateRef LedgerDBEnv m l blk
env (StateRef m l -> Solo (StateRef m l)
forall a. a -> Solo a
MkSolo (StateRef m l -> Solo (StateRef m l))
-> (LedgerSeq m l -> StateRef m l)
-> LedgerSeq m l
-> Solo (StateRef m l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m l -> StateRef m l
selectWhereTo) ((Solo (StateRef m l) -> m ()) -> m ())
-> (Solo (StateRef m l) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(MkSolo StateRef m l
st) ->
          m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Monad.void (m (Maybe (DiskSnapshot, RealPoint blk)) -> m ())
-> m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall a b. (a -> b) -> a -> b
$
            SnapshotManager m m blk (StateRef m l)
-> Maybe String
-> StateRef m l
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) (n :: * -> *) blk st.
SnapshotManager m n blk st
-> Maybe String -> st -> n (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot
              SnapshotManager m m blk (StateRef m l)
snapManager
              Maybe String
suff
              StateRef m l
st
    , wipeLedgerDB :: m ()
wipeLedgerDB = SnapshotManager m m blk (StateRef m l) -> m ()
forall (m :: * -> *) (n :: * -> *) blk st.
Monad m =>
SnapshotManager m n blk st -> m ()
destroySnapshots SnapshotManager m m blk (StateRef m l)
snapManager
    , truncateSnapshots :: m ()
truncateSnapshots = LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m ()) -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m l blk
h ((LedgerDBEnv m l blk -> m ()) -> m ())
-> (LedgerDBEnv m l blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ SnapshotManager m m blk (StateRef m l) -> SomeHasFS m -> m ()
forall (m :: * -> *) blk st.
MonadThrow m =>
SnapshotManager m m blk st -> SomeHasFS m -> m ()
implIntTruncateSnapshots SnapshotManager m m blk (StateRef m l)
snapManager (SomeHasFS m -> m ())
-> (LedgerDBEnv m l blk -> SomeHasFS m)
-> LedgerDBEnv m l blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBEnv m l blk -> SomeHasFS m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SomeHasFS m
ldbHasFS
    , push :: l DiffMK -> m ()
push = \l DiffMK
st -> do
        LedgerDB m l blk -> (Forker m l -> m ()) -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk a.
IOLike m =>
LedgerDB m l blk -> (Forker m l -> m a) -> m a
withTipForker
          LedgerDB m l blk
ldb
          ( \Forker m l
frk -> do
              Forker m l -> l DiffMK -> m ()
forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l -> l DiffMK -> m ()
forkerPush Forker m l
frk l 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
>> m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
Monad.join (STM m (m ()) -> m (m ())
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Forker m l -> STM m (m ())
forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l -> STM m (m ())
forkerCommit Forker m l
frk))
              LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m ()) -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m l blk
h LedgerDBEnv m l blk -> m ()
pruneLedgerSeq
          )
    , reapplyThenPushNOW :: blk -> m ()
reapplyThenPushNOW = \blk
blk -> LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m ()) -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m l blk
h ((LedgerDBEnv m l blk -> m ()) -> m ())
-> (LedgerDBEnv m l blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \LedgerDBEnv m l blk
env -> do
        LedgerDB m l blk -> (Forker m l -> m ()) -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk a.
IOLike m =>
LedgerDB m l blk -> (Forker m l -> m a) -> m a
withTipForker
          LedgerDB m l blk
ldb
          ( \Forker m l
frk -> do
              st <- STM m (l EmptyMK) -> m (l EmptyMK)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (l EmptyMK) -> m (l EmptyMK))
-> STM m (l EmptyMK) -> m (l EmptyMK)
forall a b. (a -> b) -> a -> b
$ Forker m l -> STM m (l EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l -> STM m (l EmptyMK)
forkerGetLedgerState Forker m l
frk
              tables <- forkerReadTables frk (getBlockKeySets blk)
              let st' =
                    ComputeLedgerEvents -> LedgerCfg l -> blk -> l ValuesMK -> l DiffMK
forall (l :: LedgerStateKind) blk.
ApplyBlock l blk =>
ComputeLedgerEvents -> LedgerCfg l -> blk -> l ValuesMK -> l DiffMK
tickThenReapply
                      (LedgerDbCfgF Identity l -> ComputeLedgerEvents
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> ComputeLedgerEvents
ledgerDbCfgComputeLedgerEvents (LedgerDBEnv m l blk -> LedgerDbCfgF Identity l
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l
ldbCfg LedgerDBEnv m l blk
env))
                      (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)
                      blk
blk
                      (l EmptyMK
st l EmptyMK -> LedgerTables l ValuesMK -> l ValuesMK
forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l 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 l ValuesMK
tables)
              forkerPush frk st' >> Monad.join (atomically (forkerCommit frk))
              pruneLedgerSeq env
          )
    , closeLedgerDB :: m ()
closeLedgerDB = LedgerDBHandle m l blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDBHandle m l blk -> m ()
implCloseDB LedgerDBHandle m l blk
h
    , getNumLedgerTablesHandles :: m Word64
getNumLedgerTablesHandles = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> m Word64) -> m Word64
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m l blk
h ((LedgerDBEnv m l blk -> m Word64) -> m Word64)
-> (LedgerDBEnv m l blk -> m Word64) -> m Word64
forall a b. (a -> b) -> a -> b
$ \LedgerDBEnv m l blk
env -> 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
env)
        -- We always have a state at the anchor.
        pure $ 1 + maxRollback l
    }
 where
  pruneLedgerSeq :: LedgerDBEnv m l blk -> m ()
  pruneLedgerSeq :: LedgerDBEnv m l blk -> m ()
pruneLedgerSeq LedgerDBEnv m l blk
env =
    m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
Monad.join (m (m ()) -> m ()) -> m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ STM m (m ()) -> m (m ())
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (m ()) -> m (m ())) -> STM m (m ()) -> m (m ())
forall a b. (a -> b) -> a -> b
$ StrictTVar m (LedgerSeq m l)
-> (LedgerSeq m l -> (m (), LedgerSeq m l)) -> STM m (m ())
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar (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) ((LedgerSeq m l -> (m (), LedgerSeq m l)) -> STM m (m ()))
-> (LedgerSeq m l -> (m (), LedgerSeq m l)) -> STM m (m ())
forall a b. (a -> b) -> a -> b
$ LedgerSeq m l -> (m (), LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind).
(Monad m, GetTip l) =>
LedgerSeq m l -> (m (), LedgerSeq m l)
pruneToImmTipOnly

-- | Testing only! Truncate all snapshots in the DB. We only truncate the state
-- file because it is unclear how to truncate the LSM database without
-- corrupting it.
implIntTruncateSnapshots :: MonadThrow m => SnapshotManager m m blk st -> SomeHasFS m -> m ()
implIntTruncateSnapshots :: forall (m :: * -> *) blk st.
MonadThrow m =>
SnapshotManager m m blk st -> SomeHasFS m -> m ()
implIntTruncateSnapshots SnapshotManager m m blk st
snapManager (SomeHasFS HasFS m h
fs) = do
  SnapshotManager m m blk st -> (DiskSnapshot -> m ()) -> m ()
forall (m :: * -> *) (n :: * -> *) blk st a.
Monad m =>
SnapshotManager m n blk st -> (DiskSnapshot -> m a) -> m ()
snapshotsMapM_ SnapshotManager m m blk st
snapManager ((DiskSnapshot -> m ()) -> m ()) -> (DiskSnapshot -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
    \DiskSnapshot
pre -> HasFS m h -> FsPath -> OpenMode -> (Handle h -> m ()) -> m ()
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
fs (DiskSnapshot -> FsPath
snapshotToStatePath DiskSnapshot
pre) (AllowExisting -> OpenMode
AppendMode AllowExisting
AllowExisting) ((Handle h -> m ()) -> m ()) -> (Handle h -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
      \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

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
. LedgerDBEnv m l blk -> STM m (LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l) =>
LedgerDBEnv m l blk -> STM m (LedgerSeq m l)
getVolatileLedgerSeq

implGetImmutableTip ::
  (MonadSTM m, GetTip l) =>
  LedgerDBEnv m l blk ->
  STM m (l EmptyMK)
implGetImmutableTip :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l) =>
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
. LedgerDBEnv m l blk -> STM m (LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l) =>
LedgerDBEnv m l blk -> STM m (LedgerSeq m l)
getVolatileLedgerSeq

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
<$> LedgerDBEnv m l blk -> STM m (LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l) =>
LedgerDBEnv m l blk -> STM m (LedgerSeq m l)
getVolatileLedgerSeq 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 <- LedgerDBEnv m l blk -> STM m (LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l) =>
LedgerDBEnv m l blk -> STM m (LedgerSeq m l)
getVolatileLedgerSeq 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
  , HasCallStack
  , ApplyBlock l blk
  , StandardHash l
  , LedgerSupportsProtocol blk
  ) =>
  LedgerDBHandle m l blk ->
  LedgerDBEnv m l blk ->
  (TraceValidateEvent blk -> m ()) ->
  BlockCache blk ->
  Word64 ->
  NonEmpty (Header blk) ->
  SuccessForkerAction m l ->
  m (ValidateResult l blk)
implValidate :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasCallStack, ApplyBlock l blk, StandardHash l,
 LedgerSupportsProtocol blk) =>
LedgerDBHandle m l blk
-> LedgerDBEnv m l blk
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> NonEmpty (Header blk)
-> SuccessForkerAction m l
-> m (ValidateResult l blk)
implValidate LedgerDBHandle m l blk
h LedgerDBEnv m l blk
ldbEnv TraceValidateEvent blk -> m ()
tr BlockCache blk
cache Word64
rollbacks NonEmpty (Header blk)
hdrs SuccessForkerAction m l
onSuccess =
  ComputeLedgerEvents
-> ValidateArgs m l blk -> m (ValidateResult l blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasCallStack, ApplyBlock l blk) =>
ComputeLedgerEvents
-> ValidateArgs m l blk -> m (ValidateResult l 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 l blk -> m (ValidateResult l blk))
-> ValidateArgs m l blk -> m (ValidateResult l blk)
forall a b. (a -> b) -> a -> b
$
    ResolveBlock m blk
-> LedgerCfg l
-> ([RealPoint blk] -> STM m ())
-> STM m (Set (RealPoint blk))
-> (forall r.
    Word64 -> (Forker m l -> m r) -> m (Either GetForkerError r))
-> SuccessForkerAction m l
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> NonEmpty (Header blk)
-> ValidateArgs m l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ResolveBlock m blk
-> LedgerCfg l
-> ([RealPoint blk] -> STM m ())
-> STM m (Set (RealPoint blk))
-> (forall r.
    Word64 -> (Forker m l -> m r) -> m (Either GetForkerError r))
-> SuccessForkerAction m l
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> NonEmpty (Header blk)
-> ValidateArgs m l 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)
      (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
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 l blk
-> Word64 -> (Forker m l -> m r) -> m (Either GetForkerError r)
forall (l :: LedgerStateKind) blk (m :: * -> *) r.
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBHandle m l blk
-> Word64 -> (Forker m l -> m r) -> m (Either GetForkerError r)
withForkerByRollback LedgerDBHandle m l blk
h)
      SuccessForkerAction m l
onSuccess
      TraceValidateEvent blk -> m ()
tr
      BlockCache blk
cache
      Word64
rollbacks
      NonEmpty (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 'LedgerSeq' states older than the given slot, and all points with a
-- slot older than the given slot from the set of previously applied points.
implGarbageCollect :: (IOLike m, GetTip l) => LedgerDBEnv m l blk -> SlotNo -> m ()
implGarbageCollect :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, GetTip l) =>
LedgerDBEnv m l blk -> SlotNo -> m ()
implGarbageCollect LedgerDBEnv m l blk
env SlotNo
slotNo = do
  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 (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)
  m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
Monad.join (m (m ()) -> m ()) -> m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ RAWLock m () -> (() -> m (m (), ())) -> m (m ())
forall (m :: * -> *) st a.
(MonadSTM m, MonadCatch m, MonadThrow (STM m)) =>
RAWLock m st -> (st -> m (a, st)) -> m a
RAWLock.withWriteAccess (LedgerDBEnv m l blk -> RAWLock m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> RAWLock m ()
ldbOpenHandlesLock LedgerDBEnv m l blk
env) ((() -> m (m (), ())) -> m (m ()))
-> (() -> m (m (), ())) -> m (m ())
forall a b. (a -> b) -> a -> b
$ \() -> do
    close <- STM m (m ()) -> m (m ())
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (m ()) -> m (m ())) -> STM m (m ()) -> m (m ())
forall a b. (a -> b) -> a -> b
$ StrictTVar m (LedgerSeq m l)
-> (LedgerSeq m l -> (m (), LedgerSeq m l)) -> STM m (m ())
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar (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) ((LedgerSeq m l -> (m (), LedgerSeq m l)) -> STM m (m ()))
-> (LedgerSeq m l -> (m (), LedgerSeq m l)) -> STM m (m ())
forall a b. (a -> b) -> a -> b
$ LedgerDbPrune -> LedgerSeq m l -> (m (), LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind).
(Monad m, GetTip l) =>
LedgerDbPrune -> LedgerSeq m l -> (m (), LedgerSeq m l)
prune (SlotNo -> LedgerDbPrune
LedgerDbPruneBeforeSlot SlotNo
slotNo)
    pure (close, ())

implTryTakeSnapshot ::
  forall m l blk.
  ( IOLike m
  , GetTip l
  ) =>
  SnapshotManager m m blk (StateRef m l) ->
  LedgerDBEnv m l blk ->
  m () ->
  Maybe (Time, Time) ->
  Word64 ->
  m SnapCounters
implTryTakeSnapshot :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, GetTip l) =>
SnapshotManager m m blk (StateRef m l)
-> LedgerDBEnv m l blk
-> m ()
-> Maybe (Time, Time)
-> Word64
-> m SnapCounters
implTryTakeSnapshot SnapshotManager m m blk (StateRef m l)
snapManager LedgerDBEnv m l blk
env m ()
copyBlocks 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 ()
copyBlocks
      LedgerDBEnv m l blk
-> (LedgerSeq m l -> Solo (StateRef m l))
-> (Solo (StateRef m l) -> m ())
-> m ()
forall (m :: * -> *) (t :: * -> *) (l :: LedgerStateKind) blk a.
(IOLike m, Traversable t, GetTip l) =>
LedgerDBEnv m l blk
-> (LedgerSeq m l -> t (StateRef m l))
-> (t (StateRef m l) -> m a)
-> m a
withStateRef LedgerDBEnv m l blk
env (StateRef m l -> Solo (StateRef m l)
forall a. a -> Solo a
MkSolo (StateRef m l -> Solo (StateRef m l))
-> (LedgerSeq m l -> StateRef m l)
-> LedgerSeq m l
-> Solo (StateRef m l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m l -> StateRef m l
forall (m :: * -> *) (l :: LedgerStateKind).
LedgerSeq m l -> StateRef m l
anchorHandle) ((Solo (StateRef m l) -> m ()) -> m ())
-> (Solo (StateRef m l) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(MkSolo StateRef m l
st) ->
        m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Monad.void (m (Maybe (DiskSnapshot, RealPoint blk)) -> m ())
-> m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall a b. (a -> b) -> a -> b
$
          SnapshotManager m m blk (StateRef m l)
-> Maybe String
-> StateRef m l
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) (n :: * -> *) blk st.
SnapshotManager m n blk st
-> Maybe String -> st -> n (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot
            SnapshotManager m m blk (StateRef m l)
snapManager
            Maybe String
forall a. Maybe a
Nothing
            StateRef m l
st
      m [DiskSnapshot] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Monad.void (m [DiskSnapshot] -> m ()) -> m [DiskSnapshot] -> m ()
forall a b. (a -> b) -> a -> b
$
        SnapshotManager m m blk (StateRef m l)
-> SnapshotPolicy -> m [DiskSnapshot]
forall (m :: * -> *) (n :: * -> *) blk st.
Monad m =>
SnapshotManager m n blk st -> SnapshotPolicy -> m [DiskSnapshot]
trimSnapshots
          SnapshotManager m m blk (StateRef m l)
snapManager
          (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

-- 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 :: forall m l blk. 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
  res <-
    STM m (Maybe (StrictTVar m (LedgerSeq m l), SomeResources m blk))
-> m (Maybe (StrictTVar m (LedgerSeq m l), SomeResources m blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (StrictTVar m (LedgerSeq m l), SomeResources m blk))
 -> m (Maybe (StrictTVar m (LedgerSeq m l), SomeResources m blk)))
-> STM
     m (Maybe (StrictTVar m (LedgerSeq m l), SomeResources m blk))
-> m (Maybe (StrictTVar m (LedgerSeq m l), SomeResources m 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 (StrictTVar m (LedgerSeq m l), SomeResources m blk)))
-> STM
     m (Maybe (StrictTVar m (LedgerSeq m l), SomeResources m 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 (StrictTVar m (LedgerSeq m l), SomeResources m blk)
-> STM
     m (Maybe (StrictTVar m (LedgerSeq m l), SomeResources m blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (StrictTVar m (LedgerSeq m l), SomeResources m 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 (StrictTVar m (LedgerSeq m l), SomeResources m blk)
-> STM
     m (Maybe (StrictTVar m (LedgerSeq m l), SomeResources m blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((StrictTVar m (LedgerSeq m l), SomeResources m blk)
-> Maybe (StrictTVar m (LedgerSeq m l), SomeResources m blk)
forall a. a -> Maybe a
Just ((StrictTVar m (LedgerSeq m l), SomeResources m blk)
 -> Maybe (StrictTVar m (LedgerSeq m l), SomeResources m blk))
-> (StrictTVar m (LedgerSeq m l), SomeResources m blk)
-> Maybe (StrictTVar m (LedgerSeq m l), SomeResources m blk)
forall a b. (a -> b) -> a -> b
$ (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, LedgerDBEnv m l blk -> SomeResources m blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SomeResources m blk
ldbBackendResources LedgerDBEnv m l blk
env))
  whenJust
    res
    ( \(StrictTVar m (LedgerSeq m l)
s, SomeResources Resources m backend
res') -> do
        s' <- StrictTVar m (LedgerSeq m l) -> m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (LedgerSeq m l)
s
        closeLedgerSeq s'
        releaseResources (Proxy @blk) res'
    )

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

type LedgerDBEnv :: (Type -> Type) -> LedgerStateKind -> Type -> Type
data LedgerDBEnv m l blk = LedgerDBEnv
  { forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l)
ldbSeq :: !(StrictTVar m (LedgerSeq m l))
  -- ^ INVARIANT: the tip of the 'LedgerDB' is always in sync with the tip of
  -- the current chain of the ChainDB.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
ldbPrevApplied :: !(StrictTVar m (Set (RealPoint blk)))
  -- ^ INVARIANT: this set contains only points that are in the
  -- VolatileDB.
  --
  -- INVARIANT: all points on the current chain fragment are in this set.
  --
  -- The VolatileDB might contain invalid blocks, these will not be in
  -- this set.
  --
  -- When a garbage-collection is performed on the VolatileDB, the points
  -- of the blocks eligible for garbage-collection should be removed from
  -- this set.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m ForkerKey
ldbNextForkerKey :: !(StrictTVar m ForkerKey)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotPolicy
ldbSnapshotPolicy :: !SnapshotPolicy
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> Tracer m (TraceEvent blk)
ldbTracer :: !(Tracer m (TraceEvent blk))
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l
ldbCfg :: !(LedgerDbCfg l)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SomeHasFS m
ldbHasFS :: !(SomeHasFS m)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> ResolveBlock m blk
ldbResolveBlock :: !(ResolveBlock m blk)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> QueryBatchSize
ldbQueryBatchSize :: !QueryBatchSize
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> RAWLock m ()
ldbOpenHandlesLock :: !(RAWLock m ())
  -- ^ While holding a read lock (at least), all handles in the 'ldbSeq' are
  -- guaranteed to be open. During this time, the handle can be duplicated and
  -- then be used independently, see 'openStateRef' and 'withStateRef'.
  --
  -- We acquire read access when opening a duplicate of a handle (see
  -- 'openGetStateRef').
  --
  -- We acquire write access when pruning the LedgerDB (see
  -- 'implGarbageCollect') and when closing orphaned handles in Chain selection
  -- (see 'implForkerCommit').
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SomeResources m blk
ldbBackendResources :: !(SomeResources m blk)
  -- ^ Resource keys used in the LSM backend so that the closing function used
  -- in tests can release such resources. These are the resource keys for the
  -- LSM session and the resource key for the BlockIO interface.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> GetVolatileSuffix m blk
ldbGetVolatileSuffix :: !(GetVolatileSuffix m blk)
  }
  deriving (forall x. LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x)
-> (forall x. Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk)
-> Generic (LedgerDBEnv m l blk)
forall x. Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
forall x. LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) (l :: LedgerStateKind) blk x.
Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk x.
LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
$cfrom :: forall (m :: * -> *) (l :: LedgerStateKind) blk x.
LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
from :: forall x. LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
$cto :: forall (m :: * -> *) (l :: LedgerStateKind) blk x.
Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
to :: forall x. Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
Generic

deriving instance
  ( IOLike m
  , LedgerSupportsProtocol blk
  , NoThunks (l EmptyMK)
  , NoThunks (TxIn l)
  , NoThunks (TxOut l)
  , NoThunks (LedgerCfg l)
  , NoThunks (SomeResources m blk)
  ) =>
  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 (SomeResources m blk)
  ) =>
  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) =>
  LedgerDBHandle m l blk ->
  (LedgerDBEnv m l blk -> m r) ->
  m r
getEnv :: forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
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 -> m r
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (LedgerDbError -> m r) -> LedgerDbError -> m r
forall a b. (a -> b) -> a -> b
$ PrettyCallStack -> LedgerDbError
ClosedDBError PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack

-- | Variant 'of 'getEnv' for functions taking two arguments.
getEnv3 ::
  (IOLike m, HasCallStack) =>
  LedgerDBHandle m l blk ->
  (LedgerDBEnv m l blk -> a -> b -> c -> m r) ->
  a ->
  b ->
  c ->
  m r
getEnv3 :: forall (m :: * -> *) (l :: LedgerStateKind) blk a b c r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> b -> c -> m r)
-> a
-> b
-> c
-> m r
getEnv3 LedgerDBHandle m l blk
h LedgerDBEnv m l blk -> a -> b -> c -> m r
f a
a b
b c
c = LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
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 -> m r
f LedgerDBEnv m l blk
env a
a b
b c
c)

-- | Variant 'of 'getEnv' for functions taking five arguments.
getEnv5 ::
  (IOLike m, HasCallStack) =>
  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 :: * -> *) (l :: LedgerStateKind) blk a b c d e r.
(IOLike m, HasCallStack) =>
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) =>
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) =>
  LedgerDBHandle m l blk ->
  (LedgerDBEnv m l blk -> STM m r) ->
  STM m r
getEnvSTM :: forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
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 -> STM m r
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (LedgerDbError -> STM m r) -> LedgerDbError -> STM m r
forall a b. (a -> b) -> a -> b
$ PrettyCallStack -> LedgerDbError
ClosedDBError PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack

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

-- | Take the suffix of the 'ldbSeq' containing the only the volatile states
-- (and the first immutable state at the anchor). The 'LedgerSeq' can contain
-- more than one immutable state if we adopted new blocks, but garbage
-- collection has not yet been run.
getVolatileLedgerSeq ::
  (MonadSTM m, GetTip l) =>
  LedgerDBEnv m l blk -> STM m (LedgerSeq m l)
getVolatileLedgerSeq :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l) =>
LedgerDBEnv m l blk -> STM m (LedgerSeq m l)
getVolatileLedgerSeq LedgerDBEnv m l blk
env = do
  volSuffix <- GetVolatileSuffix m blk
-> forall s.
   Anchorable (WithOrigin SlotNo) s s =>
   STM
     m
     (AnchoredSeq (WithOrigin SlotNo) s s
      -> AnchoredSeq (WithOrigin SlotNo) s s)
forall (m :: * -> *) blk.
GetVolatileSuffix m blk
-> forall s.
   Anchorable (WithOrigin SlotNo) s s =>
   STM
     m
     (AnchoredSeq (WithOrigin SlotNo) s s
      -> AnchoredSeq (WithOrigin SlotNo) s s)
getVolatileSuffix (LedgerDBEnv m l blk -> GetVolatileSuffix m blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> GetVolatileSuffix m blk
ldbGetVolatileSuffix LedgerDBEnv m l blk
env)
  LedgerSeq . volSuffix . getLedgerSeq <$> readTVar (ldbSeq env)

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

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

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

openNewForkerAtTarget ::
  ( HeaderHash l ~ HeaderHash blk
  , IOLike m
  , IsLedger l
  , HasLedgerTables l
  , LedgerSupportsProtocol blk
  , StandardHash l
  ) =>
  LedgerDBHandle m l blk ->
  Target (Point blk) ->
  m (Either GetForkerError (Forker m l))
openNewForkerAtTarget :: forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 HasLedgerTables l, LedgerSupportsProtocol blk, StandardHash l) =>
LedgerDBHandle m l blk
-> Target (Point blk) -> m (Either GetForkerError (Forker m l))
openNewForkerAtTarget LedgerDBHandle m l blk
h Target (Point blk)
pt = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> m (Either GetForkerError (Forker m l)))
-> m (Either GetForkerError (Forker m l))
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
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)))
 -> m (Either GetForkerError (Forker m l)))
-> (LedgerDBEnv m l blk -> m (Either GetForkerError (Forker m l)))
-> m (Either GetForkerError (Forker m l))
forall a b. (a -> b) -> a -> b
$ \LedgerDBEnv m l blk
ldbEnv ->
  LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> m (Either GetForkerError (StateRef m l))
forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, GetTip l, StandardHash l,
 LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> m (Either GetForkerError (StateRef m l))
openStateRefAtTarget 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)))
-> m (Either GetForkerError (Forker m l))
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))
-> Either GetForkerError (StateRef m l)
-> m (Either GetForkerError (Forker m l))
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 (LedgerDBEnv m l blk -> StateRef m l -> m (Forker m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasLedgerTables l, NoThunks (l EmptyMK), GetTip l,
 StandardHash l) =>
LedgerDBEnv m l blk -> StateRef m l -> m (Forker m l)
newForker LedgerDBEnv m l blk
ldbEnv)

withForkerByRollback ::
  ( HeaderHash l ~ HeaderHash blk
  , IOLike m
  , IsLedger l
  , StandardHash l
  , HasLedgerTables l
  , LedgerSupportsProtocol blk
  ) =>
  LedgerDBHandle m l blk ->
  Word64 ->
  (Forker m l -> m r) ->
  m (Either GetForkerError r)
withForkerByRollback :: forall (l :: LedgerStateKind) blk (m :: * -> *) r.
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBHandle m l blk
-> Word64 -> (Forker m l -> m r) -> m (Either GetForkerError r)
withForkerByRollback LedgerDBHandle m l blk
h Word64
n Forker m l -> m r
k = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> m (Either GetForkerError r))
-> m (Either GetForkerError r)
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
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 r))
 -> m (Either GetForkerError r))
-> (LedgerDBEnv m l blk -> m (Either GetForkerError r))
-> m (Either GetForkerError r)
forall a b. (a -> b) -> a -> b
$ \LedgerDBEnv m l blk
ldbEnv ->
  m (Either GetForkerError (Forker m l))
-> (Either GetForkerError (Forker m l) -> m ())
-> (Either GetForkerError (Forker m l)
    -> m (Either GetForkerError r))
-> m (Either GetForkerError r)
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
    (LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> m (Either GetForkerError (StateRef m l))
forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, GetTip l, StandardHash l,
 LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> m (Either GetForkerError (StateRef m l))
openStateRefAtTarget 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)))
-> m (Either GetForkerError (Forker m l))
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))
-> Either GetForkerError (StateRef m l)
-> m (Either GetForkerError (Forker m l))
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 (LedgerDBEnv m l blk -> StateRef m l -> m (Forker m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasLedgerTables l, NoThunks (l EmptyMK), GetTip l,
 StandardHash l) =>
LedgerDBEnv m l blk -> StateRef m l -> m (Forker m l)
newForker LedgerDBEnv m l blk
ldbEnv))
    ((GetForkerError -> m ())
-> (Forker m l -> m ())
-> Either GetForkerError (Forker m l)
-> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m () -> GetForkerError -> m ()
forall a b. a -> b -> a
const (m () -> GetForkerError -> m ()) -> m () -> GetForkerError -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Forker m l -> m ()
forall (m :: * -> *) (l :: LedgerStateKind). Forker m l -> m ()
forkerClose)
    ((GetForkerError -> m (Either GetForkerError r))
-> (Forker m l -> m (Either GetForkerError r))
-> Either GetForkerError (Forker m l)
-> m (Either GetForkerError r)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either GetForkerError r -> m (Either GetForkerError r)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either GetForkerError r -> m (Either GetForkerError r))
-> (GetForkerError -> Either GetForkerError r)
-> GetForkerError
-> m (Either GetForkerError r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GetForkerError -> Either GetForkerError r
forall a b. a -> Either a b
Left) ((r -> Either GetForkerError r)
-> m r -> m (Either GetForkerError r)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r -> Either GetForkerError r
forall a b. b -> Either a b
Right (m r -> m (Either GetForkerError r))
-> (Forker m l -> m r) -> Forker m l -> m (Either GetForkerError r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forker m l -> m r
k))

-- | Will release all handles in the 'foeLedgerSeq', which will be only the
-- first duplicate if the forker has been committed.
implForkerClose ::
  IOLike m =>
  ForkerEnv m l ->
  m ()
implForkerClose :: forall (m :: * -> *) (l :: LedgerStateKind).
IOLike m =>
ForkerEnv m l -> m ()
implForkerClose ForkerEnv m l
env = do
  wasCommitted <- StrictTVar m Bool -> m Bool
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (ForkerEnv m l -> StrictTVar m Bool
forall (m :: * -> *) (l :: LedgerStateKind).
ForkerEnv m l -> StrictTVar m Bool
foeWasCommitted ForkerEnv m l
env)
  if wasCommitted
    then
      traceWith (foeTracer env) (ForkerClose ForkerWasCommitted)
    else
      traceWith (foeTracer env) (ForkerClose ForkerWasUncommitted)
  closeLedgerSeq =<< readTVarIO (foeLedgerSeq env)

newForker ::
  ( IOLike m
  , HasLedgerTables l
  , NoThunks (l EmptyMK)
  , GetTip l
  , StandardHash l
  ) =>
  LedgerDBEnv m l blk ->
  StateRef m l ->
  m (Forker m l)
newForker :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasLedgerTables l, NoThunks (l EmptyMK), GetTip l,
 StandardHash l) =>
LedgerDBEnv m l blk -> StateRef m l -> m (Forker m l)
newForker LedgerDBEnv m l blk
ldbEnv 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
  lseq <- newTVarIO (LedgerSeq . AS.Empty $ st)
  committed <- newTVarIO False
  let forkerEnv =
        ForkerEnv
          { foeLedgerSeq :: StrictTVar m (LedgerSeq m l)
foeLedgerSeq = StrictTVar m (LedgerSeq m l)
lseq
          , 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
          , foeTracer :: Tracer m TraceForkerEvent
foeTracer = Tracer m TraceForkerEvent
tr
          , foeLedgerDbLock :: RAWLock m ()
foeLedgerDbLock = LedgerDBEnv m l blk -> RAWLock m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> RAWLock m ()
ldbOpenHandlesLock LedgerDBEnv m l blk
ldbEnv
          , foeWasCommitted :: StrictTVar m Bool
foeWasCommitted = StrictTVar m Bool
committed
          }
  pure $
    Forker
      { forkerReadTables = implForkerReadTables forkerEnv
      , forkerRangeReadTables = implForkerRangeReadTables (ldbQueryBatchSize ldbEnv) forkerEnv
      , forkerGetLedgerState = implForkerGetLedgerState forkerEnv
      , forkerReadStatistics = implForkerReadStatistics forkerEnv
      , forkerPush = implForkerPush forkerEnv
      , forkerCommit = implForkerCommit forkerEnv
      , forkerClose = implForkerClose forkerEnv
      }