{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Storage.LedgerDB.V1.Forker
  ( ForkerEnv (..)
  , closeForkerEnv
  , implForkerCommit
  , implForkerGetLedgerState
  , implForkerPush
  , implForkerRangeReadTables
  , implForkerReadStatistics
  , implForkerReadTables
  ) where

import Control.Tracer
import qualified Data.Map.Strict as Map
import Data.Semigroup
import qualified Data.Set as Set
import GHC.Generics (Generic)
import NoThunks.Class
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsProtocol
import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff
import Ouroboros.Consensus.Storage.LedgerDB.API
import Ouroboros.Consensus.Storage.LedgerDB.Args
import Ouroboros.Consensus.Storage.LedgerDB.Forker as Forker
import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API as BackingStore
import Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog
import Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq
  ( numDeletes
  , numInserts
  )
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq as DS
import Ouroboros.Consensus.Util.IOLike

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

data ForkerEnv m l blk = ForkerEnv
  { forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> LedgerBackingStoreValueHandle m l
foeBackingStoreValueHandle :: !(LedgerBackingStoreValueHandle m l)
  -- ^ Local, consistent view of backing store
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> StrictTVar m (DbChangelog l)
foeChangelog :: !(StrictTVar m (DbChangelog l))
  -- ^ In memory db changelog, 'foeBackingStoreValueHandle' must refer to
  -- the anchor of this changelog.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> StrictTVar m (DbChangelog l)
foeSwitchVar :: !(StrictTVar m (DbChangelog l))
  -- ^ The same 'StrictTVar' as 'ldbChangelog'
  --
  -- The anchor of this and 'foeChangelog' might get out of sync if diffs are
  -- flushed, but 'forkerCommit' will take care of this.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> SecurityParam
foeSecurityParam :: !SecurityParam
  -- ^ Config
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> Tracer m TraceForkerEvent
foeTracer :: !(Tracer m TraceForkerEvent)
  -- ^ Config
  }
  deriving (forall x. ForkerEnv m l blk -> Rep (ForkerEnv m l blk) x)
-> (forall x. Rep (ForkerEnv m l blk) x -> ForkerEnv m l blk)
-> Generic (ForkerEnv m l blk)
forall x. Rep (ForkerEnv m l blk) x -> ForkerEnv m l blk
forall x. ForkerEnv m l blk -> Rep (ForkerEnv 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 (ForkerEnv m l blk) x -> ForkerEnv m l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk x.
ForkerEnv m l blk -> Rep (ForkerEnv m l blk) x
$cfrom :: forall (m :: * -> *) (l :: LedgerStateKind) blk x.
ForkerEnv m l blk -> Rep (ForkerEnv m l blk) x
from :: forall x. ForkerEnv m l blk -> Rep (ForkerEnv m l blk) x
$cto :: forall (m :: * -> *) (l :: LedgerStateKind) blk x.
Rep (ForkerEnv m l blk) x -> ForkerEnv m l blk
to :: forall x. Rep (ForkerEnv m l blk) x -> ForkerEnv m l blk
Generic

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

{-------------------------------------------------------------------------------
  Close
-------------------------------------------------------------------------------}

closeForkerEnv :: ForkerEnv m l blk -> m ()
closeForkerEnv :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> m ()
closeForkerEnv ForkerEnv{LedgerBackingStoreValueHandle m l
foeBackingStoreValueHandle :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> LedgerBackingStoreValueHandle m l
foeBackingStoreValueHandle :: LedgerBackingStoreValueHandle m l
foeBackingStoreValueHandle} = LedgerBackingStoreValueHandle m l -> m ()
forall (m :: * -> *) keys values.
BackingStoreValueHandle m keys values -> m ()
bsvhClose LedgerBackingStoreValueHandle m l
foeBackingStoreValueHandle

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

implForkerReadTables ::
  (MonadSTM m, HasLedgerTables l, GetTip l) =>
  ForkerEnv m l blk ->
  LedgerTables l KeysMK ->
  m (LedgerTables l ValuesMK)
implForkerReadTables :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, HasLedgerTables l, GetTip l) =>
ForkerEnv m l blk
-> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
implForkerReadTables ForkerEnv m l blk
env LedgerTables l KeysMK
ks = do
  Tracer m TraceForkerEvent -> TraceForkerEvent -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (ForkerEnv m l blk -> Tracer m TraceForkerEvent
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> Tracer m TraceForkerEvent
foeTracer ForkerEnv m l blk
env) TraceForkerEvent
ForkerReadTablesStart
  chlog <- StrictTVar m (DbChangelog l) -> m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (ForkerEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> StrictTVar m (DbChangelog l)
foeChangelog ForkerEnv m l blk
env)
  unfwd <- readKeySetsWith lvh (changelogLastFlushedState chlog) ks
  case forwardTableKeySets chlog unfwd of
    Left RewindReadFwdError
_err -> String -> m (LedgerTables l ValuesMK)
forall a. HasCallStack => String -> a
error String
"impossible!"
    Right LedgerTables l ValuesMK
vs -> do
      Tracer m TraceForkerEvent -> TraceForkerEvent -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (ForkerEnv m l blk -> Tracer m TraceForkerEvent
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> Tracer m TraceForkerEvent
foeTracer ForkerEnv m l blk
env) TraceForkerEvent
ForkerReadTablesEnd
      LedgerTables l ValuesMK -> m (LedgerTables l ValuesMK)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerTables l ValuesMK
vs
 where
  lvh :: LedgerBackingStoreValueHandle m l
lvh = ForkerEnv m l blk -> LedgerBackingStoreValueHandle m l
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> LedgerBackingStoreValueHandle m l
foeBackingStoreValueHandle ForkerEnv m l blk
env

implForkerRangeReadTables ::
  (MonadSTM m, HasLedgerTables l) =>
  QueryBatchSize ->
  ForkerEnv m l blk ->
  RangeQueryPrevious l ->
  m (LedgerTables l ValuesMK)
implForkerRangeReadTables :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, HasLedgerTables l) =>
QueryBatchSize
-> ForkerEnv m l blk
-> RangeQueryPrevious l
-> m (LedgerTables l ValuesMK)
implForkerRangeReadTables QueryBatchSize
qbs ForkerEnv m l blk
env RangeQueryPrevious l
rq0 = do
  Tracer m TraceForkerEvent -> TraceForkerEvent -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (ForkerEnv m l blk -> Tracer m TraceForkerEvent
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> Tracer m TraceForkerEvent
foeTracer ForkerEnv m l blk
env) TraceForkerEvent
ForkerRangeReadTablesStart
  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
$ ForkerEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> StrictTVar m (DbChangelog l)
foeChangelog ForkerEnv m l blk
env
  let
    -- Get the differences without the keys that are greater or equal
    -- than the maximum previously seen key.
    diffs =
      (LedgerTables l DiffMK -> LedgerTables l DiffMK)
-> (LedgerTables l KeysMK
    -> LedgerTables l DiffMK -> LedgerTables l DiffMK)
-> Maybe (LedgerTables l KeysMK)
-> LedgerTables l DiffMK
-> LedgerTables l DiffMK
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        LedgerTables l DiffMK -> LedgerTables l DiffMK
forall a. a -> a
id
        ((forall k v.
 LedgerTableConstraints' l k v =>
 KeysMK k v -> DiffMK k v -> DiffMK k v)
-> LedgerTables l KeysMK
-> LedgerTables l DiffMK
-> LedgerTables l DiffMK
forall (l :: LedgerStateKind) (mk1 :: MapKind) (mk2 :: MapKind)
       (mk3 :: MapKind).
LedgerTableConstraints l =>
(forall k v.
 LedgerTableConstraints' l k v =>
 mk1 k v -> mk2 k v -> mk3 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2 -> LedgerTables l mk3
ltliftA2 KeysMK k v -> DiffMK k v -> DiffMK k v
forall k v. Ord k => KeysMK k v -> DiffMK k v -> DiffMK k v
forall k v.
LedgerTableConstraints' l k v =>
KeysMK k v -> DiffMK k v -> DiffMK k v
doDropLTE)
        (RangeQuery (LedgerTables l KeysMK) -> Maybe (LedgerTables l KeysMK)
forall keys. RangeQuery keys -> Maybe keys
BackingStore.rqPrev RangeQuery (LedgerTables l KeysMK)
rq)
        (LedgerTables l DiffMK -> LedgerTables l DiffMK)
-> LedgerTables l DiffMK -> LedgerTables l DiffMK
forall a b. (a -> b) -> a -> b
$ (forall k v.
 LedgerTableConstraints' l k v =>
 SeqDiffMK k v -> DiffMK k v)
-> LedgerTables l SeqDiffMK -> LedgerTables l DiffMK
forall (l :: LedgerStateKind) (mk1 :: MapKind) (mk2 :: MapKind).
LedgerTableConstraints l =>
(forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2
ltmap SeqDiffMK k v -> DiffMK k v
forall k v. (Ord k, Eq v) => SeqDiffMK k v -> DiffMK k v
forall k v.
LedgerTableConstraints' l k v =>
SeqDiffMK k v -> DiffMK k v
prj
        (LedgerTables l SeqDiffMK -> LedgerTables l DiffMK)
-> LedgerTables l SeqDiffMK -> LedgerTables l DiffMK
forall a b. (a -> b) -> a -> b
$ DbChangelog l -> LedgerTables l SeqDiffMK
forall (l :: LedgerStateKind).
DbChangelog l -> LedgerTables l SeqDiffMK
changelogDiffs DbChangelog l
ldb
    -- (1) Ensure that we never delete everything read from disk (ie if
    --     our result is non-empty then it contains something read from
    --     disk, as we only get an empty result if we reached the end of
    --     the table).
    --
    -- (2) Also, read one additional key, which we will not include in
    --     the result but need in order to know which in-memory
    --     insertions to include.
    maxDeletes = LedgerTables l (K2 Int) -> Int
forall (l :: LedgerStateKind) a. LedgerTables l (K2 a) -> a
ltcollapse (LedgerTables l (K2 Int) -> Int) -> LedgerTables l (K2 Int) -> Int
forall a b. (a -> b) -> a -> b
$ (forall k v.
 LedgerTableConstraints' l k v =>
 DiffMK k v -> K2 Int k v)
-> LedgerTables l DiffMK -> LedgerTables l (K2 Int)
forall (l :: LedgerStateKind) (mk1 :: MapKind) (mk2 :: MapKind).
LedgerTableConstraints l =>
(forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2
ltmap (Int -> K2 Int k v
forall k1 k2 a (b :: k1) (c :: k2). a -> K2 a b c
K2 (Int -> K2 Int k v)
-> (DiffMK k v -> Int) -> DiffMK k v -> K2 Int k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffMK k v -> Int
forall k v. DiffMK k v -> Int
numDeletesDiffMK) LedgerTables l DiffMK
diffs
    nrequested = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (RangeQuery (LedgerTables l KeysMK) -> Int
forall keys. RangeQuery keys -> Int
BackingStore.rqCount RangeQuery (LedgerTables l KeysMK)
rq) (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
maxDeletes)

  let st = DbChangelog l -> l EmptyMK
forall (l :: LedgerStateKind). DbChangelog l -> l EmptyMK
changelogLastFlushedState DbChangelog l
ldb
  values <- BackingStore.bsvhRangeRead lvh st (rq{BackingStore.rqCount = nrequested})
  traceWith (foeTracer env) ForkerRangeReadTablesEnd
  pure $ ltliftA2 (doFixupReadResult nrequested) diffs values
 where
  lvh :: BackingStoreValueHandle
  m (LedgerTables l KeysMK) (LedgerTables l ValuesMK)
lvh = ForkerEnv m l blk
-> BackingStoreValueHandle
     m (LedgerTables l KeysMK) (LedgerTables l ValuesMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> LedgerBackingStoreValueHandle m l
foeBackingStoreValueHandle ForkerEnv m l blk
env

  rq :: RangeQuery (LedgerTables l KeysMK)
rq = Maybe (LedgerTables l KeysMK)
-> Int -> RangeQuery (LedgerTables l KeysMK)
forall keys. Maybe keys -> Int -> RangeQuery keys
BackingStore.RangeQuery Maybe (LedgerTables l KeysMK)
rq1 (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ QueryBatchSize -> Word64
defaultQueryBatchSize QueryBatchSize
qbs)

  rq1 :: Maybe (LedgerTables l KeysMK)
rq1 = case RangeQueryPrevious l
rq0 of
    RangeQueryPrevious l
NoPreviousQuery -> Maybe (LedgerTables l KeysMK)
forall a. Maybe a
Nothing
    RangeQueryPrevious l
PreviousQueryWasFinal -> LedgerTables l KeysMK -> Maybe (LedgerTables l KeysMK)
forall a. a -> Maybe a
Just (KeysMK (TxIn l) (TxOut l) -> LedgerTables l KeysMK
forall (l :: LedgerStateKind) (mk :: MapKind).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables (KeysMK (TxIn l) (TxOut l) -> LedgerTables l KeysMK)
-> KeysMK (TxIn l) (TxOut l) -> LedgerTables l KeysMK
forall a b. (a -> b) -> a -> b
$ Set (TxIn l) -> KeysMK (TxIn l) (TxOut l)
forall k v. Set k -> KeysMK k v
KeysMK Set (TxIn l)
forall a. Set a
Set.empty)
    PreviousQueryWasUpTo TxIn l
k -> LedgerTables l KeysMK -> Maybe (LedgerTables l KeysMK)
forall a. a -> Maybe a
Just (KeysMK (TxIn l) (TxOut l) -> LedgerTables l KeysMK
forall (l :: LedgerStateKind) (mk :: MapKind).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables (KeysMK (TxIn l) (TxOut l) -> LedgerTables l KeysMK)
-> KeysMK (TxIn l) (TxOut l) -> LedgerTables l KeysMK
forall a b. (a -> b) -> a -> b
$ Set (TxIn l) -> KeysMK (TxIn l) (TxOut l)
forall k v. Set k -> KeysMK k v
KeysMK (Set (TxIn l) -> KeysMK (TxIn l) (TxOut l))
-> Set (TxIn l) -> KeysMK (TxIn l) (TxOut l)
forall a b. (a -> b) -> a -> b
$ TxIn l -> Set (TxIn l)
forall a. a -> Set a
Set.singleton TxIn l
k)

  prj ::
    (Ord k, Eq v) =>
    SeqDiffMK k v ->
    DiffMK k v
  prj :: forall k v. (Ord k, Eq v) => SeqDiffMK k v -> DiffMK k v
prj (SeqDiffMK DiffSeq k v
sq) = Diff k v -> DiffMK k v
forall k v. Diff k v -> DiffMK k v
DiffMK (Diff k v -> Diff k v
forall k v. Diff k v -> Diff k v
DS.fromAntiDiff (Diff k v -> Diff k v) -> Diff k v -> Diff k v
forall a b. (a -> b) -> a -> b
$ DiffSeq k v -> Diff k v
forall k v. SM k v => DiffSeq k v -> Diff k v
DS.cumulativeDiff DiffSeq k v
sq)

  -- Remove all diff elements that are <= to the greatest given key
  doDropLTE ::
    Ord k =>
    KeysMK k v ->
    DiffMK k v ->
    DiffMK k v
  doDropLTE :: forall k v. Ord k => KeysMK k v -> DiffMK k v -> DiffMK k v
doDropLTE (KeysMK Set k
ks) (DiffMK Diff k v
ds) =
    Diff k v -> DiffMK k v
forall k v. Diff k v -> DiffMK k v
DiffMK (Diff k v -> DiffMK k v) -> Diff k v -> DiffMK k v
forall a b. (a -> b) -> a -> b
$
      case Set k -> Maybe k
forall a. Set a -> Maybe a
Set.lookupMax Set k
ks of
        Maybe k
Nothing -> Diff k v
ds
        Just k
k -> (k -> Bool) -> Diff k v -> Diff k v
forall k v. (k -> Bool) -> Diff k v -> Diff k v
Diff.filterWithKeyOnly (k -> k -> Bool
forall a. Ord a => a -> a -> Bool
> k
k) Diff k v
ds

  -- NOTE: this is counting the deletions wrt disk because deletions of values
  -- created along the diffs will have been collapsed to the empty diff.
  numDeletesDiffMK :: DiffMK k v -> Int
  numDeletesDiffMK :: forall k v. DiffMK k v -> Int
numDeletesDiffMK (DiffMK Diff k v
d) =
    Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> Int) -> Sum Int -> Int
forall a b. (a -> b) -> a -> b
$ (Delta v -> Sum Int) -> Diff k v -> Sum Int
forall m v k. Monoid m => (Delta v -> m) -> Diff k v -> m
Diff.foldMapDelta (Int -> Sum Int
forall a. a -> Sum a
Sum (Int -> Sum Int) -> (Delta v -> Int) -> Delta v -> Sum Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Delta v -> Int
forall {a} {v}. Num a => Delta v -> a
oneIfDel) Diff k v
d
   where
    oneIfDel :: Delta v -> a
oneIfDel Delta v
x = case Delta v
x of
      Delta v
Diff.Delete -> a
1
      Diff.Insert v
_ -> a
0

  -- INVARIANT: nrequested > 0
  --
  -- (1) if we reached the end of the store, then simply yield the given diff
  --     applied to the given values
  -- (2) otherwise, the readset must be non-empty, since 'rqCount' is positive
  -- (3) remove the greatest read key
  -- (4) remove all diff elements that are >= the greatest read key
  -- (5) apply the remaining diff
  -- (6) (the greatest read key will be the first fetched if the yield of this
  --     result is next passed as 'rqPrev')
  --
  -- Note that if the in-memory changelog contains the greatest key, then
  -- we'll return that in step (1) above, in which case the next passed
  -- 'rqPrev' will contain it, which will cause 'doDropLTE' to result in an
  -- empty diff, which will result in an entirely empty range query result,
  -- which is the termination case.
  doFixupReadResult ::
    Ord k =>
    Int ->
    -- \^ Number of requested keys from the backing store.
    DiffMK k v ->
    -- \^ Differences that will be applied to the values read from the backing
    -- store.
    ValuesMK k v ->
    -- \^ Values read from the backing store. The number of values read should
    -- be at most @nrequested@.
    ValuesMK k v
  doFixupReadResult :: forall k v.
Ord k =>
Int -> DiffMK k v -> ValuesMK k v -> ValuesMK k v
doFixupReadResult
    Int
nrequested
    (DiffMK Diff k v
ds)
    (ValuesMK Map k v
vs) =
      let includingAllKeys :: Map k v
includingAllKeys =
            Map k v -> Diff k v -> Map k v
forall k v. Ord k => Map k v -> Diff k v -> Map k v
Diff.applyDiff Map k v
vs Diff k v
ds
          definitelyNoMoreToFetch :: Bool
definitelyNoMoreToFetch = Map k v -> Int
forall k a. Map k a -> Int
Map.size Map k v
vs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
nrequested
       in Map k v -> ValuesMK k v
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map k v -> ValuesMK k v) -> Map k v -> ValuesMK k v
forall a b. (a -> b) -> a -> b
$
            case Map k v -> Maybe ((k, v), Map k v)
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map k v
vs of
              Maybe ((k, v), Map k v)
Nothing ->
                if Bool
definitelyNoMoreToFetch
                  then Map k v
includingAllKeys
                  else String -> Map k v
forall a. HasCallStack => String -> a
error (String -> Map k v) -> String -> Map k v
forall a b. (a -> b) -> a -> b
$ String
"Size of values " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Map k v -> Int
forall k a. Map k a -> Int
Map.size Map k v
vs) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", nrequested " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
nrequested
              Just ((k
k, v
_v), Map k v
vs') ->
                if Bool
definitelyNoMoreToFetch
                  then Map k v
includingAllKeys
                  else
                    Map k v -> Diff k v -> Map k v
forall k v. Ord k => Map k v -> Diff k v -> Map k v
Diff.applyDiff
                      Map k v
vs'
                      ((k -> Bool) -> Diff k v -> Diff k v
forall k v. (k -> Bool) -> Diff k v -> Diff k v
Diff.filterWithKeyOnly (k -> k -> Bool
forall a. Ord a => a -> a -> Bool
< k
k) Diff k v
ds)

implForkerGetLedgerState ::
  (MonadSTM m, GetTip l) =>
  ForkerEnv m l blk ->
  STM m (l EmptyMK)
implForkerGetLedgerState :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l) =>
ForkerEnv m l blk -> STM m (l EmptyMK)
implForkerGetLedgerState ForkerEnv m l blk
env = DbChangelog l -> l EmptyMK
forall (l :: LedgerStateKind).
GetTip l =>
DbChangelog l -> l EmptyMK
current (DbChangelog l -> l EmptyMK)
-> STM m (DbChangelog l) -> STM m (l EmptyMK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (DbChangelog l) -> STM m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ForkerEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> StrictTVar m (DbChangelog l)
foeChangelog ForkerEnv m l blk
env)

-- | Obtain statistics for a combination of backing store value handle and
-- changelog.
implForkerReadStatistics ::
  (MonadSTM m, HasLedgerTables l, GetTip l) =>
  ForkerEnv m l blk ->
  m (Maybe Forker.Statistics)
implForkerReadStatistics :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, HasLedgerTables l, GetTip l) =>
ForkerEnv m l blk -> m (Maybe Statistics)
implForkerReadStatistics ForkerEnv m l blk
env = do
  Tracer m TraceForkerEvent -> TraceForkerEvent -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (ForkerEnv m l blk -> Tracer m TraceForkerEvent
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> Tracer m TraceForkerEvent
foeTracer ForkerEnv m l blk
env) TraceForkerEvent
ForkerReadStatistics
  dblog <- StrictTVar m (DbChangelog l) -> m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (ForkerEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> StrictTVar m (DbChangelog l)
foeChangelog ForkerEnv m l blk
env)

  let seqNo = l EmptyMK -> WithOrigin SlotNo
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot (l EmptyMK -> WithOrigin SlotNo) -> l EmptyMK -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ DbChangelog l -> l EmptyMK
forall (l :: LedgerStateKind). DbChangelog l -> l EmptyMK
changelogLastFlushedState DbChangelog l
dblog
  BackingStore.Statistics{sequenceNumber = seqNo', numEntries = n} <- bsvhStat lbsvh
  if seqNo /= seqNo'
    then
      error $
        "Statistics seqNo ("
          ++ show seqNo'
          ++ ") is different from the seqNo in the DbChangelog last flushed field ("
          ++ show seqNo
          ++ ")"
    else do
      let
        diffs = DbChangelog l -> LedgerTables l SeqDiffMK
forall (l :: LedgerStateKind).
DbChangelog l -> LedgerTables l SeqDiffMK
changelogDiffs DbChangelog l
dblog

        nInserts =
          LedgerTables l (K2 Int) -> Int
forall (l :: LedgerStateKind) a. LedgerTables l (K2 a) -> a
ltcollapse (LedgerTables l (K2 Int) -> Int) -> LedgerTables l (K2 Int) -> Int
forall a b. (a -> b) -> a -> b
$
            (forall k v.
 LedgerTableConstraints' l k v =>
 SeqDiffMK k v -> K2 Int k v)
-> LedgerTables l SeqDiffMK -> LedgerTables l (K2 Int)
forall (l :: LedgerStateKind) (mk1 :: MapKind) (mk2 :: MapKind).
LedgerTableConstraints l =>
(forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2
ltmap
              (Int -> K2 Int k v
forall k1 k2 a (b :: k1) (c :: k2). a -> K2 a b c
K2 (Int -> K2 Int k v)
-> (SeqDiffMK k v -> Int) -> SeqDiffMK k v -> K2 Int k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> Int)
-> (SeqDiffMK k v -> Sum Int) -> SeqDiffMK k v -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffSeq k v -> Sum Int
forall k v. SM k v => DiffSeq k v -> Sum Int
numInserts (DiffSeq k v -> Sum Int)
-> (SeqDiffMK k v -> DiffSeq k v) -> SeqDiffMK k v -> Sum Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SeqDiffMK k v -> DiffSeq k v
forall k v. SeqDiffMK k v -> DiffSeq k v
getSeqDiffMK)
              LedgerTables l SeqDiffMK
diffs
        nDeletes =
          LedgerTables l (K2 Int) -> Int
forall (l :: LedgerStateKind) a. LedgerTables l (K2 a) -> a
ltcollapse (LedgerTables l (K2 Int) -> Int) -> LedgerTables l (K2 Int) -> Int
forall a b. (a -> b) -> a -> b
$
            (forall k v.
 LedgerTableConstraints' l k v =>
 SeqDiffMK k v -> K2 Int k v)
-> LedgerTables l SeqDiffMK -> LedgerTables l (K2 Int)
forall (l :: LedgerStateKind) (mk1 :: MapKind) (mk2 :: MapKind).
LedgerTableConstraints l =>
(forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2
ltmap
              (Int -> K2 Int k v
forall k1 k2 a (b :: k1) (c :: k2). a -> K2 a b c
K2 (Int -> K2 Int k v)
-> (SeqDiffMK k v -> Int) -> SeqDiffMK k v -> K2 Int k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> Int)
-> (SeqDiffMK k v -> Sum Int) -> SeqDiffMK k v -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffSeq k v -> Sum Int
forall k v. SM k v => DiffSeq k v -> Sum Int
numDeletes (DiffSeq k v -> Sum Int)
-> (SeqDiffMK k v -> DiffSeq k v) -> SeqDiffMK k v -> Sum Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SeqDiffMK k v -> DiffSeq k v
forall k v. SeqDiffMK k v -> DiffSeq k v
getSeqDiffMK)
              LedgerTables l SeqDiffMK
diffs
      pure . Just $
        Forker.Statistics
          { ledgerTableSize = n + nInserts - nDeletes
          }
 where
  lbsvh :: BackingStoreValueHandle
  m (LedgerTables l KeysMK) (LedgerTables l ValuesMK)
lbsvh = ForkerEnv m l blk
-> BackingStoreValueHandle
     m (LedgerTables l KeysMK) (LedgerTables l ValuesMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> LedgerBackingStoreValueHandle m l
foeBackingStoreValueHandle ForkerEnv m l blk
env

implForkerPush ::
  (MonadSTM m, GetTip l, HasLedgerTables l) =>
  ForkerEnv m l blk ->
  l DiffMK ->
  m ()
implForkerPush :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l, HasLedgerTables l) =>
ForkerEnv m l blk -> l DiffMK -> m ()
implForkerPush ForkerEnv m l blk
env l DiffMK
newState = do
  Tracer m TraceForkerEvent -> TraceForkerEvent -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (ForkerEnv m l blk -> Tracer m TraceForkerEvent
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> Tracer m TraceForkerEvent
foeTracer ForkerEnv m l blk
env) TraceForkerEvent
ForkerPushStart
  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
    chlog <- StrictTVar m (DbChangelog l) -> STM m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ForkerEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> StrictTVar m (DbChangelog l)
foeChangelog ForkerEnv m l blk
env)
    let chlog' =
          LedgerDbPrune -> DbChangelog l -> DbChangelog l
forall (l :: LedgerStateKind).
GetTip l =>
LedgerDbPrune -> DbChangelog l -> DbChangelog l
prune (SecurityParam -> LedgerDbPrune
LedgerDbPruneKeeping (ForkerEnv m l blk -> SecurityParam
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> SecurityParam
foeSecurityParam ForkerEnv m l blk
env)) (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
newState DbChangelog l
chlog
    writeTVar (foeChangelog env) chlog'
  Tracer m TraceForkerEvent -> TraceForkerEvent -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (ForkerEnv m l blk -> Tracer m TraceForkerEvent
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> Tracer m TraceForkerEvent
foeTracer ForkerEnv m l blk
env) TraceForkerEvent
ForkerPushEnd

implForkerCommit ::
  (MonadSTM m, GetTip l, HasLedgerTables l) =>
  ForkerEnv m l blk ->
  STM m ()
implForkerCommit :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(MonadSTM m, GetTip l, HasLedgerTables l) =>
ForkerEnv m l blk -> STM m ()
implForkerCommit ForkerEnv m l blk
env = do
  dblog <- StrictTVar m (DbChangelog l) -> STM m (DbChangelog l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ForkerEnv m l blk -> StrictTVar m (DbChangelog l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ForkerEnv m l blk -> StrictTVar m (DbChangelog l)
foeChangelog ForkerEnv m l blk
env)
  modifyTVar (foeSwitchVar env) $ \DbChangelog l
orig ->
    -- We don't need to distinguish Origin from 0 because Origin has no diffs
    -- (SeqDiffMK is a fingertree measured by slot so there cannot be an entry
    -- for Origin).
    let s :: SlotNo
s =
          SlotNo -> WithOrigin SlotNo -> SlotNo
forall t. t -> WithOrigin t -> t
fromWithOrigin SlotNo
0
            (WithOrigin SlotNo -> SlotNo)
-> (l EmptyMK -> WithOrigin SlotNo) -> l EmptyMK -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point l -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot
            (Point l -> WithOrigin SlotNo)
-> (l EmptyMK -> Point l) -> l EmptyMK -> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> SlotNo) -> l EmptyMK -> SlotNo
forall a b. (a -> b) -> a -> b
$ DbChangelog l -> l EmptyMK
forall (l :: LedgerStateKind). DbChangelog l -> l EmptyMK
changelogLastFlushedState DbChangelog l
orig
     in DbChangelog
          { changelogLastFlushedState :: l EmptyMK
changelogLastFlushedState = DbChangelog l -> l EmptyMK
forall (l :: LedgerStateKind). DbChangelog l -> l EmptyMK
changelogLastFlushedState DbChangelog l
orig
          , changelogStates :: AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates = DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall (l :: LedgerStateKind).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates DbChangelog l
dblog
          , changelogDiffs :: LedgerTables l SeqDiffMK
changelogDiffs =
              (forall k v.
 LedgerTableConstraints' l k v =>
 SeqDiffMK k v -> SeqDiffMK k v -> SeqDiffMK k v)
-> LedgerTables l SeqDiffMK
-> LedgerTables l SeqDiffMK
-> LedgerTables l SeqDiffMK
forall (l :: LedgerStateKind) (mk1 :: MapKind) (mk2 :: MapKind)
       (mk3 :: MapKind).
LedgerTableConstraints l =>
(forall k v.
 LedgerTableConstraints' l k v =>
 mk1 k v -> mk2 k v -> mk3 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2 -> LedgerTables l mk3
ltliftA2 (SlotNo -> SeqDiffMK k v -> SeqDiffMK k v -> SeqDiffMK k v
forall k v.
(Ord k, Eq v) =>
SlotNo -> SeqDiffMK k v -> SeqDiffMK k v -> SeqDiffMK k v
doPrune SlotNo
s) (DbChangelog l -> LedgerTables l SeqDiffMK
forall (l :: LedgerStateKind).
DbChangelog l -> LedgerTables l SeqDiffMK
changelogDiffs DbChangelog l
orig) (DbChangelog l -> LedgerTables l SeqDiffMK
forall (l :: LedgerStateKind).
DbChangelog l -> LedgerTables l SeqDiffMK
changelogDiffs DbChangelog l
dblog)
          }
 where
  -- Prune the diffs from the forker's log that have already been flushed to
  -- disk
  doPrune ::
    (Ord k, Eq v) =>
    SlotNo ->
    SeqDiffMK k v ->
    SeqDiffMK k v ->
    SeqDiffMK k v
  doPrune :: forall k v.
(Ord k, Eq v) =>
SlotNo -> SeqDiffMK k v -> SeqDiffMK k v -> SeqDiffMK k v
doPrune SlotNo
s (SeqDiffMK DiffSeq k v
prunedSeq) (SeqDiffMK DiffSeq k v
extendedSeq) =
    DiffSeq k v -> SeqDiffMK k v
forall k v. DiffSeq k v -> SeqDiffMK k v
SeqDiffMK (DiffSeq k v -> SeqDiffMK k v) -> DiffSeq k v -> SeqDiffMK k v
forall a b. (a -> b) -> a -> b
$
      -- This is acceptable because Byron has no tables, so combination of Byron
      -- block and EBB diffs will always result in the empty ledger table hence
      -- it doesn't matter.
      if DiffSeq k v -> StrictMaybe SlotNo
forall k v. SM k v => DiffSeq k v -> StrictMaybe SlotNo
DS.minSlot DiffSeq k v
prunedSeq StrictMaybe SlotNo -> StrictMaybe SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== DiffSeq k v -> StrictMaybe SlotNo
forall k v. SM k v => DiffSeq k v -> StrictMaybe SlotNo
DS.minSlot DiffSeq k v
extendedSeq
        then DiffSeq k v
extendedSeq
        else (DiffSeq k v, DiffSeq k v) -> DiffSeq k v
forall a b. (a, b) -> b
snd ((DiffSeq k v, DiffSeq k v) -> DiffSeq k v)
-> (DiffSeq k v, DiffSeq k v) -> DiffSeq k v
forall a b. (a -> b) -> a -> b
$ SlotNo -> DiffSeq k v -> (DiffSeq k v, DiffSeq k v)
forall k v.
SM k v =>
SlotNo -> DiffSeq k v -> (DiffSeq k v, DiffSeq k v)
DS.splitAtSlot SlotNo
s DiffSeq k v
extendedSeq