{-# 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 Data.Containers.ListUtils (nubOrd)
import qualified Data.Foldable as Foldable
import Data.Functor ((<&>))
import Data.Functor.Contravariant ((>$<))
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (isJust, mapMaybe)
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)
        lastSnapshotRequestedAt <- newTVarIO Nothing
        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
                , ldbLastSuccessfulSnapshotRequestedAt :: StrictTVar m (Maybe Time)
ldbLastSuccessfulSnapshotRequestedAt = StrictTVar m (Maybe Time)
lastSnapshotRequestedAt
                }
        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 () -> (SnapshotDelayRange -> m DiffTime) -> m ()
tryTakeSnapshot = LedgerDBHandle m l blk
-> (LedgerDBEnv m l blk
    -> m () -> (SnapshotDelayRange -> m DiffTime) -> m ())
-> m ()
-> (SnapshotDelayRange -> m DiffTime)
-> m ()
forall (m :: * -> *) (l :: 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 (SnapshotManagerV1 m blk
-> LedgerDBEnv m l blk
-> m ()
-> (SnapshotDelayRange -> m DiffTime)
-> m ()
forall blk (l :: LedgerStateKind) (m :: * -> *).
(IsLedger (LedgerState blk), l ~ ExtLedgerState blk,
 HasLedgerTables l, IOLike m) =>
SnapshotManagerV1 m blk
-> LedgerDBEnv m l blk
-> m ()
-> (SnapshotDelayRange -> m DiffTime)
-> m ()
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 ::
  ( IsLedger (LedgerState blk)
  , l ~ ExtLedgerState blk
  , HasLedgerTables l
  , IOLike m
  ) =>
  SnapshotManagerV1 m blk ->
  LedgerDBEnv m l blk ->
  m () ->
  (SnapshotDelayRange -> m DiffTime) ->
  m ()
implTryTakeSnapshot :: forall blk (l :: LedgerStateKind) (m :: * -> *).
(IsLedger (LedgerState blk), l ~ ExtLedgerState blk,
 HasLedgerTables l, IOLike m) =>
SnapshotManagerV1 m blk
-> LedgerDBEnv m l blk
-> m ()
-> (SnapshotDelayRange -> m DiffTime)
-> m ()
implTryTakeSnapshot SnapshotManagerV1 m blk
snapManager LedgerDBEnv m l blk
env m ()
copyBlocks SnapshotDelayRange -> m DiffTime
getRandomDelay = do
  now <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
  timeSinceLastSnapshot <- do
    mLastSnapshotRequested <- readTVarIO $ ldbLastSuccessfulSnapshotRequestedAt env
    forM mLastSnapshotRequested $ \Time
lastSnapshotRequested -> do
      DiffTime -> m DiffTime
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiffTime -> m DiffTime) -> DiffTime -> m DiffTime
forall a b. (a -> b) -> a -> b
$ Time
now Time -> Time -> DiffTime
`diffTime` Time
lastSnapshotRequested
  -- Get all states before the volatile suffix.
  immutableStates <- atomically $ do
    states <- changelogStates <$> readTVar (ldbChangelog env)
    volSuffix <- getVolatileSuffix (ldbGetVolatileSuffix env)
    pure $ AS.dropNewest (AS.length (volSuffix states)) states
  let immutableSlots :: [SlotNo] =
        -- Remove duplicates due to EBBs.
        nubOrd . mapMaybe (withOriginToMaybe . getTipSlot) $
          AS.anchor immutableStates : AS.toOldestFirst immutableStates
      snapshotSlots =
        SnapshotPolicy -> SnapshotSelectorContext -> [SlotNo]
onDiskSnapshotSelector
          (LedgerDBEnv m l blk -> SnapshotPolicy
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> SnapshotPolicy
ldbSnapshotPolicy LedgerDBEnv m l blk
env)
          SnapshotSelectorContext
            { sscTimeSinceLast :: Maybe DiffTime
sscTimeSinceLast = Maybe DiffTime
timeSinceLastSnapshot
            , sscSnapshotSlots :: [SlotNo]
sscSnapshotSlots = [SlotNo]
immutableSlots
            }
  case NonEmpty.nonEmpty snapshotSlots of
    Maybe (NonEmpty SlotNo)
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just NonEmpty SlotNo
nonEmptySnapshotSlots -> do
      m ()
copyBlocks

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

      forM_ nonEmptySnapshotSlots $ \SlotNo
slot -> do
        -- Prune the 'DbChangelog' such that the resulting anchor state has slot
        -- number @slot@.
        let pruneStrat :: LedgerDbPrune
pruneStrat = SlotNo -> LedgerDbPrune
LedgerDbPruneBeforeSlot (SlotNo
slot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1)
        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) (LedgerDbPrune -> DbChangelog l -> DbChangelog l
forall (l :: LedgerStateKind).
GetTip l =>
LedgerDbPrune -> DbChangelog l -> DbChangelog l
prune LedgerDbPrune
pruneStrat)
        -- Flush the LedgerDB such that we can take a snapshot for the new anchor
        -- state due to the previous prune.
        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))
        -- Now, taking a snapshot (for the last flushed state) will do what we want.
        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
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)
        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 (Maybe Time) -> Maybe Time -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (LedgerDBEnv m l blk -> StrictTVar m (Maybe Time)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (Maybe Time)
ldbLastSuccessfulSnapshotRequestedAt LedgerDBEnv m l blk
env) (Time -> Maybe Time
forall a. a -> Maybe a
Just (Time -> Maybe Time) -> Time -> Maybe Time
forall a b. (a -> b) -> a -> b
$! Time
now)
        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 (ExtLedgerState 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 (ExtLedgerState 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)
      traceWith (LedgerDBSnapshotEvent >$< ldbTracer env) $
        SnapshotRequestCompleted

-- 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)
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
LedgerDBEnv m l blk -> StrictTVar m (Maybe Time)
ldbLastSuccessfulSnapshotRequestedAt :: !(StrictTVar m (Maybe Time))
  -- ^ The time at which the latest successfully-completed snapshot was
  -- requested. Note that this is not the the last time any snapshot was
  -- requested -- there may be later snapshot requests that have failed, or that
  -- are currently in progress (but may be blocked by a snapshot delay or
  -- working).
  }
  deriving (forall x. LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x)
-> (forall x. Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk)
-> Generic (LedgerDBEnv m l blk)
forall x. Rep (LedgerDBEnv m l blk) x -> LedgerDBEnv m l blk
forall x. LedgerDBEnv m l blk -> Rep (LedgerDBEnv m l blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) (l :: 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 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
      }