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

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

import Control.Monad
import Control.Monad.Except
import Control.Monad.Trans (lift)
import Control.Tracer
import qualified Data.Foldable as Foldable
import Data.Functor ((<&>))
import Data.Functor.Contravariant ((>$<))
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (isJust)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word
import GHC.Generics (Generic)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.HardFork.Abstract
import Ouroboros.Consensus.HeaderStateHistory
  ( HeaderStateHistory (..)
  , mkHeaderStateWithTimeFromSummary
  )
import Ouroboros.Consensus.HeaderValidation
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.SupportsProtocol
import Ouroboros.Consensus.Ledger.Tables.Utils
import Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache
import Ouroboros.Consensus.Storage.LedgerDB.API
import Ouroboros.Consensus.Storage.LedgerDB.Args
import Ouroboros.Consensus.Storage.LedgerDB.Forker
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import Ouroboros.Consensus.Storage.LedgerDB.TraceEvent
import Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1
import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as BS
import Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog as DbCh
  ( empty
  , flushableLength
  )
import Ouroboros.Consensus.Storage.LedgerDB.V1.Forker
import Ouroboros.Consensus.Storage.LedgerDB.V1.Lock
import Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots
import Ouroboros.Consensus.Util
import Ouroboros.Consensus.Util.Args
import Ouroboros.Consensus.Util.CallStack
import Ouroboros.Consensus.Util.IOLike
import qualified Ouroboros.Network.AnchoredSeq as AS
import Ouroboros.Network.Protocol.LocalStateQuery.Type
import System.FS.API

type SnapshotManagerV1 m blk =
  SnapshotManager m (ReadLocked m) blk (StrictTVar m (DbChangelog' blk), BackingStore' m 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.
  ( LedgerSupportsProtocol blk
  , IOLike m
  , HasHardForkHistory blk
  , LedgerSupportsLedgerDB blk
  ) =>
  Complete LedgerDbArgs m blk ->
  V1.LedgerDbBackendArgs m (ExtLedgerState blk) ->
  ResolveBlock m blk ->
  SnapshotManagerV1 m blk ->
  GetVolatileSuffix m blk ->
  InitDB (DbChangelog' blk, BackingStore' m blk) m blk
mkInitDb :: forall (m :: * -> *) blk.
(LedgerSupportsProtocol blk, IOLike m, HasHardForkHistory blk,
 LedgerSupportsLedgerDB blk) =>
Complete LedgerDbArgs m blk
-> LedgerDbBackendArgs m (ExtLedgerState blk)
-> ResolveBlock m blk
-> SnapshotManagerV1 m blk
-> GetVolatileSuffix m blk
-> InitDB (DbChangelog' blk, BackingStore' m blk) m blk
mkInitDb Complete LedgerDbArgs m blk
args LedgerDbBackendArgs m (ExtLedgerState blk)
bss ResolveBlock m blk
getBlock SnapshotManagerV1 m blk
snapManager GetVolatileSuffix m blk
getVolatileSuffix =
  InitDB
    { initFromGenesis :: m (DbChangelog (ExtLedgerState blk),
   BackingStore
     m
     (LedgerTables (ExtLedgerState blk) KeysMK)
     (TxIn (LedgerState blk))
     (LedgerTables (ExtLedgerState blk) ValuesMK)
     (LedgerTables (ExtLedgerState blk) DiffMK))
initFromGenesis = do
        st <- m (ExtLedgerState blk ValuesMK)
lgrGenesis
        let genesis = ExtLedgerState blk ValuesMK -> ExtLedgerState blk EmptyMK
forall (l :: LedgerStateKind) (mk :: MapKind).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables ExtLedgerState blk ValuesMK
st
            chlog = ExtLedgerState blk EmptyMK -> DbChangelog (ExtLedgerState blk)
forall (l :: LedgerStateKind).
(HasLedgerTables l, GetTip l) =>
l EmptyMK -> DbChangelog l
DbCh.empty ExtLedgerState blk EmptyMK
genesis
        backingStore <- newBackingStore bsTracer baArgs lgrHasFS' genesis (projectLedgerTables st)
        pure (chlog, backingStore)
    , initFromSnapshot :: DiskSnapshot
-> m (Either
        (SnapshotFailure blk)
        ((DbChangelog (ExtLedgerState blk),
          BackingStore
            m
            (LedgerTables (ExtLedgerState blk) KeysMK)
            (TxIn (LedgerState blk))
            (LedgerTables (ExtLedgerState blk) ValuesMK)
            (LedgerTables (ExtLedgerState blk) DiffMK)),
         RealPoint blk))
initFromSnapshot = \DiskSnapshot
ds ->
        ExceptT
  (SnapshotFailure blk)
  m
  ((DbChangelog (ExtLedgerState blk),
    BackingStore
      m
      (LedgerTables (ExtLedgerState blk) KeysMK)
      (TxIn (LedgerState blk))
      (LedgerTables (ExtLedgerState blk) ValuesMK)
      (LedgerTables (ExtLedgerState blk) DiffMK)),
   RealPoint blk)
-> m (Either
        (SnapshotFailure blk)
        ((DbChangelog (ExtLedgerState blk),
          BackingStore
            m
            (LedgerTables (ExtLedgerState blk) KeysMK)
            (TxIn (LedgerState blk))
            (LedgerTables (ExtLedgerState blk) ValuesMK)
            (LedgerTables (ExtLedgerState blk) DiffMK)),
         RealPoint blk))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
          ( Tracer m SomeBackendTrace
-> SomeBackendArgs m (ExtLedgerState blk)
-> CodecConfig blk
-> SnapshotsFS m
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     ((DbChangelog (ExtLedgerState blk),
       BackingStore
         m
         (LedgerTables (ExtLedgerState blk) KeysMK)
         (TxIn (ExtLedgerState blk))
         (LedgerTables (ExtLedgerState blk) ValuesMK)
         (LedgerTables (ExtLedgerState blk) DiffMK)),
      RealPoint blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk,
 LedgerSupportsV1LedgerDB (LedgerState blk),
 LedgerDbSerialiseConstraints blk) =>
Tracer m SomeBackendTrace
-> SomeBackendArgs m (ExtLedgerState blk)
-> CodecConfig blk
-> SnapshotsFS m
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     ((DbChangelog' blk, LedgerBackingStore m (ExtLedgerState blk)),
      RealPoint blk)
loadSnapshot
              Tracer m SomeBackendTrace
bsTracer
              SomeBackendArgs m (ExtLedgerState blk)
baArgs
              (TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec (TopLevelConfig blk -> CodecConfig blk)
-> (LedgerDbCfg (ExtLedgerState blk) -> TopLevelConfig blk)
-> LedgerDbCfg (ExtLedgerState blk)
-> CodecConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg (ExtLedgerCfg blk -> TopLevelConfig blk)
-> (LedgerDbCfg (ExtLedgerState blk) -> ExtLedgerCfg blk)
-> LedgerDbCfg (ExtLedgerState blk)
-> TopLevelConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDbCfg (ExtLedgerState blk)
-> HKD Identity (LedgerCfg (ExtLedgerState blk))
LedgerDbCfg (ExtLedgerState blk) -> ExtLedgerCfg blk
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
ledgerDbCfg (LedgerDbCfg (ExtLedgerState blk) -> CodecConfig blk)
-> LedgerDbCfg (ExtLedgerState blk) -> CodecConfig blk
forall a b. (a -> b) -> a -> b
$ LedgerDbCfg (ExtLedgerState blk)
lgrConfig)
              SnapshotsFS m
lgrHasFS'
              DiskSnapshot
ds
          )
    , initReapplyBlock :: LedgerDbCfg (ExtLedgerState blk)
-> blk
-> (DbChangelog (ExtLedgerState blk),
    BackingStore
      m
      (LedgerTables (ExtLedgerState blk) KeysMK)
      (TxIn (LedgerState blk))
      (LedgerTables (ExtLedgerState blk) ValuesMK)
      (LedgerTables (ExtLedgerState blk) DiffMK))
-> m (DbChangelog (ExtLedgerState blk),
      BackingStore
        m
        (LedgerTables (ExtLedgerState blk) KeysMK)
        (TxIn (LedgerState blk))
        (LedgerTables (ExtLedgerState blk) ValuesMK)
        (LedgerTables (ExtLedgerState blk) DiffMK))
initReapplyBlock = \LedgerDbCfg (ExtLedgerState blk)
cfg blk
blk (DbChangelog (ExtLedgerState blk)
chlog, BackingStore
  m
  (LedgerTables (ExtLedgerState blk) KeysMK)
  (TxIn (LedgerState blk))
  (LedgerTables (ExtLedgerState blk) ValuesMK)
  (LedgerTables (ExtLedgerState blk) DiffMK)
bstore) -> do
        !chlog' <- LedgerDbCfg (ExtLedgerState blk)
-> blk
-> KeySetsReader m (ExtLedgerState blk)
-> DbChangelog (ExtLedgerState blk)
-> m (DbChangelog (ExtLedgerState blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(Monad m, ApplyBlock l blk) =>
LedgerDbCfg l
-> blk -> KeySetsReader m l -> DbChangelog l -> m (DbChangelog l)
reapplyThenPush LedgerDbCfg (ExtLedgerState blk)
cfg blk
blk (BackingStore
  m
  (LedgerTables (ExtLedgerState blk) KeysMK)
  (TxIn (ExtLedgerState blk))
  (LedgerTables (ExtLedgerState blk) ValuesMK)
  (LedgerTables (ExtLedgerState blk) DiffMK)
-> KeySetsReader m (ExtLedgerState blk)
forall (m :: * -> *) (l :: LedgerStateKind).
IOLike m =>
LedgerBackingStore m l -> KeySetsReader m l
readKeySets BackingStore
  m
  (LedgerTables (ExtLedgerState blk) KeysMK)
  (TxIn (LedgerState blk))
  (LedgerTables (ExtLedgerState blk) ValuesMK)
  (LedgerTables (ExtLedgerState blk) DiffMK)
BackingStore
  m
  (LedgerTables (ExtLedgerState blk) KeysMK)
  (TxIn (ExtLedgerState blk))
  (LedgerTables (ExtLedgerState blk) ValuesMK)
  (LedgerTables (ExtLedgerState blk) DiffMK)
bstore) DbChangelog (ExtLedgerState blk)
chlog
        -- It's OK to flush without a lock here, since the `LedgerDB` has not
        -- finished initializing, only this thread has access to the backing
        -- store.
        chlog'' <-
          unsafeIgnoreWriteLock $
            if shouldFlush flushFreq (flushableLength chlog')
              then do
                let (toFlush, toKeep) = splitForFlushing chlog'
                mapM_ (flushIntoBackingStore bstore) toFlush
                pure toKeep
              else pure chlog'
        pure (chlog'', bstore)
    , currentTip :: (DbChangelog (ExtLedgerState blk),
 BackingStore
   m
   (LedgerTables (ExtLedgerState blk) KeysMK)
   (TxIn (LedgerState blk))
   (LedgerTables (ExtLedgerState blk) ValuesMK)
   (LedgerTables (ExtLedgerState blk) DiffMK))
-> LedgerState blk EmptyMK
currentTip = \(DbChangelog (ExtLedgerState blk)
ch, BackingStore
  m
  (LedgerTables (ExtLedgerState blk) KeysMK)
  (TxIn (LedgerState blk))
  (LedgerTables (ExtLedgerState blk) ValuesMK)
  (LedgerTables (ExtLedgerState blk) DiffMK)
_) -> ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState (ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK)
-> (DbChangelog (ExtLedgerState blk) -> ExtLedgerState blk EmptyMK)
-> DbChangelog (ExtLedgerState blk)
-> LedgerState blk EmptyMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbChangelog (ExtLedgerState blk) -> ExtLedgerState blk EmptyMK
forall (l :: LedgerStateKind).
GetTip l =>
DbChangelog l -> l EmptyMK
current (DbChangelog (ExtLedgerState blk) -> LedgerState blk EmptyMK)
-> DbChangelog (ExtLedgerState blk) -> LedgerState blk EmptyMK
forall a b. (a -> b) -> a -> b
$ DbChangelog (ExtLedgerState blk)
ch
    , mkLedgerDb :: (DbChangelog (ExtLedgerState blk),
 BackingStore
   m
   (LedgerTables (ExtLedgerState blk) KeysMK)
   (TxIn (LedgerState blk))
   (LedgerTables (ExtLedgerState blk) ValuesMK)
   (LedgerTables (ExtLedgerState blk) DiffMK))
-> m (LedgerDB m (ExtLedgerState blk) blk,
      TestInternals m (ExtLedgerState blk) blk)
mkLedgerDb = \(DbChangelog (ExtLedgerState blk)
db, BackingStore
  m
  (LedgerTables (ExtLedgerState blk) KeysMK)
  (TxIn (LedgerState blk))
  (LedgerTables (ExtLedgerState blk) ValuesMK)
  (LedgerTables (ExtLedgerState blk) DiffMK)
ldbBackingStore) -> do
        (varDB, prevApplied) <-
          (,) (StrictTVar m (DbChangelog (ExtLedgerState blk))
 -> StrictTVar m (Set (RealPoint blk))
 -> (StrictTVar m (DbChangelog (ExtLedgerState blk)),
     StrictTVar m (Set (RealPoint blk))))
-> m (StrictTVar m (DbChangelog (ExtLedgerState blk)))
-> m (StrictTVar m (Set (RealPoint blk))
      -> (StrictTVar m (DbChangelog (ExtLedgerState blk)),
          StrictTVar m (Set (RealPoint blk))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DbChangelog (ExtLedgerState blk)
-> m (StrictTVar m (DbChangelog (ExtLedgerState blk)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO DbChangelog (ExtLedgerState blk)
db m (StrictTVar m (Set (RealPoint blk))
   -> (StrictTVar m (DbChangelog (ExtLedgerState blk)),
       StrictTVar m (Set (RealPoint blk))))
-> m (StrictTVar m (Set (RealPoint blk)))
-> m (StrictTVar m (DbChangelog (ExtLedgerState blk)),
      StrictTVar m (Set (RealPoint blk)))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set (RealPoint blk) -> m (StrictTVar m (Set (RealPoint blk)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Set (RealPoint blk)
forall a. Set a
Set.empty
        flushLock <- mkLedgerDBLock
        nextForkerKey <- newTVarIO (ForkerKey 0)
        let env =
              LedgerDBEnv
                { ldbChangelog :: StrictTVar m (DbChangelog (ExtLedgerState blk))
ldbChangelog = StrictTVar m (DbChangelog (ExtLedgerState blk))
varDB
                , ldbBackingStore :: BackingStore
  m
  (LedgerTables (ExtLedgerState blk) KeysMK)
  (TxIn (ExtLedgerState blk))
  (LedgerTables (ExtLedgerState blk) ValuesMK)
  (LedgerTables (ExtLedgerState blk) DiffMK)
ldbBackingStore = BackingStore
  m
  (LedgerTables (ExtLedgerState blk) KeysMK)
  (TxIn (LedgerState blk))
  (LedgerTables (ExtLedgerState blk) ValuesMK)
  (LedgerTables (ExtLedgerState blk) DiffMK)
BackingStore
  m
  (LedgerTables (ExtLedgerState blk) KeysMK)
  (TxIn (ExtLedgerState blk))
  (LedgerTables (ExtLedgerState blk) ValuesMK)
  (LedgerTables (ExtLedgerState blk) DiffMK)
ldbBackingStore
                , ldbLock :: LedgerDBLock m
ldbLock = LedgerDBLock m
flushLock
                , ldbPrevApplied :: StrictTVar m (Set (RealPoint blk))
ldbPrevApplied = StrictTVar m (Set (RealPoint blk))
prevApplied
                , ldbNextForkerKey :: StrictTVar m ForkerKey
ldbNextForkerKey = StrictTVar m ForkerKey
nextForkerKey
                , ldbSnapshotPolicy :: SnapshotPolicy
ldbSnapshotPolicy = SecurityParam -> SnapshotPolicyArgs -> SnapshotPolicy
defaultSnapshotPolicy (LedgerDbCfg (ExtLedgerState blk) -> HKD Identity SecurityParam
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f SecurityParam
ledgerDbCfgSecParam LedgerDbCfg (ExtLedgerState blk)
lgrConfig) SnapshotPolicyArgs
lgrSnapshotPolicyArgs
                , ldbTracer :: Tracer m (TraceEvent blk)
ldbTracer = Tracer m (TraceEvent blk)
lgrTracer
                , ldbCfg :: LedgerDbCfg (ExtLedgerState blk)
ldbCfg = LedgerDbCfg (ExtLedgerState blk)
lgrConfig
                , ldbHasFS :: SnapshotsFS m
ldbHasFS = SnapshotsFS m
lgrHasFS'
                , ldbShouldFlush :: Word64 -> Bool
ldbShouldFlush = FlushFrequency -> Word64 -> Bool
shouldFlush FlushFrequency
flushFreq
                , ldbQueryBatchSize :: QueryBatchSize
ldbQueryBatchSize = QueryBatchSize
lgrQueryBatchSize
                , ldbResolveBlock :: ResolveBlock m blk
ldbResolveBlock = ResolveBlock m blk
getBlock
                , ldbGetVolatileSuffix :: GetVolatileSuffix m blk
ldbGetVolatileSuffix = GetVolatileSuffix m blk
getVolatileSuffix
                }
        h <- LDBHandle <$> newTVarIO (LedgerDBOpen env)
        pure $ implMkLedgerDb h snapManager
    }
 where
  !bsTracer :: Tracer m SomeBackendTrace
bsTracer = FlavorImplSpecificTrace -> TraceEvent blk
forall blk. FlavorImplSpecificTrace -> TraceEvent blk
LedgerDBFlavorImplEvent (FlavorImplSpecificTrace -> TraceEvent blk)
-> (SomeBackendTrace -> FlavorImplSpecificTrace)
-> SomeBackendTrace
-> TraceEvent blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeBackendTrace -> FlavorImplSpecificTrace
FlavorImplSpecificTraceV1 (SomeBackendTrace -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m SomeBackendTrace
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m (TraceEvent blk)
tr
  !tr :: Tracer m (TraceEvent blk)
tr = Tracer m (TraceEvent blk)
lgrTracer

  LedgerDbArgs
    { HKD Identity (SomeHasFS m)
lgrHasFS :: HKD Identity (SomeHasFS m)
lgrHasFS :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (SomeHasFS m)
lgrHasFS
    , Tracer m (TraceEvent blk)
lgrTracer :: Tracer m (TraceEvent blk)
lgrTracer :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> Tracer m (TraceEvent blk)
lgrTracer
    , SnapshotPolicyArgs
lgrSnapshotPolicyArgs :: SnapshotPolicyArgs
lgrSnapshotPolicyArgs :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> SnapshotPolicyArgs
lgrSnapshotPolicyArgs
    , LedgerDbCfg (ExtLedgerState blk)
lgrConfig :: LedgerDbCfg (ExtLedgerState blk)
lgrConfig :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> LedgerDbCfgF f (ExtLedgerState blk)
lgrConfig
    , HKD Identity (m (ExtLedgerState blk ValuesMK))
lgrGenesis :: HKD Identity (m (ExtLedgerState blk ValuesMK))
lgrGenesis :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> HKD f (m (ExtLedgerState blk ValuesMK))
lgrGenesis
    , QueryBatchSize
lgrQueryBatchSize :: QueryBatchSize
lgrQueryBatchSize :: forall (f :: * -> *) (m :: * -> *) blk.
LedgerDbArgs f m blk -> QueryBatchSize
lgrQueryBatchSize
    } = Complete LedgerDbArgs m blk
args

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

  V1Args FlushFrequency
flushFreq SomeBackendArgs m (ExtLedgerState blk)
baArgs = LedgerDbBackendArgs m (ExtLedgerState blk)
bss

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

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

implGetImmutableTip ::
  (MonadSTM m, GetTip l) =>
  LedgerDBEnv m l blk ->
  STM m (l EmptyMK)
implGetImmutableTip :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l) =>
LedgerDBEnv m l blk -> STM m (l EmptyMK)
implGetImmutableTip 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 (GetVolatileSuffix m blk
 -> forall s.
    Anchorable (WithOrigin SlotNo) s s =>
    STM
      m
      (AnchoredSeq (WithOrigin SlotNo) s s
       -> AnchoredSeq (WithOrigin SlotNo) s s))
-> GetVolatileSuffix m blk
-> forall s.
   Anchorable (WithOrigin SlotNo) s s =>
   STM
     m
     (AnchoredSeq (WithOrigin SlotNo) s s
      -> AnchoredSeq (WithOrigin SlotNo) s s)
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> GetVolatileSuffix m blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> GetVolatileSuffix m blk
ldbGetVolatileSuffix LedgerDBEnv m l blk
env
  -- The DbChangelog might contain more than k states if they have not yet
  -- been garbage-collected.
  fmap (AS.anchor . volSuffix . changelogStates)
    . readTVar
    $ ldbChangelog env

implGetPastLedgerState ::
  ( MonadSTM m
  , HasHeader blk
  , IsLedger l
  , StandardHash l
  , HasLedgerTables l
  , HeaderHash l ~ HeaderHash blk
  ) =>
  LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l EmptyMK))
implGetPastLedgerState :: forall (m :: * -> *) blk (l :: LedgerStateKind).
(MonadSTM m, HasHeader blk, IsLedger l, StandardHash l,
 HasLedgerTables l, HeaderHash l ~ HeaderHash blk) =>
LedgerDBEnv m l blk -> Point blk -> STM m (Maybe (l EmptyMK))
implGetPastLedgerState LedgerDBEnv m l blk
env Point blk
point = 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 (GetVolatileSuffix m blk
 -> forall s.
    Anchorable (WithOrigin SlotNo) s s =>
    STM
      m
      (AnchoredSeq (WithOrigin SlotNo) s s
       -> AnchoredSeq (WithOrigin SlotNo) s s))
-> GetVolatileSuffix m blk
-> forall s.
   Anchorable (WithOrigin SlotNo) s s =>
   STM
     m
     (AnchoredSeq (WithOrigin SlotNo) s s
      -> AnchoredSeq (WithOrigin SlotNo) s s)
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> GetVolatileSuffix m blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> GetVolatileSuffix m blk
ldbGetVolatileSuffix LedgerDBEnv m l blk
env
  readTVar (ldbChangelog env) <&> \DbChangelog l
chlog -> do
    -- The DbChangelog might contain more than k states if they have not yet
    -- been garbage-collected, so make sure that the point is volatile (or the
    -- immutable tip).
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$
      WithOrigin SlotNo
-> (Either (l EmptyMK) (l EmptyMK) -> Bool)
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
-> Bool
forall v a b.
Anchorable v a b =>
v -> (Either a b -> Bool) -> AnchoredSeq v a b -> Bool
AS.withinBounds
        (Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
point)
        ((Point blk
point Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
==) (Point blk -> Bool)
-> (Either (l EmptyMK) (l EmptyMK) -> Point blk)
-> Either (l EmptyMK) (l EmptyMK)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point l -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point l -> Point blk)
-> (Either (l EmptyMK) (l EmptyMK) -> Point l)
-> Either (l EmptyMK) (l EmptyMK)
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (l EmptyMK -> Point l)
-> (l EmptyMK -> Point l)
-> Either (l EmptyMK) (l EmptyMK)
-> Point l
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either l EmptyMK -> Point l
forall (mk :: MapKind). l mk -> Point l
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip l EmptyMK -> Point l
forall (mk :: MapKind). l mk -> Point l
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip)
        (AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
volSuffix (DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall (l :: LedgerStateKind).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates DbChangelog l
chlog))
    Point blk -> DbChangelog l -> Maybe (l EmptyMK)
forall blk (l :: LedgerStateKind).
(HasHeader blk, IsLedger l, HeaderHash l ~ HeaderHash blk,
 StandardHash l, HasLedgerTables l) =>
Point blk -> DbChangelog l -> Maybe (l EmptyMK)
getPastLedgerAt Point blk
point DbChangelog l
chlog

implGetHeaderStateHistory ::
  ( MonadSTM m
  , l ~ ExtLedgerState blk
  , IsLedger (LedgerState blk)
  , HasHardForkHistory blk
  , HasAnnTip blk
  ) =>
  LedgerDBEnv m l blk -> STM m (HeaderStateHistory blk)
implGetHeaderStateHistory :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, l ~ ExtLedgerState blk, IsLedger (LedgerState blk),
 HasHardForkHistory blk, HasAnnTip blk) =>
LedgerDBEnv m l blk -> STM m (HeaderStateHistory blk)
implGetHeaderStateHistory LedgerDBEnv m l blk
env = do
  ldb <- StrictTVar m (DbChangelog l) -> STM m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
env)
  volSuffix <- getVolatileSuffix $ ldbGetVolatileSuffix env
  let currentLedgerState = ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState (ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK)
-> ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall a b. (a -> b) -> a -> b
$ DbChangelog (ExtLedgerState blk) -> ExtLedgerState blk EmptyMK
forall (l :: LedgerStateKind).
GetTip l =>
DbChangelog l -> l EmptyMK
current DbChangelog (ExtLedgerState blk)
ldb
      -- This summary can convert all tip slots of the ledger states in the
      -- @ledgerDb@ as these are not newer than the tip slot of the current
      -- ledger state (Property 17.1 in the Consensus report).
      summary = 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 l -> HKD Identity (LedgerCfg l)
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
ledgerDbCfg (LedgerDbCfgF Identity l -> HKD Identity (LedgerCfg l))
-> LedgerDbCfgF Identity l -> HKD Identity (LedgerCfg l)
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> LedgerDbCfgF Identity l
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l
ldbCfg LedgerDBEnv m l blk
env) LedgerState blk EmptyMK
currentLedgerState
      mkHeaderStateWithTime' =
        Summary (HardForkIndices blk)
-> HeaderState blk -> HeaderStateWithTime blk
forall blk.
(HasCallStack, HasAnnTip blk) =>
Summary (HardForkIndices blk)
-> HeaderState blk -> HeaderStateWithTime blk
mkHeaderStateWithTimeFromSummary Summary (HardForkIndices blk)
summary
          (HeaderState blk -> HeaderStateWithTime blk)
-> (ExtLedgerState blk mk -> HeaderState blk)
-> ExtLedgerState blk mk
-> HeaderStateWithTime blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerState blk mk -> HeaderState blk
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> HeaderState blk
headerState
  pure
    . HeaderStateHistory
    . AS.bimap mkHeaderStateWithTime' mkHeaderStateWithTime'
    -- The DbChangelog might contain more than k states if they have not yet
    -- been garbage-collected, so only take the corresponding suffix.
    . volSuffix
    $ changelogStates ldb

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

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

-- | Remove 'DbChangelog' 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 ::
  ( MonadSTM m
  , IsLedger (LedgerState blk)
  , l ~ ExtLedgerState blk
  ) =>
  LedgerDBEnv m l blk -> SlotNo -> m ()
implGarbageCollect :: forall (m :: * -> *) blk (l :: LedgerStateKind).
(MonadSTM m, IsLedger (LedgerState blk), l ~ ExtLedgerState blk) =>
LedgerDBEnv m l blk -> SlotNo -> m ()
implGarbageCollect LedgerDBEnv m l blk
env SlotNo
slotNo = 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
$ do
  StrictTVar m (DbChangelog l)
-> (DbChangelog l -> DbChangelog l) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
env) ((DbChangelog l -> DbChangelog l) -> STM m ())
-> (DbChangelog l -> DbChangelog l) -> STM m ()
forall a b. (a -> b) -> a -> b
$
    LedgerDbPrune -> DbChangelog l -> DbChangelog l
forall (l :: LedgerStateKind).
GetTip l =>
LedgerDbPrune -> DbChangelog l -> DbChangelog l
prune (SlotNo -> LedgerDbPrune
LedgerDbPruneBeforeSlot SlotNo
slotNo)
  StrictTVar m (Set (RealPoint blk))
-> (Set (RealPoint blk) -> Set (RealPoint blk)) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
ldbPrevApplied LedgerDBEnv m l blk
env) ((Set (RealPoint blk) -> Set (RealPoint blk)) -> STM m ())
-> (Set (RealPoint blk) -> Set (RealPoint blk)) -> STM m ()
forall a b. (a -> b) -> a -> b
$
    (RealPoint blk -> Bool)
-> Set (RealPoint blk) -> Set (RealPoint blk)
forall a. (a -> Bool) -> Set a -> Set a
Set.dropWhileAntitone ((SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
slotNo) (SlotNo -> Bool)
-> (RealPoint blk -> SlotNo) -> RealPoint blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot)

implTryTakeSnapshot ::
  ( l ~ ExtLedgerState blk
  , IOLike m
  ) =>
  SnapshotManagerV1 m blk ->
  LedgerDBEnv m l blk ->
  m () ->
  Maybe (Time, Time) ->
  Word64 ->
  m SnapCounters
implTryTakeSnapshot :: forall (l :: LedgerStateKind) blk (m :: * -> *).
(l ~ ExtLedgerState blk, IOLike m) =>
SnapshotManagerV1 m blk
-> LedgerDBEnv m l blk
-> m ()
-> Maybe (Time, Time)
-> Word64
-> m SnapCounters
implTryTakeSnapshot SnapshotManagerV1 m blk
snapManager LedgerDBEnv m l blk
env m ()
copyBlocks Maybe (Time, Time)
mTime Word64
nrBlocks =
  if SnapshotPolicy -> Maybe DiffTime -> Word64 -> Bool
onDiskShouldTakeSnapshot (LedgerDBEnv m l blk -> SnapshotPolicy
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotPolicy
ldbSnapshotPolicy LedgerDBEnv m l blk
env) ((Time -> Time -> DiffTime) -> (Time, Time) -> DiffTime
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Time -> Time -> DiffTime) -> Time -> Time -> DiffTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip Time -> Time -> DiffTime
diffTime) ((Time, Time) -> DiffTime) -> Maybe (Time, Time) -> Maybe DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Time, Time)
mTime) Word64
nrBlocks
    then do
      m ()
copyBlocks
      m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (DiskSnapshot, RealPoint blk)) -> m ())
-> m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall a b. (a -> b) -> a -> b
$
        LedgerDBLock m
-> ReadLocked m (Maybe (DiskSnapshot, RealPoint blk))
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) a.
IOLike m =>
LedgerDBLock m -> ReadLocked m a -> m a
withReadLock
          (LedgerDBEnv m l blk -> LedgerDBLock m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDBLock m
ldbLock LedgerDBEnv m l blk
env)
          ( SnapshotManager
  m
  (ReadLocked m)
  blk
  (StrictTVar m (DbChangelog l),
   BackingStore
     m
     (LedgerTables (ExtLedgerState blk) KeysMK)
     (TxIn (LedgerState blk))
     (LedgerTables (ExtLedgerState blk) ValuesMK)
     (LedgerTables (ExtLedgerState blk) DiffMK))
-> Maybe String
-> (StrictTVar m (DbChangelog l),
    BackingStore
      m
      (LedgerTables (ExtLedgerState blk) KeysMK)
      (TxIn (LedgerState blk))
      (LedgerTables (ExtLedgerState blk) ValuesMK)
      (LedgerTables (ExtLedgerState blk) DiffMK))
-> ReadLocked m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) (n :: * -> *) blk st.
SnapshotManager m n blk st
-> Maybe String -> st -> n (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot
              SnapshotManager
  m
  (ReadLocked m)
  blk
  (StrictTVar m (DbChangelog l),
   BackingStore
     m
     (LedgerTables (ExtLedgerState blk) KeysMK)
     (TxIn (LedgerState blk))
     (LedgerTables (ExtLedgerState blk) ValuesMK)
     (LedgerTables (ExtLedgerState blk) DiffMK))
SnapshotManagerV1 m blk
snapManager
              Maybe String
forall a. Maybe a
Nothing
              (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
env, LedgerDBEnv m l blk -> LedgerBackingStore m l
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerBackingStore m l
ldbBackingStore LedgerDBEnv m l blk
env)
          )
      m [DiskSnapshot] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [DiskSnapshot] -> m ()) -> m [DiskSnapshot] -> m ()
forall a b. (a -> b) -> a -> b
$
        SnapshotManager
  m
  (ReadLocked m)
  blk
  (StrictTVar m (DbChangelog' blk),
   BackingStore
     m
     (LedgerTables (ExtLedgerState blk) KeysMK)
     (TxIn (LedgerState blk))
     (LedgerTables (ExtLedgerState blk) ValuesMK)
     (LedgerTables (ExtLedgerState blk) DiffMK))
-> SnapshotPolicy -> m [DiskSnapshot]
forall (m :: * -> *) (n :: * -> *) blk st.
Monad m =>
SnapshotManager m n blk st -> SnapshotPolicy -> m [DiskSnapshot]
trimSnapshots
          SnapshotManager
  m
  (ReadLocked m)
  blk
  (StrictTVar m (DbChangelog' blk),
   BackingStore
     m
     (LedgerTables (ExtLedgerState blk) KeysMK)
     (TxIn (LedgerState blk))
     (LedgerTables (ExtLedgerState blk) ValuesMK)
     (LedgerTables (ExtLedgerState blk) DiffMK))
SnapshotManagerV1 m blk
snapManager
          (LedgerDBEnv m l blk -> SnapshotPolicy
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotPolicy
ldbSnapshotPolicy LedgerDBEnv m l blk
env)
      (Maybe Time -> Word64 -> SnapCounters
`SnapCounters` Word64
0) (Maybe Time -> SnapCounters)
-> (Time -> Maybe Time) -> Time -> SnapCounters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time -> Maybe Time
forall a. a -> Maybe a
Just (Time -> SnapCounters) -> m Time -> m SnapCounters
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Time -> ((Time, Time) -> m Time) -> Maybe (Time, Time) -> m Time
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime (Time -> m Time
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> m Time)
-> ((Time, Time) -> Time) -> (Time, Time) -> m Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, Time) -> Time
forall a b. (a, b) -> b
snd) Maybe (Time, Time)
mTime
    else
      SnapCounters -> m SnapCounters
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapCounters -> m SnapCounters) -> SnapCounters -> m SnapCounters
forall a b. (a -> b) -> a -> b
$ Maybe Time -> Word64 -> SnapCounters
SnapCounters ((Time, Time) -> Time
forall a b. (a, b) -> a
fst ((Time, Time) -> Time) -> Maybe (Time, Time) -> Maybe Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Time, Time)
mTime) Word64
nrBlocks

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

implCloseDB :: IOLike m => LedgerDBHandle m l blk -> m ()
implCloseDB :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
IOLike m =>
LedgerDBHandle m l blk -> m ()
implCloseDB (LDBHandle StrictTVar m (LedgerDBState m l blk)
varState) = do
  mbOpenEnv <-
    STM m (Maybe (LedgerDBEnv m l blk))
-> m (Maybe (LedgerDBEnv m l blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (LedgerDBEnv m l blk))
 -> m (Maybe (LedgerDBEnv m l blk)))
-> STM m (Maybe (LedgerDBEnv m l blk))
-> m (Maybe (LedgerDBEnv m l blk))
forall a b. (a -> b) -> a -> b
$
      StrictTVar m (LedgerDBState m l blk)
-> STM m (LedgerDBState m l blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (LedgerDBState m l blk)
varState STM m (LedgerDBState m l blk)
-> (LedgerDBState m l blk -> STM m (Maybe (LedgerDBEnv m l blk)))
-> STM m (Maybe (LedgerDBEnv m l blk))
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- Idempotent
        LedgerDBState m l blk
LedgerDBClosed -> Maybe (LedgerDBEnv m l blk) -> STM m (Maybe (LedgerDBEnv m l blk))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LedgerDBEnv m l blk)
forall a. Maybe a
Nothing
        LedgerDBOpen LedgerDBEnv m l blk
env -> do
          -- By writing this tvar, we already make sure that no
          -- forkers can perform operations other than closing, as
          -- they rely on accessing the LedgerDB, which is now closed.
          StrictTVar m (LedgerDBState m l blk)
-> LedgerDBState m l blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (LedgerDBState m l blk)
varState LedgerDBState m l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBState m l blk
LedgerDBClosed
          Maybe (LedgerDBEnv m l blk) -> STM m (Maybe (LedgerDBEnv m l blk))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (LedgerDBEnv m l blk)
 -> STM m (Maybe (LedgerDBEnv m l blk)))
-> Maybe (LedgerDBEnv m l blk)
-> STM m (Maybe (LedgerDBEnv m l blk))
forall a b. (a -> b) -> a -> b
$ LedgerDBEnv m l blk -> Maybe (LedgerDBEnv m l blk)
forall a. a -> Maybe a
Just LedgerDBEnv m l blk
env

  -- Only when the LedgerDB was open
  whenJust mbOpenEnv $ void . bsClose . ldbBackingStore

mkInternals ::
  ( IOLike m
  , LedgerDbSerialiseConstraints blk
  , LedgerSupportsProtocol blk
  ) =>
  LedgerDBHandle m (ExtLedgerState blk) blk ->
  SnapshotManagerV1 m blk ->
  TestInternals' m blk
mkInternals :: forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk) =>
LedgerDBHandle m (ExtLedgerState blk) blk
-> SnapshotManagerV1 m blk -> TestInternals' m blk
mkInternals LedgerDBHandle m (ExtLedgerState blk) blk
h SnapshotManagerV1 m blk
snapManager =
  TestInternals
    { takeSnapshotNOW :: WhereToTakeSnapshot -> Maybe String -> m ()
takeSnapshotNOW = LedgerDBHandle m (ExtLedgerState blk) blk
-> (LedgerDBEnv m (ExtLedgerState blk) blk
    -> WhereToTakeSnapshot -> Maybe String -> m ())
-> WhereToTakeSnapshot
-> Maybe String
-> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk a b r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> b -> m r) -> a -> b -> m r
getEnv2 LedgerDBHandle m (ExtLedgerState blk) blk
h (SnapshotManagerV1 m blk
-> LedgerDBEnv m (ExtLedgerState blk) blk
-> WhereToTakeSnapshot
-> Maybe String
-> m ()
forall (m :: * -> *) blk (l :: LedgerStateKind).
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk, l ~ ExtLedgerState blk) =>
SnapshotManagerV1 m blk
-> LedgerDBEnv m l blk
-> WhereToTakeSnapshot
-> Maybe String
-> m ()
implIntTakeSnapshot SnapshotManagerV1 m blk
snapManager)
    , wipeLedgerDB :: m ()
wipeLedgerDB = m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ SnapshotManager
  m
  (ReadLocked m)
  blk
  (StrictTVar m (DbChangelog' blk),
   BackingStore
     m
     (LedgerTables (ExtLedgerState blk) KeysMK)
     (TxIn (LedgerState blk))
     (LedgerTables (ExtLedgerState blk) ValuesMK)
     (LedgerTables (ExtLedgerState blk) DiffMK))
-> m ()
forall (m :: * -> *) (n :: * -> *) blk st.
Monad m =>
SnapshotManager m n blk st -> m ()
destroySnapshots SnapshotManager
  m
  (ReadLocked m)
  blk
  (StrictTVar m (DbChangelog' blk),
   BackingStore
     m
     (LedgerTables (ExtLedgerState blk) KeysMK)
     (TxIn (LedgerState blk))
     (LedgerTables (ExtLedgerState blk) ValuesMK)
     (LedgerTables (ExtLedgerState blk) DiffMK))
SnapshotManagerV1 m blk
snapManager
    , truncateSnapshots :: m ()
truncateSnapshots = LedgerDBHandle m (ExtLedgerState blk) blk
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m (ExtLedgerState blk) blk
h ((LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ())
-> LedgerDBEnv m (ExtLedgerState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapshotsFS m -> m ()
forall (m :: * -> *). MonadThrow m => SnapshotsFS m -> m ()
implIntTruncateSnapshots (SnapshotsFS m -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> SnapshotsFS m)
-> LedgerDBEnv m (ExtLedgerState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBEnv m (ExtLedgerState blk) blk -> SnapshotsFS m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotsFS m
ldbHasFS
    , push :: ExtLedgerState blk DiffMK -> m ()
push = LedgerDBHandle m (ExtLedgerState blk) blk
-> (LedgerDBEnv m (ExtLedgerState blk) blk
    -> ExtLedgerState blk DiffMK -> m ())
-> ExtLedgerState blk DiffMK
-> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk a r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> m r) -> a -> m r
getEnv1 LedgerDBHandle m (ExtLedgerState blk) blk
h LedgerDBEnv m (ExtLedgerState blk) blk
-> ExtLedgerState blk DiffMK -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, ApplyBlock l blk, l ~ ExtLedgerState blk) =>
LedgerDBEnv m l blk -> l DiffMK -> m ()
implIntPush
    , reapplyThenPushNOW :: blk -> m ()
reapplyThenPushNOW = LedgerDBHandle m (ExtLedgerState blk) blk
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> blk -> m ())
-> blk
-> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk a r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> m r) -> a -> m r
getEnv1 LedgerDBHandle m (ExtLedgerState blk) blk
h LedgerDBEnv m (ExtLedgerState blk) blk -> blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, ApplyBlock l blk, l ~ ExtLedgerState blk) =>
LedgerDBEnv m l blk -> blk -> m ()
implIntReapplyThenPush
    , closeLedgerDB :: m ()
closeLedgerDB = LedgerDBHandle m (ExtLedgerState blk) blk
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m (ExtLedgerState blk) blk
h ((LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk -> m ())
-> LedgerDBEnv m (ExtLedgerState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BackingStore
  m
  (LedgerTables (ExtLedgerState blk) KeysMK)
  (TxIn (LedgerState blk))
  (LedgerTables (ExtLedgerState blk) ValuesMK)
  (LedgerTables (ExtLedgerState blk) DiffMK)
-> m ()
forall (m :: * -> *) keys key values diff.
BackingStore m keys key values diff -> m ()
bsClose (BackingStore
   m
   (LedgerTables (ExtLedgerState blk) KeysMK)
   (TxIn (LedgerState blk))
   (LedgerTables (ExtLedgerState blk) ValuesMK)
   (LedgerTables (ExtLedgerState blk) DiffMK)
 -> m ())
-> (LedgerDBEnv m (ExtLedgerState blk) blk
    -> BackingStore
         m
         (LedgerTables (ExtLedgerState blk) KeysMK)
         (TxIn (LedgerState blk))
         (LedgerTables (ExtLedgerState blk) ValuesMK)
         (LedgerTables (ExtLedgerState blk) DiffMK))
-> LedgerDBEnv m (ExtLedgerState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDBEnv m (ExtLedgerState blk) blk
-> BackingStore
     m
     (LedgerTables (ExtLedgerState blk) KeysMK)
     (TxIn (LedgerState blk))
     (LedgerTables (ExtLedgerState blk) ValuesMK)
     (LedgerTables (ExtLedgerState blk) DiffMK)
LedgerDBEnv m (ExtLedgerState blk) blk
-> LedgerBackingStore m (ExtLedgerState blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerBackingStore m l
ldbBackingStore
    , getNumLedgerTablesHandles :: m Word64
getNumLedgerTablesHandles = Word64 -> m Word64
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
0
    }

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

implIntTakeSnapshot ::
  ( IOLike m
  , LedgerDbSerialiseConstraints blk
  , LedgerSupportsProtocol blk
  , l ~ ExtLedgerState blk
  ) =>
  SnapshotManagerV1 m blk ->
  LedgerDBEnv m l blk ->
  WhereToTakeSnapshot ->
  Maybe String ->
  m ()
implIntTakeSnapshot :: forall (m :: * -> *) blk (l :: LedgerStateKind).
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk, l ~ ExtLedgerState blk) =>
SnapshotManagerV1 m blk
-> LedgerDBEnv m l blk
-> WhereToTakeSnapshot
-> Maybe String
-> m ()
implIntTakeSnapshot SnapshotManagerV1 m blk
snapManager LedgerDBEnv m l blk
env WhereToTakeSnapshot
whereTo Maybe String
suffix = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WhereToTakeSnapshot
whereTo WhereToTakeSnapshot -> WhereToTakeSnapshot -> Bool
forall a. Eq a => a -> a -> Bool
== WhereToTakeSnapshot
TakeAtVolatileTip) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (DbChangelog l)
-> (DbChangelog l -> DbChangelog l) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
env) DbChangelog l -> DbChangelog l
forall (l :: LedgerStateKind).
GetTip l =>
DbChangelog l -> DbChangelog l
pruneToImmTipOnly
  LedgerDBLock m -> WriteLocked m () -> m ()
forall (m :: * -> *) a.
IOLike m =>
LedgerDBLock m -> WriteLocked m a -> m a
withWriteLock
    (LedgerDBEnv m l blk -> LedgerDBLock m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDBLock m
ldbLock LedgerDBEnv m l blk
env)
    (StrictTVar m (DbChangelog l)
-> LedgerBackingStore m l -> WriteLocked m ()
forall (m :: * -> *) (l :: LedgerStateKind).
(MonadSTM m, GetTip l, HasLedgerTables l) =>
StrictTVar m (DbChangelog l)
-> LedgerBackingStore m l -> WriteLocked m ()
flushLedgerDB (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
env) (LedgerDBEnv m l blk -> LedgerBackingStore m l
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerBackingStore m l
ldbBackingStore LedgerDBEnv m l blk
env))
  m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (DiskSnapshot, RealPoint blk)) -> m ())
-> m (Maybe (DiskSnapshot, RealPoint blk)) -> m ()
forall a b. (a -> b) -> a -> b
$
    LedgerDBLock m
-> ReadLocked m (Maybe (DiskSnapshot, RealPoint blk))
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) a.
IOLike m =>
LedgerDBLock m -> ReadLocked m a -> m a
withReadLock (LedgerDBEnv m l blk -> LedgerDBLock m
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDBLock m
ldbLock LedgerDBEnv m l blk
env) (ReadLocked m (Maybe (DiskSnapshot, RealPoint blk))
 -> m (Maybe (DiskSnapshot, RealPoint blk)))
-> ReadLocked m (Maybe (DiskSnapshot, RealPoint blk))
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall a b. (a -> b) -> a -> b
$
      SnapshotManager
  m
  (ReadLocked m)
  blk
  (StrictTVar m (DbChangelog l),
   BackingStore
     m
     (LedgerTables (ExtLedgerState blk) KeysMK)
     (TxIn (LedgerState blk))
     (LedgerTables (ExtLedgerState blk) ValuesMK)
     (LedgerTables (ExtLedgerState blk) DiffMK))
-> Maybe String
-> (StrictTVar m (DbChangelog l),
    BackingStore
      m
      (LedgerTables (ExtLedgerState blk) KeysMK)
      (TxIn (LedgerState blk))
      (LedgerTables (ExtLedgerState blk) ValuesMK)
      (LedgerTables (ExtLedgerState blk) DiffMK))
-> ReadLocked m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) (n :: * -> *) blk st.
SnapshotManager m n blk st
-> Maybe String -> st -> n (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot
        SnapshotManager
  m
  (ReadLocked m)
  blk
  (StrictTVar m (DbChangelog l),
   BackingStore
     m
     (LedgerTables (ExtLedgerState blk) KeysMK)
     (TxIn (LedgerState blk))
     (LedgerTables (ExtLedgerState blk) ValuesMK)
     (LedgerTables (ExtLedgerState blk) DiffMK))
SnapshotManagerV1 m blk
snapManager
        Maybe String
suffix
        (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
env, LedgerDBEnv m l blk -> LedgerBackingStore m l
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerBackingStore m l
ldbBackingStore LedgerDBEnv m l blk
env)

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

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

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

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

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

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

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

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

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

type LedgerDBEnv :: (Type -> Type) -> LedgerStateKind -> Type -> Type
data LedgerDBEnv m l blk = LedgerDBEnv
  { forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog :: !(StrictTVar m (DbChangelog l))
  -- ^ INVARIANT: the tip of the 'LedgerDB' is always in sync with the tip of
  -- the current chain of the ChainDB.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerBackingStore m l
ldbBackingStore :: !(LedgerBackingStore m l)
  -- ^ Handle to the ledger's backing store, containing the parts that grow too
  -- big for in-memory residency
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDBLock m
ldbLock :: !(LedgerDBLock m)
  -- ^ The flush lock to the 'BackingStore'. This lock is crucial when it
  -- comes to keeping the data in memory consistent with the data on-disk.
  --
  -- This lock should be held whenever we want to keep a consistent view of
  -- the backing store for some time. In particular we use this:
  --
  -- - when performing a query on the ledger state, we need to hold a
  --   'LocalStateQueryView' which, while live, must maintain a consistent view
  --   of the DB, and therefore we acquire a Read lock.
  --
  -- - when taking a snapshot of the ledger db, we need to prevent others (eg
  --   ChainSel) from altering the backing store at the same time, thus we
  --   acquire a Write lock.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (Set (RealPoint blk))
ldbPrevApplied :: !(StrictTVar m (Set (RealPoint blk)))
  -- ^ INVARIANT: this set contains only points that are in the
  -- VolatileDB.
  --
  -- INVARIANT: all points on the current chain fragment are in this set.
  --
  -- The VolatileDB might contain invalid blocks, these will not be in
  -- this set.
  --
  -- When a garbage-collection is performed on the VolatileDB, the points
  -- of the blocks eligible for garbage-collection should be removed from
  -- this set.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m ForkerKey
ldbNextForkerKey :: !(StrictTVar m ForkerKey)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotPolicy
ldbSnapshotPolicy :: !SnapshotPolicy
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> Tracer m (TraceEvent blk)
ldbTracer :: !(Tracer m (TraceEvent blk))
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> LedgerDbCfg l
ldbCfg :: !(LedgerDbCfg l)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotsFS m
ldbHasFS :: !(SnapshotsFS m)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> Word64 -> Bool
ldbShouldFlush :: !(Word64 -> Bool)
  -- ^ Determine whether we should flush depending on the number of flushable
  -- diffs that we currently have in the LedgerDB, based on the flush
  -- frequency that was provided when opening the LedgerDB.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> QueryBatchSize
ldbQueryBatchSize :: !QueryBatchSize
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> ResolveBlock m blk
ldbResolveBlock :: !(ResolveBlock m blk)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> GetVolatileSuffix m blk
ldbGetVolatileSuffix :: !(GetVolatileSuffix m blk)
  }
  deriving (forall x. LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x)
-> (forall x. Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk)
-> Generic (LedgerDBEnv m l blk)
forall x. Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
forall x. LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) (l :: LedgerStateKind) blk x.
Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk x.
LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
$cfrom :: forall (m :: * -> *) (l :: LedgerStateKind) blk x.
LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
from :: forall x. LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
$cto :: forall (m :: * -> *) (l :: LedgerStateKind) blk x.
Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
to :: forall x. Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
Generic

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

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

-- | Variant 'of 'getEnv' for functions taking one argument.
getEnv1 ::
  (IOLike m, HasCallStack) =>
  LedgerDBHandle m l blk ->
  (LedgerDBEnv m l blk -> a -> m r) ->
  a ->
  m r
getEnv1 :: forall (m :: * -> *) (l :: LedgerStateKind) blk a r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> a -> m r) -> a -> m r
getEnv1 LedgerDBHandle m l blk
h LedgerDBEnv m l blk -> a -> m r
f a
a = LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m l blk
h (LedgerDBEnv m l blk -> a -> m r
`f` a
a)

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

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

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

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

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

-- | Will call 'error' if the point is not on the LedgerDB
openNewForkerAtTarget ::
  ( HeaderHash l ~ HeaderHash blk
  , IOLike m
  , IsLedger l
  , StandardHash l
  , HasLedgerTables l
  , LedgerSupportsProtocol blk
  ) =>
  LedgerDBHandle m l blk ->
  Target (Point blk) ->
  m (Either GetForkerError (Forker m l))
openNewForkerAtTarget :: forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBHandle m l blk
-> Target (Point blk) -> m (Either GetForkerError (Forker m l))
openNewForkerAtTarget LedgerDBHandle m l blk
h Target (Point blk)
pt = LedgerDBHandle m l blk
-> Either Word64 (Target (Point blk))
-> m (Either GetForkerError (Forker m l))
forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBHandle m l blk
-> Either Word64 (Target (Point blk))
-> m (Either GetForkerError (Forker m l))
withTransferrableReadAccess LedgerDBHandle m l blk
h (Target (Point blk) -> Either Word64 (Target (Point blk))
forall a b. b -> Either a b
Right Target (Point blk)
pt)

withForkerByRollback ::
  ( HeaderHash l ~ HeaderHash blk
  , IOLike m
  , IsLedger l
  , StandardHash l
  , HasLedgerTables l
  , LedgerSupportsProtocol blk
  ) =>
  LedgerDBHandle m l blk ->
  -- | How many blocks to rollback from the tip
  Word64 ->
  (Forker m l -> m r) ->
  m (Either GetForkerError r)
withForkerByRollback :: forall (l :: LedgerStateKind) blk (m :: * -> *) r.
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBHandle m l blk
-> Word64 -> (Forker m l -> m r) -> m (Either GetForkerError r)
withForkerByRollback LedgerDBHandle m l blk
h Word64
n Forker m l -> m r
k =
  m (Either GetForkerError (Forker m l))
-> (Either GetForkerError (Forker m l) -> m ())
-> (Either GetForkerError (Forker m l)
    -> m (Either GetForkerError r))
-> m (Either GetForkerError r)
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
    (LedgerDBHandle m l blk
-> Either Word64 (Target (Point blk))
-> m (Either GetForkerError (Forker m l))
forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBHandle m l blk
-> Either Word64 (Target (Point blk))
-> m (Either GetForkerError (Forker m l))
withTransferrableReadAccess LedgerDBHandle m l blk
h (Word64 -> Either Word64 (Target (Point blk))
forall a b. a -> Either a b
Left Word64
n))
    ((GetForkerError -> m ())
-> (Forker m l -> m ())
-> Either GetForkerError (Forker m l)
-> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m () -> GetForkerError -> m ()
forall a b. a -> b -> a
const (m () -> GetForkerError -> m ()) -> m () -> GetForkerError -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Forker m l -> m ()
forall (m :: * -> *) (l :: LedgerStateKind). Forker m l -> m ()
forkerClose)
    ((GetForkerError -> m (Either GetForkerError r))
-> (Forker m l -> m (Either GetForkerError r))
-> Either GetForkerError (Forker m l)
-> m (Either GetForkerError r)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either GetForkerError r -> m (Either GetForkerError r)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either GetForkerError r -> m (Either GetForkerError r))
-> (GetForkerError -> Either GetForkerError r)
-> GetForkerError
-> m (Either GetForkerError r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GetForkerError -> Either GetForkerError r
forall a b. a -> Either a b
Left) ((r -> Either GetForkerError r)
-> m r -> m (Either GetForkerError r)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r -> Either GetForkerError r
forall a b. b -> Either a b
Right (m r -> m (Either GetForkerError r))
-> (Forker m l -> m r) -> Forker m l -> m (Either GetForkerError r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forker m l -> m r
k))

-- | Acquire read access and then allocate a forker, acquiring it at the given
-- point or rollback.
withTransferrableReadAccess ::
  ( HeaderHash l ~ HeaderHash blk
  , IOLike m
  , IsLedger l
  , StandardHash l
  , HasLedgerTables l
  , LedgerSupportsProtocol blk
  ) =>
  LedgerDBHandle m l blk ->
  Either Word64 (Target (Point blk)) ->
  m (Either GetForkerError (Forker m l))
withTransferrableReadAccess :: forall (l :: LedgerStateKind) blk (m :: * -> *).
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBHandle m l blk
-> Either Word64 (Target (Point blk))
-> m (Either GetForkerError (Forker m l))
withTransferrableReadAccess LedgerDBHandle m l blk
h Either Word64 (Target (Point blk))
f = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk -> m (Either GetForkerError (Forker m l)))
-> m (Either GetForkerError (Forker m l))
forall (m :: * -> *) (l :: LedgerStateKind) blk r.
(IOLike m, HasCallStack) =>
LedgerDBHandle m l blk -> (LedgerDBEnv m l blk -> m r) -> m r
getEnv LedgerDBHandle m l blk
h ((LedgerDBEnv m l blk -> m (Either GetForkerError (Forker m l)))
 -> m (Either GetForkerError (Forker m l)))
-> (LedgerDBEnv m l blk -> m (Either GetForkerError (Forker m l)))
-> m (Either GetForkerError (Forker m l))
forall a b. (a -> b) -> a -> b
$ \LedgerDBEnv m l blk
ldbEnv -> do
  -- This TVar will be used to maybe release the read lock by the resource
  -- registry. Once the forker was opened it will be emptied.
  m (StrictTVar m (m ()))
-> (StrictTVar m (m ()) -> m ())
-> (StrictTVar m (m ()) -> m (Either GetForkerError (Forker m l)))
-> m (Either GetForkerError (Forker m l))
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
    ( do
        tv <- m () -> m (StrictTVar m (m ()))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        atomically $ do
          -- Populate the tvar with the releasing action. Creating the forker will empty this
          writeTVar tv (atomically $ unsafeReleaseReadAccess (ldbLock ldbEnv))
          -- Acquire the read access
          unsafeAcquireReadAccess (ldbLock ldbEnv)
        pure tv
    )
    (m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ())
-> (StrictTVar m (m ()) -> m (m ())) -> StrictTVar m (m ()) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictTVar m (m ()) -> m (m ())
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO)
    ( \StrictTVar m (m ())
tv ->
        ReadLocked m (Either GetForkerError (Forker m l))
-> m (Either GetForkerError (Forker m l))
forall (m :: * -> *) a. ReadLocked m a -> m a
unsafeRunReadLocked
          ( LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> ReadLocked m (Either GetForkerError (DbChangelog l))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> ReadLocked m (Either GetForkerError (DbChangelog l))
unsafeAcquireAtTarget LedgerDBEnv m l blk
ldbEnv Either Word64 (Target (Point blk))
f
              ReadLocked m (Either GetForkerError (DbChangelog l))
-> (Either GetForkerError (DbChangelog l)
    -> ReadLocked m (Either GetForkerError (Forker m l)))
-> ReadLocked m (Either GetForkerError (Forker m l))
forall a b.
ReadLocked m a -> (a -> ReadLocked m b) -> ReadLocked m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left GetForkerError
err -> do
                  Either GetForkerError (Forker m l)
-> ReadLocked m (Either GetForkerError (Forker m l))
forall a. a -> ReadLocked m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GetForkerError -> Either GetForkerError (Forker m l)
forall a b. a -> Either a b
Left GetForkerError
err)
                Right DbChangelog l
chlog -> do
                  Forker m l -> Either GetForkerError (Forker m l)
forall a b. b -> Either a b
Right (Forker m l -> Either GetForkerError (Forker m l))
-> ReadLocked m (Forker m l)
-> ReadLocked m (Either GetForkerError (Forker m l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerDBEnv m l blk
-> StrictTVar m (m ())
-> DbChangelog l
-> ReadLocked m (Forker m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasLedgerTables l, NoThunks (l EmptyMK), GetTip l,
 StandardHash l) =>
LedgerDBEnv m l blk
-> StrictTVar m (m ())
-> DbChangelog l
-> ReadLocked m (Forker m l)
newForker LedgerDBEnv m l blk
ldbEnv StrictTVar m (m ())
tv DbChangelog l
chlog
          )
    )

-- | Acquire both a value handle and a db changelog at the tip. Holds a read lock
-- while doing so.
unsafeAcquireAtTarget ::
  forall m l blk.
  ( HeaderHash l ~ HeaderHash blk
  , IOLike m
  , IsLedger l
  , StandardHash l
  , HasLedgerTables l
  , LedgerSupportsProtocol blk
  ) =>
  LedgerDBEnv m l blk ->
  Either Word64 (Target (Point blk)) ->
  ReadLocked m (Either GetForkerError (DbChangelog l))
unsafeAcquireAtTarget :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(HeaderHash l ~ HeaderHash blk, IOLike m, IsLedger l,
 StandardHash l, HasLedgerTables l, LedgerSupportsProtocol blk) =>
LedgerDBEnv m l blk
-> Either Word64 (Target (Point blk))
-> ReadLocked m (Either GetForkerError (DbChangelog l))
unsafeAcquireAtTarget LedgerDBEnv m l blk
ldbEnv Either Word64 (Target (Point blk))
target = m (Either GetForkerError (DbChangelog l))
-> ReadLocked m (Either GetForkerError (DbChangelog l))
forall (m :: * -> *) a. m a -> ReadLocked m a
readLocked (m (Either GetForkerError (DbChangelog l))
 -> ReadLocked m (Either GetForkerError (DbChangelog l)))
-> m (Either GetForkerError (DbChangelog l))
-> ReadLocked m (Either GetForkerError (DbChangelog l))
forall a b. (a -> b) -> a -> b
$ ExceptT GetForkerError m (DbChangelog l)
-> m (Either GetForkerError (DbChangelog l))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT GetForkerError m (DbChangelog l)
 -> m (Either GetForkerError (DbChangelog l)))
-> ExceptT GetForkerError m (DbChangelog l)
-> m (Either GetForkerError (DbChangelog l))
forall a b. (a -> b) -> a -> b
$ do
  (dblog, volStates) <- m (DbChangelog l,
   AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> ExceptT
     GetForkerError
     m
     (DbChangelog l,
      AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT GetForkerError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (DbChangelog l,
    AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
 -> ExceptT
      GetForkerError
      m
      (DbChangelog l,
       AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)))
-> m (DbChangelog l,
      AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> ExceptT
     GetForkerError
     m
     (DbChangelog l,
      AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
forall a b. (a -> b) -> a -> b
$ STM
  m
  (DbChangelog l,
   AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> m (DbChangelog l,
      AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (DbChangelog l,
    AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
 -> m (DbChangelog l,
       AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)))
-> STM
     m
     (DbChangelog l,
      AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> m (DbChangelog l,
      AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
forall a b. (a -> b) -> a -> b
$ do
    dblog <- StrictTVar m (DbChangelog l) -> STM m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
ldbEnv)
    -- The DbChangelog might contain more than k states if they have not yet
    -- been garbage-collected.
    volSuffix <- getVolatileSuffix $ ldbGetVolatileSuffix ldbEnv
    pure (dblog, volSuffix $ changelogStates dblog)

  let immTip :: Point blk
      immTip = Point l -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point l -> Point blk) -> Point l -> Point blk
forall a b. (a -> b) -> a -> b
$ l EmptyMK -> Point l
forall (mk :: MapKind). l mk -> Point l
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip (l EmptyMK -> Point l) -> l EmptyMK -> Point l
forall a b. (a -> b) -> a -> b
$ AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
-> l EmptyMK
forall v a b. AnchoredSeq v a b -> a
AS.anchor AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
volStates

      rollbackMax :: Word64
      rollbackMax = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK) -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AS.length AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
volStates

      rollbackTo Point blk
pt
        | 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 blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
immTip = GetForkerError -> m (DbChangelog l)
forall a. GetForkerError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GetForkerError -> m (DbChangelog l))
-> GetForkerError -> m (DbChangelog l)
forall a b. (a -> b) -> a -> b
$ Maybe ExceededRollback -> GetForkerError
PointTooOld Maybe ExceededRollback
forall a. Maybe a
Nothing
        | Bool
otherwise = case Point blk -> DbChangelog l -> Maybe (DbChangelog l)
forall blk (l :: LedgerStateKind).
(HasHeader blk, IsLedger l, HeaderHash l ~ HeaderHash blk,
 StandardHash l, HasLedgerTables l) =>
Point blk -> DbChangelog l -> Maybe (DbChangelog l)
rollback Point blk
pt DbChangelog l
dblog of
            Maybe (DbChangelog l)
Nothing -> GetForkerError -> m (DbChangelog l)
forall a. GetForkerError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GetForkerError
PointNotOnChain
            Just DbChangelog l
dblog' -> DbChangelog l -> m (DbChangelog l)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DbChangelog l
dblog'
  -- Get the prefix of the dblog ending in the specified target.
  case target of
    Right Target (Point blk)
VolatileTip -> DbChangelog l -> ExceptT GetForkerError m (DbChangelog l)
forall a. a -> ExceptT GetForkerError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DbChangelog l
dblog
    Right Target (Point blk)
ImmutableTip -> Point blk -> ExceptT GetForkerError m (DbChangelog l)
forall {blk} {m :: * -> *}.
(HeaderHash blk ~ HeaderHash l, MonadError GetForkerError m,
 HasHeader blk) =>
Point blk -> m (DbChangelog l)
rollbackTo Point blk
immTip
    Right (SpecificPoint Point blk
pt) -> Point blk -> ExceptT GetForkerError m (DbChangelog l)
forall {blk} {m :: * -> *}.
(HeaderHash blk ~ HeaderHash l, MonadError GetForkerError m,
 HasHeader blk) =>
Point blk -> m (DbChangelog l)
rollbackTo Point blk
pt
    Left Word64
n -> do
      Bool -> ExceptT GetForkerError m () -> ExceptT GetForkerError m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
rollbackMax) (ExceptT GetForkerError m () -> ExceptT GetForkerError m ())
-> ExceptT GetForkerError m () -> ExceptT GetForkerError m ()
forall a b. (a -> b) -> a -> b
$
        GetForkerError -> ExceptT GetForkerError m ()
forall a. GetForkerError -> ExceptT GetForkerError m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GetForkerError -> ExceptT GetForkerError m ())
-> GetForkerError -> ExceptT GetForkerError m ()
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 = Word64
rollbackMax
                , rollbackRequested :: Word64
rollbackRequested = Word64
n
                }
      case Word64 -> DbChangelog l -> Maybe (DbChangelog l)
forall (l :: LedgerStateKind).
(GetTip l, HasLedgerTables l) =>
Word64 -> DbChangelog l -> Maybe (DbChangelog l)
rollbackN Word64
n DbChangelog l
dblog of
        Maybe (DbChangelog l)
Nothing -> String -> ExceptT GetForkerError m (DbChangelog l)
forall a. HasCallStack => String -> a
error String
"unreachable"
        Just DbChangelog l
dblog' -> DbChangelog l -> ExceptT GetForkerError m (DbChangelog l)
forall a. a -> ExceptT GetForkerError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DbChangelog l
dblog'

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

newForker ::
  forall m l blk.
  ( IOLike m
  , HasLedgerTables l
  , NoThunks (l EmptyMK)
  , GetTip l
  , StandardHash l
  ) =>
  LedgerDBEnv m l blk ->
  StrictTVar m (m ()) ->
  DbChangelog l ->
  ReadLocked m (Forker m l)
newForker :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasLedgerTables l, NoThunks (l EmptyMK), GetTip l,
 StandardHash l) =>
LedgerDBEnv m l blk
-> StrictTVar m (m ())
-> DbChangelog l
-> ReadLocked m (Forker m l)
newForker LedgerDBEnv m l blk
ldbEnv StrictTVar m (m ())
releaseVar DbChangelog l
dblog = m (Forker m l) -> ReadLocked m (Forker m l)
forall (m :: * -> *) a. m a -> ReadLocked m a
readLocked (m (Forker m l) -> ReadLocked m (Forker m l))
-> m (Forker m l) -> ReadLocked m (Forker m l)
forall a b. (a -> b) -> a -> b
$ do
  dblogVar <- DbChangelog l -> m (StrictTVar m (DbChangelog l))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO DbChangelog l
dblog
  forkerKey <- atomically $ stateTVar (ldbNextForkerKey ldbEnv) $ \ForkerKey
r -> (ForkerKey
r, ForkerKey
r ForkerKey -> ForkerKey -> ForkerKey
forall a. Num a => a -> a -> a
+ ForkerKey
1)
  forkerMVar <- newMVar $ Left (ldbLock ldbEnv, ldbBackingStore ldbEnv)
  forkerCommitted <- newTVarIO False
  let forkerEnv =
        ForkerEnv
          { foeBackingStoreValueHandle :: StrictMVar
  m
  (Either
     (LedgerDBLock m,
      BackingStore
        m
        (LedgerTables l KeysMK)
        (TxIn l)
        (LedgerTables l ValuesMK)
        (LedgerTables l DiffMK))
     (BackingStoreValueHandle
        m (LedgerTables l KeysMK) (TxIn l) (LedgerTables l ValuesMK)))
foeBackingStoreValueHandle = StrictMVar
  m
  (Either
     (LedgerDBLock m,
      BackingStore
        m
        (LedgerTables l KeysMK)
        (TxIn l)
        (LedgerTables l ValuesMK)
        (LedgerTables l DiffMK))
     (BackingStoreValueHandle
        m (LedgerTables l KeysMK) (TxIn l) (LedgerTables l ValuesMK)))
forkerMVar
          , foeChangelog :: StrictTVar m (DbChangelog l)
foeChangelog = StrictTVar m (DbChangelog l)
dblogVar
          , foeSwitchVar :: StrictTVar m (DbChangelog l)
foeSwitchVar = LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (DbChangelog l)
ldbChangelog LedgerDBEnv m l blk
ldbEnv
          , foeTracer :: Tracer m TraceForkerEvent
foeTracer =
              TraceForkerEventWithKey -> TraceEvent blk
forall blk. TraceForkerEventWithKey -> TraceEvent blk
LedgerDBForkerEvent (TraceForkerEventWithKey -> TraceEvent blk)
-> (TraceForkerEvent -> TraceForkerEventWithKey)
-> TraceForkerEvent
-> TraceEvent blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForkerKey -> TraceForkerEvent -> TraceForkerEventWithKey
TraceForkerEventWithKey ForkerKey
forkerKey (TraceForkerEvent -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m TraceForkerEvent
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< LedgerDBEnv m l blk -> Tracer m (TraceEvent blk)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> Tracer m (TraceEvent blk)
ldbTracer LedgerDBEnv m l blk
ldbEnv
          , foeWasCommitted :: StrictTVar m Bool
foeWasCommitted = StrictTVar m Bool
forkerCommitted
          }
  atomically $
    -- Empty the tvar created for allocating the unsafe read access,
    -- so that it is the forker the one that takes care of releasing
    -- it.
    writeTVar releaseVar (pure ())
  traceWith (foeTracer forkerEnv) ForkerOpen
  pure $
    Forker
      { forkerClose = closeForkerEnv forkerEnv
      , forkerReadTables = implForkerReadTables forkerEnv
      , forkerRangeReadTables = implForkerRangeReadTables (ldbQueryBatchSize ldbEnv) forkerEnv
      , forkerGetLedgerState = implForkerGetLedgerState forkerEnv
      , forkerReadStatistics = implForkerReadStatistics forkerEnv
      , forkerPush = implForkerPush forkerEnv
      , forkerCommit = pure <$> implForkerCommit forkerEnv
      }