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

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

import qualified Control.Monad as Monad (forM, join, void)
import Control.Monad.Except
import Control.RAWLock
import qualified Control.RAWLock as RAWLock
import Control.Tracer
import Data.Bifunctor (first)
import Data.Containers.ListUtils (nubOrd)
import Data.Foldable (for_)
import qualified Data.Foldable as Foldable
import Data.Functor.Contravariant ((>$<))
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (mapMaybe)
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 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)
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 :: StateKind) blk.
AnchoredSeq
  (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk)
-> LedgerSeq m l blk
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 :: StateKind) blk.
LedgerDbCfgF f l blk -> HKD f (LedgerCfg l blk)
ledgerDbCfg (LedgerDbCfg ExtLedgerState blk -> CodecConfig blk)
-> LedgerDbCfg ExtLedgerState blk -> CodecConfig blk
forall a b. (a -> b) -> a -> b
$ LedgerDbCfg ExtLedgerState blk
lgrConfig)
                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 :: StateKind) blk.
(IOLike m, ApplyBlock l blk) =>
LedgerDbCfg l blk
-> blk -> LedgerSeq m l blk -> m (LedgerSeq m l blk)
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 :: StateKind) blk (m :: * -> *).
GetTip (l blk) =>
LedgerSeq m l blk -> l blk EmptyMK
current
    , mkLedgerDb :: LedgerSeq m ExtLedgerState blk
-> m (LedgerDB' m blk, TestInternals' m 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)
        ldbLastSuccessfulSnapshotRequestedAt <- newTVarIO Nothing
        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 :: StateKind) blk.
LedgerDbCfgF f l blk -> 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
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
                , ldbLastSuccessfulSnapshotRequestedAt :: StrictTVar m (Maybe Time)
ldbLastSuccessfulSnapshotRequestedAt = StrictTVar m (Maybe Time)
ldbLastSuccessfulSnapshotRequestedAt
                }
        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 blk)
  , LedgerSupportsProtocol blk
  , HasHardForkHistory blk
  , ApplyBlock l blk
  ) =>
  LedgerDBHandle m l blk ->
  SnapshotManager m blk (StateRef m l blk) ->
  (LedgerDB m l blk, TestInternals m l blk)
implMkLedgerDb :: forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, HasCallStack, StandardHash (l blk),
 LedgerSupportsProtocol blk, HasHardForkHistory blk,
 ApplyBlock l blk) =>
LedgerDBHandle m l blk
-> SnapshotManager m blk (StateRef m l blk)
-> (LedgerDB m l blk, TestInternals m l blk)
implMkLedgerDb LedgerDBHandle m l blk
h SnapshotManager m blk (StateRef m l blk)
snapManager =
  let ldb :: LedgerDB m l blk
ldb =
        LedgerDB
          { getVolatileTip :: STM m (l blk EmptyMK)
getVolatileTip = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m (l blk EmptyMK))
-> STM m (l blk EmptyMK)
forall (m :: * -> *) (l :: StateKind) 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 blk EmptyMK)
forall (m :: * -> *) (l :: StateKind) blk.
(MonadSTM m, GetTip (l blk)) =>
LedgerDBEnv m l blk -> STM m (l blk EmptyMK)
implGetVolatileTip
          , getImmutableTip :: STM m (l blk EmptyMK)
getImmutableTip = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m (l blk EmptyMK))
-> STM m (l blk EmptyMK)
forall (m :: * -> *) (l :: StateKind) 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 blk EmptyMK)
forall (m :: * -> *) (l :: StateKind) blk.
(MonadSTM m, GetTip (l blk)) =>
LedgerDBEnv m l blk -> STM m (l blk EmptyMK)
implGetImmutableTip
          , getPastLedgerState :: Point blk -> STM m (Maybe (l blk EmptyMK))
getPastLedgerState = \Point blk
s -> LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m (Maybe (l blk EmptyMK)))
-> STM m (Maybe (l blk EmptyMK))
forall (m :: * -> *) (l :: StateKind) 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 blk EmptyMK)))
-> Point blk
-> LedgerDBEnv m l blk
-> STM m (Maybe (l blk EmptyMK))
forall a b c. (a -> b -> c) -> b -> a -> c
flip LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l blk EmptyMK))
forall (m :: * -> *) blk (l :: StateKind).
(MonadSTM m, HasHeader blk, IsLedger l blk, StandardHash (l blk),
 HeaderHash (l blk) ~ HeaderHash blk) =>
LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l blk EmptyMK))
implGetPastLedgerState Point blk
s)
          , getHeaderStateHistory :: (l ~ ExtLedgerState) => STM m (HeaderStateHistory blk)
getHeaderStateHistory = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> STM m (HeaderStateHistory blk))
-> STM m (HeaderStateHistory blk)
forall (m :: * -> *) (l :: StateKind) 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)
LedgerDBEnv m ExtLedgerState blk -> STM m (HeaderStateHistory blk)
forall (m :: * -> *) blk.
(MonadSTM m, IsLedger LedgerState blk, HasHardForkHistory blk,
 HasAnnTip blk) =>
LedgerDBEnv m ExtLedgerState blk -> STM m (HeaderStateHistory blk)
implGetHeaderStateHistory
          , openForkerAtTarget :: Target (Point blk) -> m (Either GetForkerError (Forker m l blk))
openForkerAtTarget = LedgerDBHandle m l blk
-> Target (Point blk) -> m (Either GetForkerError (Forker m l blk))
forall (l :: StateKind) blk (m :: * -> *).
(HeaderHash (l blk) ~ HeaderHash blk, IOLike m, IsLedger l blk,
 HasLedgerTables l blk, LedgerSupportsProtocol blk,
 StandardHash (l blk)) =>
LedgerDBHandle m l blk
-> Target (Point blk) -> m (Either GetForkerError (Forker m l blk))
openNewForkerAtTarget LedgerDBHandle m l blk
h
          , validateFork :: (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> NonEmpty (Header blk)
-> SuccessForkerAction m l blk
-> 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 blk
    -> m (ValidateResult l blk))
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> NonEmpty (Header blk)
-> SuccessForkerAction m l blk
-> m (ValidateResult l blk)
forall (m :: * -> *) (l :: StateKind) 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 blk
-> m (ValidateResult l blk)
forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, HasCallStack, ApplyBlock l blk, StandardHash (l blk),
 LedgerSupportsProtocol blk) =>
LedgerDBHandle m l blk
-> LedgerDBEnv m l blk
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> NonEmpty (Header blk)
-> SuccessForkerAction m l blk
-> 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 :: StateKind) 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 :: StateKind) 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 :: StateKind) 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 :: StateKind) blk.
(IOLike m, GetTip (l blk)) =>
LedgerDBEnv m l blk -> SlotNo -> m ()
implGarbageCollect SlotNo
s)
          , tryTakeSnapshot :: m () -> (SnapshotDelayRange -> m DiffTime) -> m ()
tryTakeSnapshot = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk
    -> m () -> (SnapshotDelayRange -> m DiffTime) -> m ())
-> m ()
-> (SnapshotDelayRange -> m DiffTime)
-> m ()
forall (m :: * -> *) (l :: StateKind) blk a b r.
IOLike m =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> b -> m r) -> a -> b -> m r
getEnv2 LedgerDBHandle m l blk
h (SnapshotManager m blk (StateRef m l blk)
-> LedgerDBEnv m l blk
-> m ()
-> (SnapshotDelayRange -> m DiffTime)
-> m ()
forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, GetTip (l blk)) =>
SnapshotManager m blk (StateRef m l blk)
-> LedgerDBEnv m l blk
-> m ()
-> (SnapshotDelayRange -> m DiffTime)
-> m ()
implTryTakeSnapshot SnapshotManager m blk (StateRef m l blk)
snapManager)
          , closeDB :: m ()
closeDB = LedgerDBHandle m l blk -> m ()
forall (m :: * -> *) (l :: StateKind) 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 blk (StateRef m l blk)
-> TestInternals m l blk
forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, ApplyBlock l blk) =>
LedgerDB m l blk
-> LedgerDBHandle m l blk
-> SnapshotManager m blk (StateRef m l blk)
-> TestInternals m l blk
mkInternals LedgerDB m l blk
ldb LedgerDBHandle m l blk
h SnapshotManager m blk (StateRef m l blk)
snapManager)

mkInternals ::
  forall m l blk.
  ( IOLike m
  , ApplyBlock l blk
  ) =>
  LedgerDB m l blk ->
  LedgerDBHandle m l blk ->
  SnapshotManager m blk (StateRef m l blk) ->
  TestInternals m l blk
mkInternals :: forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, ApplyBlock l blk) =>
LedgerDB m l blk
-> LedgerDBHandle m l blk
-> SnapshotManager m blk (StateRef m l blk)
-> TestInternals m l blk
mkInternals LedgerDB m l blk
ldb LedgerDBHandle m l blk
h SnapshotManager m blk (StateRef m l blk)
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 :: StateKind) 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 blk -> StateRef m l blk
selectWhereTo = case WhereToTakeSnapshot
whereTo of
              WhereToTakeSnapshot
TakeAtImmutableTip -> LedgerSeq m l blk -> StateRef m l blk
forall (m :: * -> *) (l :: StateKind) blk.
LedgerSeq m l blk -> StateRef m l blk
anchorHandle
              WhereToTakeSnapshot
TakeAtVolatileTip -> LedgerSeq m l blk -> StateRef m l blk
forall (l :: StateKind) blk (m :: * -> *).
GetTip (l blk) =>
LedgerSeq m l blk -> StateRef m l blk
currentHandle
        LedgerDBEnv m l blk
-> (LedgerSeq m l blk -> Solo (StateRef m l blk))
-> (Solo (StateRef m l blk) -> m ())
-> m ()
forall (m :: * -> *) (t :: * -> *) (l :: StateKind) blk a.
(IOLike m, Traversable t, GetTip (l blk)) =>
LedgerDBEnv m l blk
-> (LedgerSeq m l blk -> t (StateRef m l blk))
-> (t (StateRef m l blk) -> m a)
-> m a
withStateRef LedgerDBEnv m l blk
env (StateRef m l blk -> Solo (StateRef m l blk)
forall a. a -> Solo a
MkSolo (StateRef m l blk -> Solo (StateRef m l blk))
-> (LedgerSeq m l blk -> StateRef m l blk)
-> LedgerSeq m l blk
-> Solo (StateRef m l blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m l blk -> StateRef m l blk
forall {m :: * -> *}. LedgerSeq m l blk -> StateRef m l blk
selectWhereTo) ((Solo (StateRef m l blk) -> m ()) -> m ())
-> (Solo (StateRef m l blk) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(MkSolo StateRef m l blk
st) ->
          m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Monad.void (m (Maybe (DiskSnapshot, RealPoint blk)) -> m ())
-> m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall a b. (a -> b) -> a -> b
$
            SnapshotManager m blk (StateRef m l blk)
-> Maybe String
-> StateRef m l blk
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) blk st.
SnapshotManager m blk st
-> Maybe String -> st -> m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot
              SnapshotManager m blk (StateRef m l blk)
snapManager
              Maybe String
suff
              StateRef m l blk
st
    , wipeLedgerDB :: m ()
wipeLedgerDB = SnapshotManager m blk (StateRef m l blk) -> m ()
forall (m :: * -> *) blk st.
Monad m =>
SnapshotManager m blk st -> m ()
destroySnapshots SnapshotManager m blk (StateRef m l blk)
snapManager
    , truncateSnapshots :: m ()
truncateSnapshots = LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m ()) -> m ()
forall (m :: * -> *) (l :: StateKind) 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 blk (StateRef m l blk) -> SomeHasFS m -> m ()
forall (m :: * -> *) blk st.
MonadThrow m =>
SnapshotManager m blk st -> SomeHasFS m -> m ()
implIntTruncateSnapshots SnapshotManager m blk (StateRef m l blk)
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 :: StateKind) blk.
LedgerDBEnv m l blk -> SomeHasFS m
ldbHasFS
    , push :: l blk DiffMK -> m ()
push = \l blk DiffMK
st -> do
        LedgerDB m l blk -> (Forker m l blk -> m ()) -> m ()
forall (m :: * -> *) (l :: StateKind) blk a.
IOLike m =>
LedgerDB m l blk -> (Forker m l blk -> m a) -> m a
withTipForker
          LedgerDB m l blk
ldb
          ( \Forker m l blk
frk -> do
              Forker m l blk -> l blk DiffMK -> m ()
forall (m :: * -> *) (l :: StateKind) blk.
Forker m l blk -> l blk DiffMK -> m ()
forkerPush Forker m l blk
frk l blk DiffMK
st m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 blk -> STM m (m ())
forall (m :: * -> *) (l :: StateKind) blk.
Forker m l blk -> STM m (m ())
forkerCommit Forker m l blk
frk))
              LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m ()) -> m ()
forall (m :: * -> *) (l :: StateKind) 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 :: StateKind) 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 blk -> m ()) -> m ()
forall (m :: * -> *) (l :: StateKind) blk a.
IOLike m =>
LedgerDB m l blk -> (Forker m l blk -> m a) -> m a
withTipForker
          LedgerDB m l blk
ldb
          ( \Forker m l blk
frk -> do
              st <- STM m (l blk EmptyMK) -> m (l blk EmptyMK)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (l blk EmptyMK) -> m (l blk EmptyMK))
-> STM m (l blk EmptyMK) -> m (l blk EmptyMK)
forall a b. (a -> b) -> a -> b
$ Forker m l blk -> STM m (l blk EmptyMK)
forall (m :: * -> *) (l :: StateKind) blk.
Forker m l blk -> STM m (l blk EmptyMK)
forkerGetLedgerState Forker m l blk
frk
              tables <- forkerReadTables frk (getBlockKeySets blk)
              let st' =
                    ComputeLedgerEvents
-> LedgerCfg l blk -> blk -> l blk ValuesMK -> l blk DiffMK
forall (l :: StateKind) blk.
ApplyBlock l blk =>
ComputeLedgerEvents
-> LedgerCfg l blk -> blk -> l blk ValuesMK -> l blk DiffMK
tickThenReapply
                      (LedgerDbCfgF Identity l blk -> ComputeLedgerEvents
forall (f :: * -> *) (l :: StateKind) blk.
LedgerDbCfgF f l blk -> ComputeLedgerEvents
ledgerDbCfgComputeLedgerEvents (LedgerDBEnv m l blk -> LedgerDbCfgF Identity l blk
forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l blk
ldbCfg LedgerDBEnv m l blk
env))
                      (LedgerDbCfgF Identity l blk -> HKD Identity (LedgerCfg l blk)
forall (f :: * -> *) (l :: StateKind) blk.
LedgerDbCfgF f l blk -> HKD f (LedgerCfg l blk)
ledgerDbCfg (LedgerDbCfgF Identity l blk -> HKD Identity (LedgerCfg l blk))
-> LedgerDbCfgF Identity l blk -> HKD Identity (LedgerCfg l blk)
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> LedgerDbCfgF Identity l blk
forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l blk
ldbCfg LedgerDBEnv m l blk
env)
                      blk
blk
                      (l blk EmptyMK
st l blk EmptyMK -> LedgerTables blk ValuesMK -> l blk ValuesMK
forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l blk any -> LedgerTables blk mk -> l blk mk
forall (l :: StateKind) blk (mk :: MapKind) (any :: MapKind).
(HasLedgerTables l blk, CanMapMK mk, CanMapKeysMK mk,
 ZeroableMK mk) =>
l blk any -> LedgerTables blk mk -> l blk mk
`withLedgerTables` LedgerTables blk ValuesMK
tables)
              forkerPush frk st' >> Monad.join (atomically (forkerCommit frk))
              pruneLedgerSeq env
          )
    , closeLedgerDB :: m ()
closeLedgerDB = LedgerDBHandle m l blk -> m ()
forall (m :: * -> *) (l :: StateKind) 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 :: StateKind) 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 blk) -> m (LedgerSeq m l blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
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 blk)
-> (LedgerSeq m l blk -> (m (), LedgerSeq m l blk)) -> 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 blk)
forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
ldbSeq LedgerDBEnv m l blk
env) ((LedgerSeq m l blk -> (m (), LedgerSeq m l blk)) -> STM m (m ()))
-> (LedgerSeq m l blk -> (m (), LedgerSeq m l blk)) -> STM m (m ())
forall a b. (a -> b) -> a -> b
$ LedgerSeq m l blk -> (m (), LedgerSeq m l blk)
forall (m :: * -> *) (l :: StateKind) blk.
(Monad m, GetTip (l blk)) =>
LedgerSeq m l blk -> (m (), LedgerSeq m l blk)
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 blk st -> SomeHasFS m -> m ()
implIntTruncateSnapshots :: forall (m :: * -> *) blk st.
MonadThrow m =>
SnapshotManager m blk st -> SomeHasFS m -> m ()
implIntTruncateSnapshots SnapshotManager m blk st
snapManager (SomeHasFS HasFS m h
fs) = do
  SnapshotManager m blk st -> (DiskSnapshot -> m ()) -> m ()
forall (m :: * -> *) blk st a.
Monad m =>
SnapshotManager m blk st -> (DiskSnapshot -> m a) -> m ()
snapshotsMapM_ SnapshotManager 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 blk)) =>
  LedgerDBEnv m l blk ->
  STM m (l blk EmptyMK)
implGetVolatileTip :: forall (m :: * -> *) (l :: StateKind) blk.
(MonadSTM m, GetTip (l blk)) =>
LedgerDBEnv m l blk -> STM m (l blk EmptyMK)
implGetVolatileTip = (LedgerSeq m l blk -> l blk EmptyMK)
-> STM m (LedgerSeq m l blk) -> STM m (l blk 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 blk -> l blk EmptyMK
forall (l :: StateKind) blk (m :: * -> *).
GetTip (l blk) =>
LedgerSeq m l blk -> l blk EmptyMK
current (STM m (LedgerSeq m l blk) -> STM m (l blk EmptyMK))
-> (LedgerDBEnv m l blk -> STM m (LedgerSeq m l blk))
-> LedgerDBEnv m l blk
-> STM m (l blk EmptyMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBEnv m l blk -> STM m (LedgerSeq m l blk)
forall (m :: * -> *) (l :: StateKind) blk.
(MonadSTM m, GetTip (l blk)) =>
LedgerDBEnv m l blk -> STM m (LedgerSeq m l blk)
getVolatileLedgerSeq

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

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

implGetHeaderStateHistory ::
  ( MonadSTM m
  , IsLedger LedgerState blk
  , HasHardForkHistory blk
  , HasAnnTip blk
  ) =>
  LedgerDBEnv m ExtLedgerState blk -> STM m (HeaderStateHistory blk)
implGetHeaderStateHistory :: forall (m :: * -> *) blk.
(MonadSTM m, IsLedger LedgerState blk, HasHardForkHistory blk,
 HasAnnTip blk) =>
LedgerDBEnv m ExtLedgerState blk -> STM m (HeaderStateHistory blk)
implGetHeaderStateHistory LedgerDBEnv m ExtLedgerState blk
env = do
  ldb <- LedgerDBEnv m ExtLedgerState blk
-> STM m (LedgerSeq m ExtLedgerState blk)
forall (m :: * -> *) (l :: StateKind) blk.
(MonadSTM m, GetTip (l blk)) =>
LedgerDBEnv m l blk -> STM m (LedgerSeq m l blk)
getVolatileLedgerSeq LedgerDBEnv m ExtLedgerState 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 :: StateKind) blk (m :: * -> *).
GetTip (l blk) =>
LedgerSeq m l blk -> l blk 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 = LedgerCfg LedgerState blk
-> LedgerState blk EmptyMK -> Summary (HardForkIndices blk)
forall blk (mk :: MapKind).
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
forall (mk :: MapKind).
LedgerCfg LedgerState blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
hardForkSummary (TopLevelConfig blk -> LedgerCfg LedgerState blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger (TopLevelConfig blk -> LedgerCfg LedgerState blk)
-> TopLevelConfig blk -> LedgerCfg LedgerState 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 ExtLedgerState blk
-> HKD Identity (LedgerCfg ExtLedgerState blk)
forall (f :: * -> *) (l :: StateKind) blk.
LedgerDbCfgF f l blk -> HKD f (LedgerCfg l blk)
ledgerDbCfg (LedgerDbCfgF Identity ExtLedgerState blk
 -> HKD Identity (LedgerCfg ExtLedgerState blk))
-> LedgerDbCfgF Identity ExtLedgerState blk
-> HKD Identity (LedgerCfg ExtLedgerState blk)
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m ExtLedgerState blk
-> LedgerDbCfgF Identity ExtLedgerState blk
forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l blk
ldbCfg LedgerDBEnv m ExtLedgerState 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 :: StateKind) blk.
StateRef m l blk -> l blk EmptyMK
state
  pure
    . HeaderStateHistory
    . AS.bimap mkHeaderStateWithTime' mkHeaderStateWithTime'
    . getLedgerSeq
    $ ldb

implValidate ::
  forall m l blk.
  ( IOLike m
  , HasCallStack
  , ApplyBlock l blk
  , StandardHash (l blk)
  , LedgerSupportsProtocol blk
  ) =>
  LedgerDBHandle m l blk ->
  LedgerDBEnv m l blk ->
  (TraceValidateEvent blk -> m ()) ->
  BlockCache blk ->
  Word64 ->
  NonEmpty (Header blk) ->
  SuccessForkerAction m l blk ->
  m (ValidateResult l blk)
implValidate :: forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, HasCallStack, ApplyBlock l blk, StandardHash (l blk),
 LedgerSupportsProtocol blk) =>
LedgerDBHandle m l blk
-> LedgerDBEnv m l blk
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> NonEmpty (Header blk)
-> SuccessForkerAction m l blk
-> 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 blk
onSuccess =
  ComputeLedgerEvents
-> ValidateArgs m l blk -> m (ValidateResult l blk)
forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, HasCallStack, ApplyBlock l blk) =>
ComputeLedgerEvents
-> ValidateArgs m l blk -> m (ValidateResult l blk)
validate (LedgerDbCfgF Identity l blk -> ComputeLedgerEvents
forall (f :: * -> *) (l :: StateKind) blk.
LedgerDbCfgF f l blk -> ComputeLedgerEvents
ledgerDbCfgComputeLedgerEvents (LedgerDbCfgF Identity l blk -> ComputeLedgerEvents)
-> LedgerDbCfgF Identity l blk -> ComputeLedgerEvents
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> LedgerDbCfgF Identity l blk
forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l blk
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 blk
-> ([RealPoint blk] -> STM m ())
-> STM m (Set (RealPoint blk))
-> (forall r.
    Word64 -> (Forker m l blk -> m r) -> m (Either GetForkerError r))
-> SuccessForkerAction m l blk
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> NonEmpty (Header blk)
-> ValidateArgs m l blk
forall (m :: * -> *) (l :: StateKind) blk.
ResolveBlock m blk
-> LedgerCfg l blk
-> ([RealPoint blk] -> STM m ())
-> STM m (Set (RealPoint blk))
-> (forall r.
    Word64 -> (Forker m l blk -> m r) -> m (Either GetForkerError r))
-> SuccessForkerAction m l blk
-> (TraceValidateEvent blk -> m ())
-> BlockCache blk
-> Word64
-> NonEmpty (Header blk)
-> ValidateArgs m l blk
ValidateArgs
      (LedgerDBEnv m l blk -> ResolveBlock m blk
forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> ResolveBlock m blk
ldbResolveBlock LedgerDBEnv m l blk
ldbEnv)
      (LedgerDbCfgF Identity l blk -> HKD Identity (LedgerCfg l blk)
forall (f :: * -> *) (l :: StateKind) blk.
LedgerDbCfgF f l blk -> HKD f (LedgerCfg l blk)
ledgerDbCfg (LedgerDbCfgF Identity l blk -> HKD Identity (LedgerCfg l blk))
-> LedgerDbCfgF Identity l blk -> HKD Identity (LedgerCfg l blk)
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> LedgerDbCfgF Identity l blk
forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l blk
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 :: StateKind) 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 :: StateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
ldbPrevApplied LedgerDBEnv m l blk
ldbEnv))
      (LedgerDBHandle m l blk
-> Word64 -> (Forker m l blk -> m r) -> m (Either GetForkerError r)
forall (l :: StateKind) blk (m :: * -> *) r.
(HeaderHash (l blk) ~ HeaderHash blk, IOLike m, IsLedger l blk,
 StandardHash (l blk), HasLedgerTables l blk,
 LedgerSupportsProtocol blk) =>
LedgerDBHandle m l blk
-> Word64 -> (Forker m l blk -> m r) -> m (Either GetForkerError r)
withForkerByRollback LedgerDBHandle m l blk
h)
      SuccessForkerAction m l blk
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 :: StateKind) 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 :: StateKind) 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 blk)) => LedgerDBEnv m l blk -> SlotNo -> m ()
implGarbageCollect :: forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, GetTip (l blk)) =>
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 :: StateKind) 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 :: StateKind) 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 blk)
-> (LedgerSeq m l blk -> (m (), LedgerSeq m l blk)) -> 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 blk)
forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
ldbSeq LedgerDBEnv m l blk
env) ((LedgerSeq m l blk -> (m (), LedgerSeq m l blk)) -> STM m (m ()))
-> (LedgerSeq m l blk -> (m (), LedgerSeq m l blk)) -> STM m (m ())
forall a b. (a -> b) -> a -> b
$ LedgerDbPrune -> LedgerSeq m l blk -> (m (), LedgerSeq m l blk)
forall (m :: * -> *) (l :: StateKind) blk.
(Monad m, GetTip (l blk)) =>
LedgerDbPrune -> LedgerSeq m l blk -> (m (), LedgerSeq m l blk)
prune (SlotNo -> LedgerDbPrune
LedgerDbPruneBeforeSlot SlotNo
slotNo)
    pure (close, ())

implTryTakeSnapshot ::
  forall m l blk.
  ( IOLike m
  , GetTip (l blk)
  ) =>
  SnapshotManager m blk (StateRef m l blk) ->
  LedgerDBEnv m l blk ->
  m () ->
  (SnapshotDelayRange -> m DiffTime) ->
  m ()
implTryTakeSnapshot :: forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, GetTip (l blk)) =>
SnapshotManager m blk (StateRef m l blk)
-> LedgerDBEnv m l blk
-> m ()
-> (SnapshotDelayRange -> m DiffTime)
-> m ()
implTryTakeSnapshot SnapshotManager m blk (StateRef m l blk)
snapManager LedgerDBEnv m l blk
env m ()
copyBlocks SnapshotDelayRange -> m DiffTime
getRandomDelay = do
  now <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
  timeSinceLastSnapshot <- do
    mLastSnapshotRequested <- readTVarIO $ ldbLastSuccessfulSnapshotRequestedAt env
    for mLastSnapshotRequested $ \Time
lastSnapshotRequested -> do
      DiffTime -> m DiffTime
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiffTime -> m DiffTime) -> DiffTime -> m DiffTime
forall a b. (a -> b) -> a -> b
$ Time
now Time -> Time -> DiffTime
`diffTime` Time
lastSnapshotRequested
  -- calculate and duplicate the ledger tables handles that we will be taking snapshots of
  handles <- RAWLock.withReadAccess (ldbOpenHandlesLock env) $ \() -> do
    lseq@(LedgerSeq immutableStates) <- STM m (LedgerSeq m l blk) -> m (LedgerSeq m l blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LedgerSeq m l blk) -> m (LedgerSeq m l blk))
-> STM m (LedgerSeq m l blk) -> m (LedgerSeq m l blk)
forall a b. (a -> b) -> a -> b
$ do
      LedgerSeq states <- StrictTVar m (LedgerSeq m l blk) -> STM m (LedgerSeq m l blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (StrictTVar m (LedgerSeq m l blk) -> STM m (LedgerSeq m l blk))
-> StrictTVar m (LedgerSeq m l blk) -> STM m (LedgerSeq m l blk)
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
ldbSeq LedgerDBEnv m l blk
env
      volSuffix <- getVolatileSuffix (ldbGetVolatileSuffix env)
      pure $ LedgerSeq $ AS.dropNewest (AS.length (volSuffix states)) states
    let immutableSlots :: [SlotNo] =
          -- Remove duplicates due to EBBs.
          nubOrd . mapMaybe (withOriginToMaybe . getTipSlot . state) $
            AS.anchor immutableStates : AS.toOldestFirst immutableStates
        snapshotSlots =
          SnapshotPolicy -> SnapshotSelectorContext -> [SlotNo]
onDiskSnapshotSelector
            (LedgerDBEnv m l blk -> SnapshotPolicy
forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> SnapshotPolicy
ldbSnapshotPolicy LedgerDBEnv m l blk
env)
            SnapshotSelectorContext
              { sscTimeSinceLast :: Maybe DiffTime
sscTimeSinceLast = Maybe DiffTime
timeSinceLastSnapshot
              , sscSnapshotSlots :: [SlotNo]
sscSnapshotSlots = [SlotNo]
immutableSlots
              }
    Monad.forM snapshotSlots $ \SlotNo
slot -> do
      -- Prune the 'LedgerSeq' such that the resulting anchor state has slot
      -- number @slot@.
      let pruneStrat :: LedgerDbPrune
pruneStrat = SlotNo -> LedgerDbPrune
LedgerDbPruneBeforeSlot (SlotNo
slot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1)
      (SlotNo
slot,) (StateRef m l blk -> (SlotNo, StateRef m l blk))
-> m (StateRef m l blk) -> m (SlotNo, StateRef m l blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StateRef m l blk -> m (StateRef m l blk)
duplicateStateRef (StateRef m l blk -> m (StateRef m l blk))
-> StateRef m l blk -> m (StateRef m l blk)
forall a b. (a -> b) -> a -> b
$ LedgerSeq m l blk -> StateRef m l blk
forall (m :: * -> *) (l :: StateKind) blk.
LedgerSeq m l blk -> StateRef m l blk
anchorHandle (LedgerSeq m l blk -> StateRef m l blk)
-> LedgerSeq m l blk -> StateRef m l blk
forall a b. (a -> b) -> a -> b
$ (m (), LedgerSeq m l blk) -> LedgerSeq m l blk
forall a b. (a, b) -> b
snd ((m (), LedgerSeq m l blk) -> LedgerSeq m l blk)
-> (m (), LedgerSeq m l blk) -> LedgerSeq m l blk
forall a b. (a -> b) -> a -> b
$ LedgerDbPrune -> LedgerSeq m l blk -> (m (), LedgerSeq m l blk)
forall (m :: * -> *) (l :: StateKind) blk.
(Monad m, GetTip (l blk)) =>
LedgerDbPrune -> LedgerSeq m l blk -> (m (), LedgerSeq m l blk)
prune LedgerDbPrune
pruneStrat LedgerSeq m l blk
lseq)

  -- look at the list of the ledger tables handles from the previous step and take the snapshots
  case NonEmpty.nonEmpty handles of
    Maybe (NonEmpty (SlotNo, StateRef m l blk))
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    -- TODO: this logic could be forked on a separate thread now that we only
    -- have V2.
    Just NonEmpty (SlotNo, StateRef m l blk)
nonEmptyHandles -> do
      m ()
copyBlocks

      delayBeforeSnapshotting <- SnapshotDelayRange -> m DiffTime
getRandomDelay (SnapshotPolicy -> SnapshotDelayRange
onDiskSnapshotDelayRange (LedgerDBEnv m l blk -> SnapshotPolicy
forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> SnapshotPolicy
ldbSnapshotPolicy LedgerDBEnv m l blk
env))
      traceWith (LedgerDBSnapshotEvent >$< ldbTracer env) $
        SnapshotRequestDelayed now delayBeforeSnapshotting (NonEmpty.map fst nonEmptyHandles)
      threadDelay delayBeforeSnapshotting

      for_ nonEmptyHandles $ \(SlotNo
_, StateRef m l blk
h) -> do
        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 blk (StateRef m l blk)
-> Maybe String
-> StateRef m l blk
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) blk st.
SnapshotManager m blk st
-> Maybe String -> st -> m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot SnapshotManager m blk (StateRef m l blk)
snapManager Maybe String
forall a. Maybe a
Nothing StateRef m l blk
h
        m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Monad.void (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ LedgerTablesHandle m l blk -> m ()
forall (m :: * -> *) (l :: StateKind) blk.
LedgerTablesHandle m l blk -> m ()
close (LedgerTablesHandle m l blk -> m ())
-> (StateRef m l blk -> LedgerTablesHandle m l blk)
-> StateRef m l blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef m l blk -> LedgerTablesHandle m l blk
forall (m :: * -> *) (l :: StateKind) blk.
StateRef m l blk -> LedgerTablesHandle m l blk
tables (StateRef m l blk -> m ()) -> StateRef m l blk -> m ()
forall a b. (a -> b) -> a -> b
$ StateRef m l blk
h
      -- we don't bracket around the handles because it is tedious. An exception that may occur
      -- before we close them would bring the whole cardano-node down anyway.

      atomically $ writeTVar (ldbLastSuccessfulSnapshotRequestedAt env) (Just $! now)
      Monad.void $ trimSnapshots snapManager (ldbSnapshotPolicy env)
      traceWith (LedgerDBSnapshotEvent >$< ldbTracer env) $
        SnapshotRequestCompleted
 where
  duplicateStateRef :: StateRef m l blk -> m (StateRef m l blk)
  duplicateStateRef :: StateRef m l blk -> m (StateRef m l blk)
duplicateStateRef StateRef{l blk EmptyMK
state :: forall (m :: * -> *) (l :: StateKind) blk.
StateRef m l blk -> l blk EmptyMK
state :: l blk EmptyMK
state, LedgerTablesHandle m l blk
tables :: forall (m :: * -> *) (l :: StateKind) blk.
StateRef m l blk -> LedgerTablesHandle m l blk
tables :: LedgerTablesHandle m l blk
tables} = do
    h <- LedgerTablesHandle m l blk -> m (LedgerTablesHandle m l blk)
forall (m :: * -> *) (l :: StateKind) blk.
LedgerTablesHandle m l blk -> m (LedgerTablesHandle m l blk)
duplicate LedgerTablesHandle m l blk
tables
    pure $ StateRef state h

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

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

type LedgerDBEnv :: (Type -> Type) -> StateKind -> Type -> Type
data LedgerDBEnv m l blk = LedgerDBEnv
  { forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
ldbSeq :: !(StrictTVar m (LedgerSeq m l blk))
  -- ^ INVARIANT: the tip of the 'LedgerDB' is always in sync with the tip of
  -- the current chain of the ChainDB.
  , forall (m :: * -> *) (l :: StateKind) 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 :: StateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m ForkerKey
ldbNextForkerKey :: !(StrictTVar m ForkerKey)
  , forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> SnapshotPolicy
ldbSnapshotPolicy :: !SnapshotPolicy
  , forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> Tracer m (TraceEvent blk)
ldbTracer :: !(Tracer m (TraceEvent blk))
  , forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l blk
ldbCfg :: !(LedgerDbCfg l blk)
  , forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> SomeHasFS m
ldbHasFS :: !(SomeHasFS m)
  , forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> ResolveBlock m blk
ldbResolveBlock :: !(ResolveBlock m blk)
  , forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> QueryBatchSize
ldbQueryBatchSize :: !QueryBatchSize
  , forall (m :: * -> *) (l :: StateKind) 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 :: StateKind) 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 :: StateKind) blk.
LedgerDBEnv m l blk -> GetVolatileSuffix m blk
ldbGetVolatileSuffix :: !(GetVolatileSuffix m blk)
  , forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (Maybe Time)
ldbLastSuccessfulSnapshotRequestedAt :: !(StrictTVar m (Maybe Time))
  -- ^ The time at which the latest successfully-completed snapshot was
  -- requested. Note that this is not the the last time any snapshot was
  -- requested -- there may be later snapshot requests that have failed, or that
  -- are currently in progress (but may be blocked by a snapshot delay or
  -- working).
  }
  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 :: StateKind) blk x.
Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
forall (m :: * -> *) (l :: StateKind) blk x.
LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
$cfrom :: forall (m :: * -> *) (l :: StateKind) 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 :: StateKind) 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 blk EmptyMK)
  , NoThunks (TxIn blk)
  , NoThunks (TxOut blk)
  , NoThunks (LedgerCfg l blk)
  ) =>
  NoThunks (LedgerDBEnv m l blk)

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

type LedgerDBHandle :: (Type -> Type) -> StateKind -> 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 :: StateKind) blk x.
Rep (LedgerDBHandle m l blk) x -> LedgerDBHandle m l blk
forall (m :: * -> *) (l :: StateKind) blk x.
LedgerDBHandle m l blk -> Rep (LedgerDBHandle m l blk) x
$cfrom :: forall (m :: * -> *) (l :: StateKind) 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 :: StateKind) 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 :: StateKind) blk x.
Rep (LedgerDBState m l blk) x -> LedgerDBState m l blk
forall (m :: * -> *) (l :: StateKind) blk x.
LedgerDBState m l blk -> Rep (LedgerDBState m l blk) x
$cfrom :: forall (m :: * -> *) (l :: StateKind) 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 :: StateKind) 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 blk EmptyMK)
  , NoThunks (TxIn blk)
  , NoThunks (TxOut blk)
  , NoThunks (LedgerCfg l 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 :: StateKind) 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.
getEnv2 ::
  IOLike m =>
  LedgerDBHandle m l blk ->
  (LedgerDBEnv m l blk -> a -> b -> m r) ->
  a ->
  b ->
  m r
getEnv2 :: forall (m :: * -> *) (l :: StateKind) blk a b r.
IOLike m =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> b -> m r) -> a -> b -> m r
getEnv2 LedgerDBHandle m l blk
h LedgerDBEnv m l blk -> a -> b -> m r
f a
a b
b = LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
forall (m :: * -> *) (l :: StateKind) 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 -> m r
f LedgerDBEnv m l blk
env a
a b
b)

-- | 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 :: StateKind) 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 :: StateKind) 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 :: StateKind) 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 blk)) =>
  LedgerDBEnv m l blk -> STM m (LedgerSeq m l blk)
getVolatileLedgerSeq :: forall (m :: * -> *) (l :: StateKind) blk.
(MonadSTM m, GetTip (l blk)) =>
LedgerDBEnv m l blk -> STM m (LedgerSeq m l blk)
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 :: StateKind) 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 blk)) =>
  LedgerDBEnv m l blk ->
  (LedgerSeq m l blk -> t (StateRef m l blk)) ->
  m (t (StateRef m l blk))
openStateRef :: forall (m :: * -> *) (t :: * -> *) (l :: StateKind) blk.
(IOLike m, Traversable t, GetTip (l blk)) =>
LedgerDBEnv m l blk
-> (LedgerSeq m l blk -> t (StateRef m l blk))
-> m (t (StateRef m l blk))
openStateRef LedgerDBEnv m l blk
ldbEnv LedgerSeq m l blk -> t (StateRef m l blk)
project =
  RAWLock m ()
-> (() -> m (t (StateRef m l blk))) -> m (t (StateRef m l blk))
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 :: StateKind) blk.
LedgerDBEnv m l blk -> RAWLock m ()
ldbOpenHandlesLock LedgerDBEnv m l blk
ldbEnv) ((() -> m (t (StateRef m l blk))) -> m (t (StateRef m l blk)))
-> (() -> m (t (StateRef m l blk))) -> m (t (StateRef m l blk))
forall a b. (a -> b) -> a -> b
$ \() -> do
    tst <- LedgerSeq m l blk -> t (StateRef m l blk)
project (LedgerSeq m l blk -> t (StateRef m l blk))
-> m (LedgerSeq m l blk) -> m (t (StateRef m l blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (LedgerSeq m l blk) -> m (LedgerSeq m l blk)
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 blk)
forall (m :: * -> *) (l :: StateKind) blk.
(MonadSTM m, GetTip (l blk)) =>
LedgerDBEnv m l blk -> STM m (LedgerSeq m l blk)
getVolatileLedgerSeq LedgerDBEnv m l blk
ldbEnv)
    for tst $ \StateRef m l blk
st -> do
      tables' <- LedgerTablesHandle m l blk -> m (LedgerTablesHandle m l blk)
forall (m :: * -> *) (l :: StateKind) blk.
LedgerTablesHandle m l blk -> m (LedgerTablesHandle m l blk)
duplicate (StateRef m l blk -> LedgerTablesHandle m l blk
forall (m :: * -> *) (l :: StateKind) blk.
StateRef m l blk -> LedgerTablesHandle m l blk
tables StateRef m l blk
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 blk)) =>
  LedgerDBEnv m l blk ->
  (LedgerSeq m l blk -> t (StateRef m l blk)) ->
  (t (StateRef m l blk) -> m a) ->
  m a
withStateRef :: forall (m :: * -> *) (t :: * -> *) (l :: StateKind) blk a.
(IOLike m, Traversable t, GetTip (l blk)) =>
LedgerDBEnv m l blk
-> (LedgerSeq m l blk -> t (StateRef m l blk))
-> (t (StateRef m l blk) -> m a)
-> m a
withStateRef LedgerDBEnv m l blk
ldbEnv LedgerSeq m l blk -> t (StateRef m l blk)
project t (StateRef m l blk) -> m a
f =
  m (t (StateRef m l blk))
-> (t (StateRef m l blk) -> m (t ()))
-> (t (StateRef m l blk) -> 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 blk -> t (StateRef m l blk))
-> m (t (StateRef m l blk))
forall (m :: * -> *) (t :: * -> *) (l :: StateKind) blk.
(IOLike m, Traversable t, GetTip (l blk)) =>
LedgerDBEnv m l blk
-> (LedgerSeq m l blk -> t (StateRef m l blk))
-> m (t (StateRef m l blk))
openStateRef LedgerDBEnv m l blk
ldbEnv LedgerSeq m l blk -> t (StateRef m l blk)
project)
    ((StateRef m l blk -> m ()) -> t (StateRef m l blk) -> 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 blk -> m ()
forall (m :: * -> *) (l :: StateKind) blk.
LedgerTablesHandle m l blk -> m ()
close (LedgerTablesHandle m l blk -> m ())
-> (StateRef m l blk -> LedgerTablesHandle m l blk)
-> StateRef m l blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef m l blk -> LedgerTablesHandle m l blk
forall (m :: * -> *) (l :: StateKind) blk.
StateRef m l blk -> LedgerTablesHandle m l blk
tables))
    t (StateRef m l blk) -> m a
f

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

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

withForkerByRollback ::
  ( HeaderHash (l blk) ~ HeaderHash blk
  , IOLike m
  , IsLedger l blk
  , StandardHash (l blk)
  , HasLedgerTables l blk
  , LedgerSupportsProtocol blk
  ) =>
  LedgerDBHandle m l blk ->
  Word64 ->
  (Forker m l blk -> m r) ->
  m (Either GetForkerError r)
withForkerByRollback :: forall (l :: StateKind) blk (m :: * -> *) r.
(HeaderHash (l blk) ~ HeaderHash blk, IOLike m, IsLedger l blk,
 StandardHash (l blk), HasLedgerTables l blk,
 LedgerSupportsProtocol blk) =>
LedgerDBHandle m l blk
-> Word64 -> (Forker m l blk -> m r) -> m (Either GetForkerError r)
withForkerByRollback LedgerDBHandle m l blk
h Word64
n Forker m l blk -> m r
k = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> m (Either GetForkerError r))
-> m (Either GetForkerError r)
forall (m :: * -> *) (l :: StateKind) 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 blk))
-> (Either GetForkerError (Forker m l blk) -> m ())
-> (Either GetForkerError (Forker m l blk)
    -> 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 blk))
forall (l :: StateKind) blk (m :: * -> *).
(HeaderHash (l blk) ~ HeaderHash blk, IOLike m, GetTip (l blk),
 StandardHash (l blk), LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> m (Either GetForkerError (StateRef m l blk))
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 blk))
-> (Either GetForkerError (StateRef m l blk)
    -> m (Either GetForkerError (Forker m l blk)))
-> m (Either GetForkerError (Forker m l blk))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (StateRef m l blk -> m (Forker m l blk))
-> Either GetForkerError (StateRef m l blk)
-> m (Either GetForkerError (Forker m l blk))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> Either GetForkerError a -> f (Either GetForkerError b)
traverse (LedgerDBEnv m l blk -> StateRef m l blk -> m (Forker m l blk)
forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, HasLedgerTables l blk, NoThunks (l blk EmptyMK),
 GetTip (l blk), StandardHash (l blk)) =>
LedgerDBEnv m l blk -> StateRef m l blk -> m (Forker m l blk)
newForker LedgerDBEnv m l blk
ldbEnv))
    ((GetForkerError -> m ())
-> (Forker m l blk -> m ())
-> Either GetForkerError (Forker m l blk)
-> 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 blk -> m ()
forall (m :: * -> *) (l :: StateKind) blk. Forker m l blk -> m ()
forkerClose)
    ((GetForkerError -> m (Either GetForkerError r))
-> (Forker m l blk -> m (Either GetForkerError r))
-> Either GetForkerError (Forker m l blk)
-> 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 blk -> m r)
-> Forker m l blk
-> m (Either GetForkerError r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forker m l blk -> 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 blk ->
  m ()
implForkerClose :: forall (m :: * -> *) (l :: StateKind) blk.
IOLike m =>
ForkerEnv m l blk -> m ()
implForkerClose ForkerEnv m l blk
env = do
  wasCommitted <- StrictTVar m Bool -> m Bool
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (ForkerEnv m l blk -> StrictTVar m Bool
forall (m :: * -> *) (l :: StateKind) blk.
ForkerEnv m l blk -> StrictTVar m Bool
foeWasCommitted ForkerEnv m l blk
env)
  if wasCommitted
    then
      traceWith (foeTracer env) (ForkerClose ForkerWasCommitted)
    else
      traceWith (foeTracer env) (ForkerClose ForkerWasUncommitted)
  closeLedgerSeq =<< readTVarIO (foeLedgerSeq env)

newForker ::
  ( IOLike m
  , HasLedgerTables l blk
  , NoThunks (l blk EmptyMK)
  , GetTip (l blk)
  , StandardHash (l blk)
  ) =>
  LedgerDBEnv m l blk ->
  StateRef m l blk ->
  m (Forker m l blk)
newForker :: forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, HasLedgerTables l blk, NoThunks (l blk EmptyMK),
 GetTip (l blk), StandardHash (l blk)) =>
LedgerDBEnv m l blk -> StateRef m l blk -> m (Forker m l blk)
newForker LedgerDBEnv m l blk
ldbEnv StateRef m l blk
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 :: StateKind) 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 :: StateKind) 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 blk)
foeLedgerSeq = StrictTVar m (LedgerSeq m l blk)
lseq
          , foeSwitchVar :: StrictTVar m (LedgerSeq m l blk)
foeSwitchVar = LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
forall (m :: * -> *) (l :: StateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
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 :: StateKind) 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
      }