{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | A 'DbChangelog' is the component of the
-- 'Ouroboros.Consensus.Storage.LedgerDB.LedgerDB' implementation that
-- responsible for:
--
-- - Maintaining the last \(k\) in-memory ledger states without on-disk parks.
--
-- - Holding the in-memory ledger state that a snapshot would write to the disk.
--
-- - Providing sequences of differences from said state to any requested state
--     in the last \(k\) ledger states, which combined with the values in the
--     'BackingStore', can provide 'LedgerTable's at any of those ledger states.
--
-- A 'DbChangelog' is said to be /anchored/ #anchored# at a 'BackingStore' when
-- the slot of the values in the backing store is the predecesor of the slots in
-- the sequence of differences, with the overall sequence of slots being defined
-- by the blocks on the chain.
--
-- This design is based on the technical report "Storing the Cardano ledger
-- state on disk: API design concepts" by Duncan Coutts and Douglas Wilson.
--
-- = Implementation details
--
-- The 'DbChangelog' is in fact a pure data structure, of which the 'LedgerDB'
-- will carry a value in some mutable state, see
-- 'Ouroboros.Consensus.Storage.LedgerDB.LedgerDBState'.
--
-- == Carrying states
--
-- The 'DbChangelog' contains an instantiation of the 'AnchoredSeq' data type to
-- hold the last \(k\) in-memory ledger states. This data type is impemented
-- using the /finger tree/ data structure and has the following time
-- complexities:
--
-- - Appending a new ledger state to the end in constant time.
--
-- - Rolling back to a previous ledger state in logarithmic time.
--
-- - Looking up a past ledger state by its point in logarithmic time.
--
-- One can think of 'AnchoredSeq' as a 'Seq' from "Data.Sequence" with a custom
-- /finger tree measure/ allowing for efficient lookups by point, combined with
-- an /anchor/. When fully /saturated/, the sequence will contain \(k\) ledger
-- states. In case of a complete rollback of all \(k\) blocks and thus ledger
-- states, the sequence will become empty. A ledger state is still needed, i.e.,
-- one corresponding to the most recent immutable block that cannot be rolled
-- back. The ledger state at the anchor plays this role.
--
-- == Appending in-memory states
--
-- When a new ledger state is appended to a fully saturated 'DbChangelog' (i.e.
-- that contains \(k\) states), the ledger state at the anchor is dropped and
-- the oldest element in the sequence becomes the new anchor, as it has become
-- immutable. Note that we only refer here to the in-memory states, as the diffs
-- from the anchor will remain in the 'DbChangelog' until flushing happens. This
-- maintains the invariant that only the last \(k\) in-memory ledger states are
-- stored, /excluding/ the ledger state at the anchor. This means that in
-- practice, \(k + 1\) ledger states will be kept in memory. When the
-- 'DbChangelog' contains fewer than \(k\) elements, new ones are appended
-- without shifting the anchor until it is saturated.
--
-- == Getting and appending differences
--
-- For the differences, the 'DbChangelog' contains a 'SeqDiffMK' (see
-- "Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq") which in turn is just an
-- instantiation of a /root-measured finger tree/ (see
-- [fingertree-rm](https://github.com/input-output-hk/anti-diffs/tree/main/fingertree-rm))
-- which is a specialization of the finger trees that carries a root-measure
-- which is the monoidal sum of all the measures of all the elements.
--
-- This allows us to very efficiently lookup the combined difference of the
-- whole 'DbChangelog', while still having a good complexity when splitting this
-- tree.
--
-- When a block is to be applied to a ledger state (which must be in the
-- 'DbChangelog' or application would directly fail), applying the root-measure
-- of the sub-sequence of differences from the backing store slot up to the
-- requested slot to the values read from the backing store will provide the
-- 'LedgerTable's needed for applying the block.
--
-- Once a new ledger state is appended to the 'DbChangelog', said ledger state
-- will carry 'DiffMK' tables (obtained by diffing the input and output ledger
-- tables when calling the Ledger rules). Adding those differences to the
-- 'DbChangelog' is just a matter of extending the carried 'SeqDiffMK'.
--
-- Only when flushing, the 'SeqDiffMK' is pruned, by extracting the differences
-- in between the last flushed state and the current immutable tip.
module Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog
  ( -- * The DbChangelog
    DbChangelog (..)
  , DbChangelog'

    -- * Construction
  , empty
  , pruneToImmTipOnly

    -- * Updating a @DbChangelog@

    -- ** Applying blocks

  --

    -- | Applying blocks to the 'DbChangelog' will extend it if the result is
    -- successful.
    --
    -- In order to do so, we first need to [find the particular
    -- block](#g:findingBlocks), then prepare the ledger tables by [hydrating
    -- the ledger state](#g:hydratingTheLedgerState) and then finally call the
    -- ledger, which might throw errors.
  , reapplyThenPush

    -- *** Hydrating the ledger state #hydratingTheLedgerState#

  --

    -- | When trying to get tables at a specific ledger state, we must follow a
    -- process we call /hydrating the ledger state/. This process consists of 3 steps:
    --
    -- 1. Rewind the requested keys to the beginning of the DbChangelog. For
    -- UTxO entries this just means that we record at which slot the db
    -- changelog was when rewinding.
    --
    -- 2. Query the 'BackingStore' for the actual values for the requested keys.
    --
    -- 3. Forward those values by applying the differences in the 'DbChangelog' up to
    -- the requested point.
  , withKeysReadSets

    -- **** Read
  , KeySetsReader
  , UnforwardedReadSets (..)
  , readKeySets
  , readKeySetsWith
  , trivialKeySetsReader

    -- **** Forward
  , RewindReadFwdError (..)
  , forwardTableKeySets
  , forwardTableKeySets'

    -- ** Flushing
  , DiffsToFlush (..)
  , splitForFlushing

    -- * Queries
  , anchor
  , current
  , flushableLength
  , getPastLedgerAt
  , rollback
  , snapshots
  , tip
  , volatileStatesBimap

    -- * 🧪 Testing

    -- ** Internal
  , extend
  , immutableTipSlot
  , isSaturated
  , maxRollback
  , prune
  , rollbackN
  , rollbackToAnchor
  , rollbackToPoint

    -- * Testing
  , reapplyThenPush'
  , reapplyThenPushMany'
  , switch
  , switch'
  ) where

import Cardano.Ledger.BaseTypes
import Cardano.Slotting.Slot
import Control.Exception as Exn
import Data.Bifunctor (bimap)
import Data.Functor.Identity
import Data.Map.Diff.Strict as AntiDiff (applyDiffForKeys)
import Data.SOP (K, unK)
import Data.SOP.Functors
import Data.Word
import GHC.Generics (Generic)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.Tables.Utils
import Ouroboros.Consensus.Storage.LedgerDB.API
import Ouroboros.Consensus.Storage.LedgerDB.Forker
import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq as DS
import Ouroboros.Consensus.Util (repeatedlyM)
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Network.AnchoredSeq (AnchoredSeq)
import qualified Ouroboros.Network.AnchoredSeq as AS

{-------------------------------------------------------------------------------
  The DbChangelog
-------------------------------------------------------------------------------}

-- | Holds a sequence of split ledger states, where the in-memory part is in a
-- sequence and the on-disk part is represented by a sequence of differences
-- that need a 'BackingStore' as an anchor point.
--
-- We illustrate its contents below, where @k = 3@ (for a state @Li@, the
-- corresponding set of differences is @Di@):
--
-- +----------------+------------------------------------+------------------------------------------+
-- | lastFlushed    | states                             | tableDiffs                               |
-- +================+====================================+==========================================+
-- |      @L0@      | @L0 :> [ ]                       @ | @[ ]                                   @ |
-- +----------------+------------------------------------+------------------------------------------+
-- |      @L0@      | @L0 :> [ L1 ]                    @ | @[ D1 ]                                @ |
-- +----------------+------------------------------------+------------------------------------------+
-- |      @L0@      | @L0 :> [ L1, L2 ]                @ | @[ D1, D2 ]                            @ |
-- +----------------+------------------------------------+------------------------------------------+
-- |      @L0@      | @L0 :> [ L1, L2, L3 ]            @ | @[ D1, D2, D3 ]                        @ |
-- +----------------+------------------------------------+------------------------------------------+
-- |      @L0@      | @L1 :> [     L2, L3, L4 ]        @ | @[ D1, D2, D3, D4 ]                    @ |
-- +----------------+------------------------------------+------------------------------------------+
-- |      @L0@      | @L2 :> [         L3, L4, L5 ]    @ | @[ D1, D2, D3, D4, D5 ] -- (*)         @ |
-- +----------------+------------------------------------+------------------------------------------+
-- |      @L2@      | @L2 :> [         L3, L4, L5 ]    @ | @[         D3, D4, D5 ]   -- flush (**)@ |
-- +----------------+------------------------------------+------------------------------------------+
-- |      @L2@      | @L3 :> [             L4, L5, L6 ]@ | @[         D3, D4, D5, D6 ]            @ |
-- +----------------+------------------------------------+------------------------------------------+
--
-- Notice that @length states@ is usually @k@ except when rollbacks or data
-- corruption take place and will be less than @k@ when we just loaded a
-- snapshot. We cannot roll back more than @k@ blocks. This means that after a
-- rollback of @k@ blocks at @(*)@, the changelog will look something like this:
--
-- +------+-------------+--------------+
-- | @L0@ | @L2 :> [ ]@ | @[ D1, D2 ]@ |
-- +------+-------------+--------------+
--
-- And a rollback of @k@ blocks at @(**)@ will look something like this:
--
-- +------+-------------+-------+
-- | @L2@ | @L2 :> [ ]@ | @[ ]@ |
-- +------+-------------+-------+
--
-- Notice how the states list always contains the in-memory state of the anchor,
-- but the table differences might not contain the differences for that anchor
-- if they have been flushed to the backend.
--
-- As said above, this @DbChangelog@ has to be coupled with a @BackingStore@
-- which provides the pointers to the on-disk data.
data DbChangelog l = DbChangelog
  { forall (l :: (* -> * -> *) -> *). DbChangelog l -> l EmptyMK
changelogLastFlushedState :: !(l EmptyMK)
  -- ^ The last flushed ledger state.
  --
  -- We need to keep track of this one as this will be the state written to
  -- disk when we make a snapshot
  , forall (l :: (* -> * -> *) -> *).
DbChangelog l -> LedgerTables l SeqDiffMK
changelogDiffs :: !(LedgerTables l SeqDiffMK)
  -- ^ The sequence of differences between the last flushed state
  -- ('changelogLastFlushedState') and the tip of the volatile sequence
  -- ('changelogStates').
  , forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates ::
      !( AnchoredSeq
           (WithOrigin SlotNo)
           (l EmptyMK)
           (l EmptyMK)
       )
  -- ^ The volatile sequence of states.
  --
  -- The anchor of this sequence is the immutable tip, so whenever we flush,
  -- we should do so up until that point. The length of this sequence will be
  -- @k@ except in abnormal circumstances like rollbacks or data corruption.
  --
  -- Note that @length 'changelogDiffs' >= length 'changelogStates'@.
  }
  deriving (forall x. DbChangelog l -> Rep (DbChangelog l) x)
-> (forall x. Rep (DbChangelog l) x -> DbChangelog l)
-> Generic (DbChangelog l)
forall x. Rep (DbChangelog l) x -> DbChangelog l
forall x. DbChangelog l -> Rep (DbChangelog l) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (l :: (* -> * -> *) -> *) x.
Rep (DbChangelog l) x -> DbChangelog l
forall (l :: (* -> * -> *) -> *) x.
DbChangelog l -> Rep (DbChangelog l) x
$cfrom :: forall (l :: (* -> * -> *) -> *) x.
DbChangelog l -> Rep (DbChangelog l) x
from :: forall x. DbChangelog l -> Rep (DbChangelog l) x
$cto :: forall (l :: (* -> * -> *) -> *) x.
Rep (DbChangelog l) x -> DbChangelog l
to :: forall x. Rep (DbChangelog l) x -> DbChangelog l
Generic

deriving instance
  (Eq (TxIn l), Eq (TxOut l), Eq (l EmptyMK)) =>
  Eq (DbChangelog l)
deriving instance
  (NoThunks (TxIn l), NoThunks (TxOut l), NoThunks (l EmptyMK)) =>
  NoThunks (DbChangelog l)
deriving instance
  (Show (TxIn l), Show (TxOut l), Show (l EmptyMK)) =>
  Show (DbChangelog l)

type DbChangelog' blk = DbChangelog (ExtLedgerState blk)

instance GetTip l => AS.Anchorable (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK) where
  asAnchor :: l EmptyMK -> l EmptyMK
asAnchor = l EmptyMK -> l EmptyMK
forall a. a -> a
id
  getAnchorMeasure :: Proxy (l EmptyMK) -> l EmptyMK -> WithOrigin SlotNo
getAnchorMeasure Proxy (l EmptyMK)
_ = l EmptyMK -> WithOrigin SlotNo
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot

instance IsLedger l => GetTip (K (DbChangelog l)) where
  getTip :: forall (mk :: * -> * -> *).
K (DbChangelog l) mk -> Point (K (DbChangelog l))
getTip =
    Point l -> Point (K (DbChangelog l))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint
      (Point l -> Point (K (DbChangelog l)))
-> (K (DbChangelog l) mk -> Point l)
-> K (DbChangelog l) mk
-> Point (K (DbChangelog l))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l EmptyMK -> Point l
forall (mk :: * -> * -> *). l mk -> Point l
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> Point l
getTip
      (l EmptyMK -> Point l)
-> (K (DbChangelog l) mk -> l EmptyMK)
-> K (DbChangelog l) mk
-> Point l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (l EmptyMK -> l EmptyMK)
-> (l EmptyMK -> l EmptyMK)
-> Either (l EmptyMK) (l EmptyMK)
-> l EmptyMK
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either l EmptyMK -> l EmptyMK
forall a. a -> a
id l EmptyMK -> l EmptyMK
forall a. a -> a
id
      (Either (l EmptyMK) (l EmptyMK) -> l EmptyMK)
-> (K (DbChangelog l) mk -> Either (l EmptyMK) (l EmptyMK))
-> K (DbChangelog l) mk
-> l EmptyMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
-> Either (l EmptyMK) (l EmptyMK)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AS.head
      (AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
 -> Either (l EmptyMK) (l EmptyMK))
-> (K (DbChangelog l) mk
    -> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> K (DbChangelog l) mk
-> Either (l EmptyMK) (l EmptyMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates
      (DbChangelog l
 -> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> (K (DbChangelog l) mk -> DbChangelog l)
-> K (DbChangelog l) mk
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K (DbChangelog l) mk -> DbChangelog l
forall {k} a (b :: k). K a b -> a
unK

type instance
  HeaderHash (K @MapKind (DbChangelog l)) =
    HeaderHash l

{-------------------------------------------------------------------------------
  Construction
-------------------------------------------------------------------------------}

-- | Creates an empty @DbChangelog@.
empty ::
  (HasLedgerTables l, GetTip l) =>
  l EmptyMK -> DbChangelog l
empty :: forall (l :: (* -> * -> *) -> *).
(HasLedgerTables l, GetTip l) =>
l EmptyMK -> DbChangelog l
empty l EmptyMK
theAnchor =
  DbChangelog
    { changelogLastFlushedState :: l EmptyMK
changelogLastFlushedState = l EmptyMK
theAnchor
    , changelogDiffs :: LedgerTables l SeqDiffMK
changelogDiffs = (forall k v. LedgerTableConstraints' l k v => SeqDiffMK k v)
-> LedgerTables l SeqDiffMK
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
LedgerTableConstraints l =>
(forall k v. LedgerTableConstraints' l k v => mk k v)
-> LedgerTables l mk
ltpure (DiffSeq k v -> SeqDiffMK k v
forall k v. DiffSeq k v -> SeqDiffMK k v
SeqDiffMK DiffSeq k v
forall k v. (Ord k, Eq v) => DiffSeq k v
DS.empty)
    , changelogStates :: AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates = l EmptyMK
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AS.Empty l EmptyMK
theAnchor
    }

{-------------------------------------------------------------------------------
  Mapping changelogs
-------------------------------------------------------------------------------}

reapplyBlock ::
  forall m l blk.
  (ApplyBlock l blk, Monad m) =>
  ComputeLedgerEvents ->
  LedgerCfg l ->
  blk ->
  KeySetsReader m l ->
  DbChangelog l ->
  m (l DiffMK)
reapplyBlock :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(ApplyBlock l blk, Monad m) =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> KeySetsReader m l
-> DbChangelog l
-> m (l DiffMK)
reapplyBlock ComputeLedgerEvents
evs LedgerCfg l
cfg blk
b KeySetsReader m l
ksReader DbChangelog l
db =
  l EmptyMK
-> KeySetsReader m l
-> DbChangelog l
-> LedgerTables l KeysMK
-> (l ValuesMK -> m (l DiffMK))
-> m (l DiffMK)
forall (l :: (* -> * -> *) -> *) (m :: * -> *) a.
(HasLedgerTables l, Monad m, GetTip l) =>
l EmptyMK
-> KeySetsReader m l
-> DbChangelog l
-> LedgerTables l KeysMK
-> (l ValuesMK -> m a)
-> m a
withKeysReadSets (DbChangelog l -> l EmptyMK
forall (l :: (* -> * -> *) -> *).
GetTip l =>
DbChangelog l -> l EmptyMK
current DbChangelog l
db) KeySetsReader m l
ksReader DbChangelog l
db (blk -> LedgerTables l KeysMK
forall (l :: (* -> * -> *) -> *) blk.
ApplyBlock l blk =>
blk -> LedgerTables l KeysMK
getBlockKeySets blk
b) (l DiffMK -> m (l DiffMK)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (l DiffMK -> m (l DiffMK))
-> (l ValuesMK -> l DiffMK) -> l ValuesMK -> m (l DiffMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComputeLedgerEvents -> LedgerCfg l -> blk -> l ValuesMK -> l DiffMK
forall (l :: (* -> * -> *) -> *) blk.
ApplyBlock l blk =>
ComputeLedgerEvents -> LedgerCfg l -> blk -> l ValuesMK -> l DiffMK
tickThenReapply ComputeLedgerEvents
evs LedgerCfg l
cfg blk
b)

-- | Apply a block on top of the ledger state and extend the DbChangelog with
-- the result ledger state.
reapplyThenPush ::
  (Monad m, ApplyBlock l blk) =>
  LedgerDbCfg l ->
  blk ->
  KeySetsReader m l ->
  DbChangelog l ->
  m (DbChangelog l)
reapplyThenPush :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(Monad m, ApplyBlock l blk) =>
LedgerDbCfg l
-> blk -> KeySetsReader m l -> DbChangelog l -> m (DbChangelog l)
reapplyThenPush LedgerDbCfg l
cfg blk
ap KeySetsReader m l
ksReader DbChangelog l
db =
  (\l DiffMK
current' -> LedgerDbPrune -> DbChangelog l -> DbChangelog l
forall (l :: (* -> * -> *) -> *).
GetTip l =>
LedgerDbPrune -> DbChangelog l -> DbChangelog l
prune (SecurityParam -> LedgerDbPrune
LedgerDbPruneKeeping (LedgerDbCfg l -> HKD Identity SecurityParam
forall (f :: * -> *) (l :: (* -> * -> *) -> *).
LedgerDbCfgF f l -> HKD f SecurityParam
ledgerDbCfgSecParam LedgerDbCfg l
cfg)) (DbChangelog l -> DbChangelog l) -> DbChangelog l -> DbChangelog l
forall a b. (a -> b) -> a -> b
$ l DiffMK -> DbChangelog l -> DbChangelog l
forall (l :: (* -> * -> *) -> *).
(GetTip l, HasLedgerTables l) =>
l DiffMK -> DbChangelog l -> DbChangelog l
extend l DiffMK
current' DbChangelog l
db)
    (l DiffMK -> DbChangelog l) -> m (l DiffMK) -> m (DbChangelog l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> KeySetsReader m l
-> DbChangelog l
-> m (l DiffMK)
forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(ApplyBlock l blk, Monad m) =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> KeySetsReader m l
-> DbChangelog l
-> m (l DiffMK)
reapplyBlock (LedgerDbCfg l -> ComputeLedgerEvents
forall (f :: * -> *) (l :: (* -> * -> *) -> *).
LedgerDbCfgF f l -> ComputeLedgerEvents
ledgerDbCfgComputeLedgerEvents LedgerDbCfg l
cfg) (LedgerDbCfg l -> HKD Identity (LedgerCfg l)
forall (f :: * -> *) (l :: (* -> * -> *) -> *).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
ledgerDbCfg LedgerDbCfg l
cfg) blk
ap KeySetsReader m l
ksReader DbChangelog l
db

-- | Prune oldest ledger states until at we have at most @k@ in the DbChangelog,
-- excluding the one stored at the anchor.
--
-- +--------------+----------------------------+----------------------+
-- | lastFlushed  | states                     | tableDiffs           |
-- +==============+============================+======================+
-- |     @L0@     | @L0 :> [ L1, L2, L3, L4 ]@ | @[ D1, D2, D3, D4 ]@ |
-- +--------------+----------------------------+----------------------+
-- | @>> prune (SecurityParam 3)@                                     |
-- +--------------+----------------------------+----------------------+
-- |     @L0@     | @L2 :> [         L3, L4 ]@ | @[ D1, D2, D3, D4 ]@ |
-- +--------------+----------------------------+----------------------+
prune ::
  GetTip l =>
  LedgerDbPrune ->
  DbChangelog l ->
  DbChangelog l
prune :: forall (l :: (* -> * -> *) -> *).
GetTip l =>
LedgerDbPrune -> DbChangelog l -> DbChangelog l
prune (LedgerDbPruneKeeping (SecurityParam NonZero Word64
k)) DbChangelog l
dblog =
  DbChangelog l
dblog{changelogStates = vol'}
 where
  DbChangelog{AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates :: forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates :: AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates} = DbChangelog l
dblog

  nvol :: Int
nvol = 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)
changelogStates

  vol' :: AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
vol' =
    if Int -> Word64
forall a. Enum a => Int -> a
toEnum Int
nvol Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k
      then AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates
      else (AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK),
 AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall a b. (a, b) -> b
snd ((AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK),
  AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
 -> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> (AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK),
    AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall a b. (a -> b) -> a -> b
$ Int
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
-> (AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK),
    AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> (AnchoredSeq v a b, AnchoredSeq v a b)
AS.splitAt (Int
nvol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Word64 -> Int
forall a. Enum a => a -> Int
fromEnum (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k)) AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates
prune LedgerDbPrune
LedgerDbPruneAll DbChangelog l
dblog =
  DbChangelog l
dblog{changelogStates = vol'}
 where
  DbChangelog{AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates :: forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates :: AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates} = DbChangelog l
dblog

  nvol :: Int
nvol = 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)
changelogStates

  vol' :: AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
vol' =
    (AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK),
 AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall a b. (a, b) -> b
snd ((AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK),
  AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
 -> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> (AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK),
    AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall a b. (a -> b) -> a -> b
$ Int
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
-> (AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK),
    AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> (AnchoredSeq v a b, AnchoredSeq v a b)
AS.splitAt Int
nvol AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates

-- NOTE: we must inline 'prune' otherwise we get unexplained thunks in
-- 'DbChangelog' and thus a space leak. Alternatively, we could disable the
-- @-fstrictness@ optimisation (enabled by default for -O1). See
-- https://github.com/IntersectMBO/ouroboros-network/pull/2532.
--
-- NOTE (@js): this INLINE was inherited from before UTxO-HD, so maybe it is not
-- needed anymore.
{-# INLINE prune #-}

-- | Extending the DbChangelog with a valid ledger state.
--
-- +------+----------------------------+----------------------+
-- | @L2@ | @L2 :> [ L3, L4, L5 ]@     | @[ D3, D4, D5 ]@     |
-- +------+----------------------------+----------------------+
-- | @>> extend L6 (D6)@                                      |
-- +------+----------------------------+----------------------+
-- | @L2@ | @L2 :> [ L3, L4, L5, L6 ]@ | @[ D3, D4, D5, D6 ]@ |
-- +------+----------------------------+----------------------+
extend ::
  (GetTip l, HasLedgerTables l) =>
  l DiffMK ->
  DbChangelog l ->
  DbChangelog l
extend :: forall (l :: (* -> * -> *) -> *).
(GetTip l, HasLedgerTables l) =>
l DiffMK -> DbChangelog l -> DbChangelog l
extend l DiffMK
newState DbChangelog l
dblog =
  DbChangelog
    { changelogLastFlushedState :: l EmptyMK
changelogLastFlushedState = l EmptyMK
changelogLastFlushedState
    , changelogDiffs :: LedgerTables l SeqDiffMK
changelogDiffs = (forall k v.
 LedgerTableConstraints' l k v =>
 SeqDiffMK k v -> DiffMK k v -> SeqDiffMK k v)
-> LedgerTables l SeqDiffMK
-> LedgerTables l DiffMK
-> LedgerTables l SeqDiffMK
forall (l :: (* -> * -> *) -> *) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *) (mk3 :: * -> * -> *).
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 SeqDiffMK k v -> DiffMK k v -> SeqDiffMK k v
forall k v.
(Ord k, Eq v) =>
SeqDiffMK k v -> DiffMK k v -> SeqDiffMK k v
forall k v.
LedgerTableConstraints' l k v =>
SeqDiffMK k v -> DiffMK k v -> SeqDiffMK k v
ext LedgerTables l SeqDiffMK
changelogDiffs LedgerTables l DiffMK
tablesDiff
    , changelogStates :: AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates = AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
-> l EmptyMK
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
AS.:> l EmptyMK
l'
    }
 where
  slot :: SlotNo
slot = case l EmptyMK -> WithOrigin SlotNo
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot l EmptyMK
l' of
    WithOrigin SlotNo
Origin -> String -> SlotNo
forall a. HasCallStack => String -> a
error String
"impossible! extending a DbChangelog with a state at Origin"
    At SlotNo
s -> SlotNo
s

  ext ::
    (Ord k, Eq v) =>
    SeqDiffMK k v ->
    DiffMK k v ->
    SeqDiffMK k v
  ext :: forall k v.
(Ord k, Eq v) =>
SeqDiffMK k v -> DiffMK k v -> SeqDiffMK k v
ext (SeqDiffMK DiffSeq k v
sq) (DiffMK Diff k v
d) =
    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
$ DiffSeq k v -> SlotNo -> Diff k v -> DiffSeq k v
forall k v.
SM k v =>
DiffSeq k v -> SlotNo -> Diff k v -> DiffSeq k v
DS.extend DiffSeq k v
sq SlotNo
slot (Diff k v -> DiffSeq k v) -> Diff k v -> DiffSeq k v
forall a b. (a -> b) -> a -> b
$ Diff k v -> Diff k v
forall k v. Diff k v -> Diff k v
DS.toAntiDiff Diff k v
d

  l' :: l EmptyMK
l' = l DiffMK -> l EmptyMK
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables l DiffMK
newState
  tablesDiff :: LedgerTables l DiffMK
tablesDiff = l DiffMK -> LedgerTables l DiffMK
forall (mk :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l mk -> LedgerTables l mk
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l mk -> LedgerTables l mk
projectLedgerTables l DiffMK
newState

  DbChangelog
    { l EmptyMK
changelogLastFlushedState :: forall (l :: (* -> * -> *) -> *). DbChangelog l -> l EmptyMK
changelogLastFlushedState :: l EmptyMK
changelogLastFlushedState
    , LedgerTables l SeqDiffMK
changelogDiffs :: forall (l :: (* -> * -> *) -> *).
DbChangelog l -> LedgerTables l SeqDiffMK
changelogDiffs :: LedgerTables l SeqDiffMK
changelogDiffs
    , AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates :: forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates :: AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates
    } = DbChangelog l
dblog

{-------------------------------------------------------------------------------
  Read
-------------------------------------------------------------------------------}

type KeySetsReader m l = l EmptyMK -> LedgerTables l KeysMK -> m (UnforwardedReadSets l)

readKeySets ::
  IOLike m =>
  LedgerBackingStore m l ->
  KeySetsReader m l
readKeySets :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
IOLike m =>
LedgerBackingStore m l -> KeySetsReader m l
readKeySets LedgerBackingStore m l
backingStore l EmptyMK
st LedgerTables l KeysMK
rew = do
  LedgerBackingStore m l
-> (BackingStoreValueHandle
      m (LedgerTables l KeysMK) (LedgerTables l ValuesMK)
    -> m (UnforwardedReadSets l))
-> m (UnforwardedReadSets l)
forall (m :: * -> *) keys values diff a.
MonadThrow m =>
BackingStore m keys values diff
-> (BackingStoreValueHandle m keys values -> m a) -> m a
withBsValueHandle LedgerBackingStore m l
backingStore (\BackingStoreValueHandle
  m (LedgerTables l KeysMK) (LedgerTables l ValuesMK)
bsvh -> BackingStoreValueHandle
  m (LedgerTables l KeysMK) (LedgerTables l ValuesMK)
-> KeySetsReader m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
Monad m =>
LedgerBackingStoreValueHandle m l -> KeySetsReader m l
readKeySetsWith BackingStoreValueHandle
  m (LedgerTables l KeysMK) (LedgerTables l ValuesMK)
bsvh l EmptyMK
st LedgerTables l KeysMK
rew)

readKeySetsWith ::
  Monad m =>
  LedgerBackingStoreValueHandle m l ->
  KeySetsReader m l
readKeySetsWith :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
Monad m =>
LedgerBackingStoreValueHandle m l -> KeySetsReader m l
readKeySetsWith LedgerBackingStoreValueHandle m l
bsvh l EmptyMK
st LedgerTables l KeysMK
rew = do
  values <- LedgerBackingStoreValueHandle m l
-> ReadHint (LedgerTables l ValuesMK)
-> LedgerTables l KeysMK
-> m (LedgerTables l ValuesMK)
forall (m :: * -> *) keys values.
BackingStoreValueHandle m keys values
-> ReadHint values -> keys -> m values
bsvhRead LedgerBackingStoreValueHandle m l
bsvh l EmptyMK
ReadHint (LedgerTables l ValuesMK)
st LedgerTables l KeysMK
rew
  pure
    UnforwardedReadSets
      { ursSeqNo = bsvhAtSlot bsvh
      , ursValues = values
      , ursKeys = rew
      }

withKeysReadSets ::
  (HasLedgerTables l, Monad m, GetTip l) =>
  l EmptyMK ->
  KeySetsReader m l ->
  DbChangelog l ->
  LedgerTables l KeysMK ->
  (l ValuesMK -> m a) ->
  m a
withKeysReadSets :: forall (l :: (* -> * -> *) -> *) (m :: * -> *) a.
(HasLedgerTables l, Monad m, GetTip l) =>
l EmptyMK
-> KeySetsReader m l
-> DbChangelog l
-> LedgerTables l KeysMK
-> (l ValuesMK -> m a)
-> m a
withKeysReadSets l EmptyMK
st KeySetsReader m l
ksReader DbChangelog l
dbch LedgerTables l KeysMK
ks l ValuesMK -> m a
f = do
  urs <- KeySetsReader m l
ksReader l EmptyMK
st LedgerTables l KeysMK
ks
  case withHydratedLedgerState urs of
    Left RewindReadFwdError
err ->
      -- We performed the rewind;read;forward sequence in this function. So
      -- the forward operation should not fail. If this is the case we're in
      -- the presence of a problem that we cannot deal with at this level,
      -- so we throw an error.
      --
      -- When we introduce pipelining, if the forward operation fails it
      -- could be because the DB handle was modified by a DB flush that took
      -- place when __after__ we read the unforwarded keys-set from disk.
      -- However, performing rewind;read;forward with the same __locked__
      -- changelog should always succeed.
      String -> m a
forall a. HasCallStack => String -> a
error (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Changelog rewind;read;forward sequence failed, " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> RewindReadFwdError -> String
forall a. Show a => a -> String
show RewindReadFwdError
err
    Right m a
res -> m a
res
 where
  withHydratedLedgerState :: UnforwardedReadSets l -> Either RewindReadFwdError (m a)
withHydratedLedgerState UnforwardedReadSets l
urs =
    l ValuesMK -> m a
f
      (l ValuesMK -> m a)
-> (LedgerTables l ValuesMK -> l ValuesMK)
-> LedgerTables l ValuesMK
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l EmptyMK -> LedgerTables l ValuesMK -> l ValuesMK
forall (mk :: * -> * -> *) (any :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *)
       (any :: * -> * -> *).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
withLedgerTables l EmptyMK
st
      (LedgerTables l ValuesMK -> m a)
-> Either RewindReadFwdError (LedgerTables l ValuesMK)
-> Either RewindReadFwdError (m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DbChangelog l
-> UnforwardedReadSets l
-> Either RewindReadFwdError (LedgerTables l ValuesMK)
forall (l :: (* -> * -> *) -> *).
(HasLedgerTables l, GetTip l) =>
DbChangelog l
-> UnforwardedReadSets l
-> Either RewindReadFwdError (LedgerTables l ValuesMK)
forwardTableKeySets DbChangelog l
dbch UnforwardedReadSets l
urs

trivialKeySetsReader ::
  (Monad m, LedgerTablesAreTrivial l) =>
  WithOrigin SlotNo ->
  KeySetsReader m l
trivialKeySetsReader :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
(Monad m, LedgerTablesAreTrivial l) =>
WithOrigin SlotNo -> KeySetsReader m l
trivialKeySetsReader WithOrigin SlotNo
s l EmptyMK
_st LedgerTables l KeysMK
_ =
  UnforwardedReadSets l -> m (UnforwardedReadSets l)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnforwardedReadSets l -> m (UnforwardedReadSets l))
-> UnforwardedReadSets l -> m (UnforwardedReadSets l)
forall a b. (a -> b) -> a -> b
$ WithOrigin SlotNo
-> LedgerTables l ValuesMK
-> LedgerTables l KeysMK
-> UnforwardedReadSets l
forall (l :: (* -> * -> *) -> *).
WithOrigin SlotNo
-> LedgerTables l ValuesMK
-> LedgerTables l KeysMK
-> UnforwardedReadSets l
UnforwardedReadSets WithOrigin SlotNo
s LedgerTables l ValuesMK
forall (mk :: * -> * -> *) (l :: (* -> * -> *) -> *).
(ZeroableMK mk, LedgerTablesAreTrivial l) =>
LedgerTables l mk
trivialLedgerTables LedgerTables l KeysMK
forall (mk :: * -> * -> *) (l :: (* -> * -> *) -> *).
(ZeroableMK mk, LedgerTablesAreTrivial l) =>
LedgerTables l mk
trivialLedgerTables

{-------------------------------------------------------------------------------
  Forward
-------------------------------------------------------------------------------}

data UnforwardedReadSets l = UnforwardedReadSets
  { forall (l :: (* -> * -> *) -> *).
UnforwardedReadSets l -> WithOrigin SlotNo
ursSeqNo :: !(WithOrigin SlotNo)
  -- ^ The Slot number of the anchor of the 'DbChangelog' that was used when
  -- rewinding and reading.
  , forall (l :: (* -> * -> *) -> *).
UnforwardedReadSets l -> LedgerTables l ValuesMK
ursValues :: !(LedgerTables l ValuesMK)
  -- ^ The values that were found in the 'BackingStore'.
  , forall (l :: (* -> * -> *) -> *).
UnforwardedReadSets l -> LedgerTables l KeysMK
ursKeys :: !(LedgerTables l KeysMK)
  -- ^ All the requested keys, being or not present in the 'BackingStore'.
  }

-- | The DbChangelog and the BackingStore got out of sync. This is a critical
-- error, we cannot recover from this.
data RewindReadFwdError = RewindReadFwdError
  { RewindReadFwdError -> WithOrigin SlotNo
rrfBackingStoreAt :: !(WithOrigin SlotNo)
  , RewindReadFwdError -> WithOrigin SlotNo
rrfDbChangelogAt :: !(WithOrigin SlotNo)
  }
  deriving Int -> RewindReadFwdError -> ShowS
[RewindReadFwdError] -> ShowS
RewindReadFwdError -> String
(Int -> RewindReadFwdError -> ShowS)
-> (RewindReadFwdError -> String)
-> ([RewindReadFwdError] -> ShowS)
-> Show RewindReadFwdError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RewindReadFwdError -> ShowS
showsPrec :: Int -> RewindReadFwdError -> ShowS
$cshow :: RewindReadFwdError -> String
show :: RewindReadFwdError -> String
$cshowList :: [RewindReadFwdError] -> ShowS
showList :: [RewindReadFwdError] -> ShowS
Show

forwardTableKeySets' ::
  HasLedgerTables l =>
  WithOrigin SlotNo ->
  LedgerTables l SeqDiffMK ->
  UnforwardedReadSets l ->
  Either
    RewindReadFwdError
    (LedgerTables l ValuesMK)
forwardTableKeySets' :: forall (l :: (* -> * -> *) -> *).
HasLedgerTables l =>
WithOrigin SlotNo
-> LedgerTables l SeqDiffMK
-> UnforwardedReadSets l
-> Either RewindReadFwdError (LedgerTables l ValuesMK)
forwardTableKeySets' WithOrigin SlotNo
seqNo LedgerTables l SeqDiffMK
chdiffs = \(UnforwardedReadSets WithOrigin SlotNo
seqNo' LedgerTables l ValuesMK
values LedgerTables l KeysMK
keys) ->
  if WithOrigin SlotNo
seqNo WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
/= WithOrigin SlotNo
seqNo'
    then RewindReadFwdError
-> Either RewindReadFwdError (LedgerTables l ValuesMK)
forall a b. a -> Either a b
Left (RewindReadFwdError
 -> Either RewindReadFwdError (LedgerTables l ValuesMK))
-> RewindReadFwdError
-> Either RewindReadFwdError (LedgerTables l ValuesMK)
forall a b. (a -> b) -> a -> b
$ WithOrigin SlotNo -> WithOrigin SlotNo -> RewindReadFwdError
RewindReadFwdError WithOrigin SlotNo
seqNo' WithOrigin SlotNo
seqNo
    else LedgerTables l ValuesMK
-> Either RewindReadFwdError (LedgerTables l ValuesMK)
forall a b. b -> Either a b
Right (LedgerTables l ValuesMK
 -> Either RewindReadFwdError (LedgerTables l ValuesMK))
-> LedgerTables l ValuesMK
-> Either RewindReadFwdError (LedgerTables l ValuesMK)
forall a b. (a -> b) -> a -> b
$ (forall k v.
 LedgerTableConstraints' l k v =>
 ValuesMK k v -> KeysMK k v -> SeqDiffMK k v -> ValuesMK k v)
-> LedgerTables l ValuesMK
-> LedgerTables l KeysMK
-> LedgerTables l SeqDiffMK
-> LedgerTables l ValuesMK
forall (l :: (* -> * -> *) -> *) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *) (mk3 :: * -> * -> *) (mk4 :: * -> * -> *).
LedgerTableConstraints l =>
(forall k v.
 LedgerTableConstraints' l k v =>
 mk1 k v -> mk2 k v -> mk3 k v -> mk4 k v)
-> LedgerTables l mk1
-> LedgerTables l mk2
-> LedgerTables l mk3
-> LedgerTables l mk4
ltliftA3 ValuesMK k v -> KeysMK k v -> SeqDiffMK k v -> ValuesMK k v
forall k v.
(Ord k, Eq v) =>
ValuesMK k v -> KeysMK k v -> SeqDiffMK k v -> ValuesMK k v
forall k v.
LedgerTableConstraints' l k v =>
ValuesMK k v -> KeysMK k v -> SeqDiffMK k v -> ValuesMK k v
forward LedgerTables l ValuesMK
values LedgerTables l KeysMK
keys LedgerTables l SeqDiffMK
chdiffs
 where
  forward ::
    (Ord k, Eq v) =>
    ValuesMK k v ->
    KeysMK k v ->
    SeqDiffMK k v ->
    ValuesMK k v
  forward :: forall k v.
(Ord k, Eq v) =>
ValuesMK k v -> KeysMK k v -> SeqDiffMK k v -> ValuesMK k v
forward (ValuesMK Map k v
values) (KeysMK Set k
keys) (SeqDiffMK DiffSeq k v
diffs) =
    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
$ Map k v -> Set k -> Diff k v -> Map k v
forall k v. Ord k => Map k v -> Set k -> Diff k v -> Map k v
AntiDiff.applyDiffForKeys Map k v
values Set k
keys (DiffSeq k v -> Diff k v
forall k v. SM k v => DiffSeq k v -> Diff k v
DS.cumulativeDiff DiffSeq k v
diffs)

forwardTableKeySets ::
  (HasLedgerTables l, GetTip l) =>
  DbChangelog l ->
  UnforwardedReadSets l ->
  Either
    RewindReadFwdError
    (LedgerTables l ValuesMK)
forwardTableKeySets :: forall (l :: (* -> * -> *) -> *).
(HasLedgerTables l, GetTip l) =>
DbChangelog l
-> UnforwardedReadSets l
-> Either RewindReadFwdError (LedgerTables l ValuesMK)
forwardTableKeySets DbChangelog l
dblog =
  WithOrigin SlotNo
-> LedgerTables l SeqDiffMK
-> UnforwardedReadSets l
-> Either RewindReadFwdError (LedgerTables l ValuesMK)
forall (l :: (* -> * -> *) -> *).
HasLedgerTables l =>
WithOrigin SlotNo
-> LedgerTables l SeqDiffMK
-> UnforwardedReadSets l
-> Either RewindReadFwdError (LedgerTables l ValuesMK)
forwardTableKeySets'
    (l EmptyMK -> WithOrigin SlotNo
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
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 :: (* -> * -> *) -> *). DbChangelog l -> l EmptyMK
changelogLastFlushedState DbChangelog l
dblog)
    (DbChangelog l -> LedgerTables l SeqDiffMK
forall (l :: (* -> * -> *) -> *).
DbChangelog l -> LedgerTables l SeqDiffMK
changelogDiffs DbChangelog l
dblog)

{-------------------------------------------------------------------------------
  Reset
-------------------------------------------------------------------------------}

-- | When creating a new @DbChangelog@, we should load whichever snapshot we
-- find and then replay the chain up to the immutable tip. When we get there,
-- the @DbChangelog@ will have a @k@-long sequence of states, which all come
-- from immutable blocks, so we just prune all of them and only keep the last
-- one as an anchor, as it is the immutable tip. Then we can proceed with
-- opening the VolatileDB.
--
-- If we didn't do this step, the @DbChangelog@ would accept rollbacks into the
-- immutable part of the chain, which must never be possible.
--
-- +--------------+----------------------------+----------------------+
-- |  lastFlushed | states                     | tableDiffs           |
-- +==============+============================+======================+
-- |     @L0@     | @L0 :> [ L1, L2, L3, L4 ]@ | @[ D1, D2, D3, D4 ]@ |
-- +--------------+----------------------------+----------------------+
-- | @>> pruneToImmTipOnly@                                           |
-- +--------------+----------------------------+----------------------+
-- |     @L0@     | @L4 :> [                ]@ | @[ D1, D2, D3, D4 ]@ |
-- +--------------+----------------------------+----------------------+
pruneToImmTipOnly ::
  GetTip l =>
  DbChangelog l ->
  DbChangelog l
pruneToImmTipOnly :: forall (l :: (* -> * -> *) -> *).
GetTip l =>
DbChangelog l -> DbChangelog l
pruneToImmTipOnly = LedgerDbPrune -> DbChangelog l -> DbChangelog l
forall (l :: (* -> * -> *) -> *).
GetTip l =>
LedgerDbPrune -> DbChangelog l -> DbChangelog l
prune LedgerDbPrune
LedgerDbPruneAll

{-------------------------------------------------------------------------------
  Internal: rolling back
-------------------------------------------------------------------------------}

-- | Rollback @n@ ledger states.
--
-- Returns 'Nothing' if maximum rollback (usually @k@, but can be less on
-- startup or under corruption) is exceeded.
--
-- +--------------+------------------------+--------------------------+
-- |  lastFlushed | states                 | tableDiffs               |
-- +==============+========================+==========================+
-- |     @L2@     | @L3 :> [ L4, L5, L6 ]@ | @[ D2, D3, D4, D5, D6 ]@ |
-- +--------------+------------------------+--------------------------+
-- | @>> rollback 3@                                                  |
-- +--------------+------------------------+--------------------------+
-- |     @L2@     | @L3 :> [ ]           @ | @[ D2, D3             ]@ |
-- +--------------+------------------------+--------------------------+
rollbackN ::
  (GetTip l, HasLedgerTables l) =>
  Word64 ->
  DbChangelog l ->
  Maybe (DbChangelog l)
rollbackN :: forall (l :: (* -> * -> *) -> *).
(GetTip l, HasLedgerTables l) =>
Word64 -> DbChangelog l -> Maybe (DbChangelog l)
rollbackN Word64
n DbChangelog l
dblog
  | Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= DbChangelog l -> Word64
forall (l :: (* -> * -> *) -> *).
GetTip l =>
DbChangelog l -> Word64
maxRollback DbChangelog l
dblog =
      DbChangelog l -> Maybe (DbChangelog l)
forall a. a -> Maybe a
Just (DbChangelog l -> Maybe (DbChangelog l))
-> DbChangelog l -> Maybe (DbChangelog l)
forall a b. (a -> b) -> a -> b
$
        DbChangelog l
dblog
          { changelogDiffs = ltmap truncSeqDiff changelogDiffs
          , changelogStates = AS.dropNewest (fromIntegral n) changelogStates
          }
  | Bool
otherwise =
      Maybe (DbChangelog l)
forall a. Maybe a
Nothing
 where
  truncSeqDiff :: (Ord k, Eq v) => SeqDiffMK k v -> SeqDiffMK k v
  truncSeqDiff :: forall k v. (Ord k, Eq v) => SeqDiffMK k v -> SeqDiffMK k v
truncSeqDiff (SeqDiffMK DiffSeq k v
sq) =
    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
$ (DiffSeq k v, DiffSeq k v) -> DiffSeq k v
forall a b. (a, b) -> a
fst ((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
$ Int -> DiffSeq k v -> (DiffSeq k v, DiffSeq k v)
forall k v.
(SM k v, HasCallStack) =>
Int -> DiffSeq k v -> (DiffSeq k v, DiffSeq k v)
DS.splitAtFromEnd (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) DiffSeq k v
sq

  DbChangelog
    { LedgerTables l SeqDiffMK
changelogDiffs :: forall (l :: (* -> * -> *) -> *).
DbChangelog l -> LedgerTables l SeqDiffMK
changelogDiffs :: LedgerTables l SeqDiffMK
changelogDiffs
    , AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates :: forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates :: AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates
    } = DbChangelog l
dblog

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

-- | " Flush " the 'DbChangelog' by splitting it into the diffs that should be
-- flushed and the new 'DbChangelog'.
--
-- +--------------+------------------------+------------------------------------------+
-- |  lastFlushed | states                 | tableDiffs                               |
-- +==============+========================+==========================================+
-- |     @L2@     | @L3 :> [ L4, L5, L6 ]@ | @[ D2, D3, D4, D5, D6 ]@                 |
-- +--------------+------------------------+------------------------------------------+
-- | @>> splitForFlushing@                                                            |
-- +--------------+------------------------+------------------------------------------+
-- |     @L2@     | --                     | @[ D2, D3 ] -- this is a 'DiffsToFlush'@ |
-- +--------------+------------------------+------------------------------------------+
-- |     @L3@     | @L3 :> [ L4, L5, L6 ]@ | @[         D4, D5, D6 ]@                 |
-- +--------------+------------------------+------------------------------------------+
splitForFlushing ::
  forall l.
  (GetTip l, HasLedgerTables l) =>
  DbChangelog l ->
  (Maybe (DiffsToFlush l), DbChangelog l)
splitForFlushing :: forall (l :: (* -> * -> *) -> *).
(GetTip l, HasLedgerTables l) =>
DbChangelog l -> (Maybe (DiffsToFlush l), DbChangelog l)
splitForFlushing DbChangelog l
dblog =
  if l EmptyMK -> WithOrigin SlotNo
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot l EmptyMK
immTip WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== WithOrigin SlotNo
forall t. WithOrigin t
Origin Bool -> Bool -> Bool
|| LedgerTables l (K2 Int) -> Int
forall (l :: (* -> * -> *) -> *) a. LedgerTables l (K2 a) -> a
ltcollapse ((forall k v.
 LedgerTableConstraints' l k v =>
 SeqDiffMK k v -> K2 Int k v)
-> LedgerTables l SeqDiffMK -> LedgerTables l (K2 Int)
forall (l :: (* -> * -> *) -> *) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *).
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
. DiffSeq k v -> Int
forall k v. SM k v => DiffSeq k v -> Int
DS.length (DiffSeq k v -> Int)
-> (SeqDiffMK k v -> DiffSeq k v) -> SeqDiffMK k v -> 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
l) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
    then (Maybe (DiffsToFlush l)
forall a. Maybe a
Nothing, DbChangelog l
dblog)
    else (DiffsToFlush l -> Maybe (DiffsToFlush l)
forall a. a -> Maybe a
Just DiffsToFlush l
ldblog, DbChangelog l
rdblog)
 where
  DbChangelog
    { l EmptyMK
changelogLastFlushedState :: forall (l :: (* -> * -> *) -> *). DbChangelog l -> l EmptyMK
changelogLastFlushedState :: l EmptyMK
changelogLastFlushedState
    , LedgerTables l SeqDiffMK
changelogDiffs :: forall (l :: (* -> * -> *) -> *).
DbChangelog l -> LedgerTables l SeqDiffMK
changelogDiffs :: LedgerTables l SeqDiffMK
changelogDiffs
    , AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates :: forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates :: AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates
    } = DbChangelog l
dblog

  immTip :: l EmptyMK
immTip = 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)
changelogStates

  splitSeqDiff ::
    (Ord k, Eq v) =>
    SeqDiffMK k v ->
    (SeqDiffMK k v, SeqDiffMK k v)
  splitSeqDiff :: forall k v.
(Ord k, Eq v) =>
SeqDiffMK k v -> (SeqDiffMK k v, SeqDiffMK k v)
splitSeqDiff (SeqDiffMK DiffSeq k v
sq) =
    let numToFlush :: Int
numToFlush = DiffSeq k v -> Int
forall k v. SM k v => DiffSeq k v -> Int
DS.length DiffSeq k v
sq Int -> Int -> Int
forall a. Num a => a -> a -> a
- 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)
changelogStates
     in (Maybe (DiffSeq k v) -> SeqDiffMK k v)
-> (DiffSeq k v -> SeqDiffMK k v)
-> (Maybe (DiffSeq k v), DiffSeq k v)
-> (SeqDiffMK k v, SeqDiffMK k v)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (SeqDiffMK k v
-> (DiffSeq k v -> SeqDiffMK k v)
-> Maybe (DiffSeq k v)
-> SeqDiffMK k v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SeqDiffMK k v
forall k v. (Ord k, Eq v) => SeqDiffMK k v
forall (mk :: * -> * -> *) k v.
(ZeroableMK mk, Ord k, Eq v) =>
mk k v
emptyMK DiffSeq k v -> SeqDiffMK k v
forall k v. DiffSeq k v -> SeqDiffMK k v
SeqDiffMK) DiffSeq k v -> SeqDiffMK k v
forall k v. DiffSeq k v -> SeqDiffMK k v
SeqDiffMK ((Maybe (DiffSeq k v), DiffSeq k v)
 -> (SeqDiffMK k v, SeqDiffMK k v))
-> (Maybe (DiffSeq k v), DiffSeq k v)
-> (SeqDiffMK k v, SeqDiffMK k v)
forall a b. (a -> b) -> a -> b
$
          if Int
numToFlush Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            then
              let (DiffSeq k v
tf, DiffSeq k v
tk) = Int -> DiffSeq k v -> (DiffSeq k v, DiffSeq k v)
forall k v.
SM k v =>
Int -> DiffSeq k v -> (DiffSeq k v, DiffSeq k v)
DS.splitAt Int
numToFlush DiffSeq k v
sq
               in (DiffSeq k v -> Maybe (DiffSeq k v)
forall a. a -> Maybe a
Just DiffSeq k v
tf, DiffSeq k v
tk)
            else (Maybe (DiffSeq k v)
forall a. Maybe a
Nothing, DiffSeq k v
sq)

  lr :: LedgerTables l (Product2 SeqDiffMK SeqDiffMK)
lr = (forall k v.
 LedgerTableConstraints' l k v =>
 SeqDiffMK k v -> Product2 SeqDiffMK SeqDiffMK k v)
-> LedgerTables l SeqDiffMK
-> LedgerTables l (Product2 SeqDiffMK SeqDiffMK)
forall (l :: (* -> * -> *) -> *) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *).
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
 -> SeqDiffMK k v -> Product2 SeqDiffMK SeqDiffMK k v)
-> (SeqDiffMK k v, SeqDiffMK k v)
-> Product2 SeqDiffMK SeqDiffMK k v
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SeqDiffMK k v -> SeqDiffMK k v -> Product2 SeqDiffMK SeqDiffMK k v
forall (f :: * -> * -> *) (g :: * -> * -> *) x y.
f x y -> g x y -> Product2 f g x y
Pair2 ((SeqDiffMK k v, SeqDiffMK k v)
 -> Product2 SeqDiffMK SeqDiffMK k v)
-> (SeqDiffMK k v -> (SeqDiffMK k v, SeqDiffMK k v))
-> SeqDiffMK k v
-> Product2 SeqDiffMK SeqDiffMK k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SeqDiffMK k v -> (SeqDiffMK k v, SeqDiffMK k v)
forall k v.
(Ord k, Eq v) =>
SeqDiffMK k v -> (SeqDiffMK k v, SeqDiffMK k v)
splitSeqDiff) LedgerTables l SeqDiffMK
changelogDiffs
  l :: LedgerTables l SeqDiffMK
l = (forall k v.
 LedgerTableConstraints' l k v =>
 Product2 SeqDiffMK SeqDiffMK k v -> SeqDiffMK k v)
-> LedgerTables l (Product2 SeqDiffMK SeqDiffMK)
-> LedgerTables l SeqDiffMK
forall (l :: (* -> * -> *) -> *) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *).
LedgerTableConstraints l =>
(forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2
ltmap (\(Pair2 SeqDiffMK k v
x SeqDiffMK k v
_) -> SeqDiffMK k v
x) LedgerTables l (Product2 SeqDiffMK SeqDiffMK)
lr
  r :: LedgerTables l SeqDiffMK
r = (forall k v.
 LedgerTableConstraints' l k v =>
 Product2 SeqDiffMK SeqDiffMK k v -> SeqDiffMK k v)
-> LedgerTables l (Product2 SeqDiffMK SeqDiffMK)
-> LedgerTables l SeqDiffMK
forall (l :: (* -> * -> *) -> *) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *).
LedgerTableConstraints l =>
(forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2
ltmap (\(Pair2 SeqDiffMK k v
_ SeqDiffMK k v
y) -> SeqDiffMK k v
y) LedgerTables l (Product2 SeqDiffMK SeqDiffMK)
lr

  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)

  ldblog :: DiffsToFlush l
ldblog =
    DiffsToFlush
      { toFlushDiffs :: LedgerTables l DiffMK
toFlushDiffs = (forall k v.
 LedgerTableConstraints' l k v =>
 SeqDiffMK k v -> DiffMK k v)
-> LedgerTables l SeqDiffMK -> LedgerTables l DiffMK
forall (l :: (* -> * -> *) -> *) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *).
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
l
      , toFlushState :: (l EmptyMK, l EmptyMK)
toFlushState = (l EmptyMK
changelogLastFlushedState, l EmptyMK
immTip)
      , toFlushSlot :: SlotNo
toFlushSlot =
          SlotNo -> WithOrigin SlotNo -> SlotNo
forall t. t -> WithOrigin t -> t
fromWithOrigin (String -> SlotNo
forall a. HasCallStack => String -> a
error String
"Flushing a DbChangelog at origin should never happen") (WithOrigin SlotNo -> SlotNo) -> WithOrigin SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$
            l EmptyMK -> WithOrigin SlotNo
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot l EmptyMK
immTip
      }

  rdblog :: DbChangelog l
rdblog =
    DbChangelog
      { changelogLastFlushedState :: l EmptyMK
changelogLastFlushedState = l EmptyMK
immTip
      , changelogDiffs :: LedgerTables l SeqDiffMK
changelogDiffs = LedgerTables l SeqDiffMK
r
      , changelogStates :: AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates = AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates
      }

{-------------------------------------------------------------------------------
  Queries
-------------------------------------------------------------------------------}

-- | The ledger state at the tip of the chain
current :: GetTip l => DbChangelog l -> l EmptyMK
current :: forall (l :: (* -> * -> *) -> *).
GetTip l =>
DbChangelog l -> l EmptyMK
current =
  (l EmptyMK -> l EmptyMK)
-> (l EmptyMK -> l EmptyMK)
-> Either (l EmptyMK) (l EmptyMK)
-> l EmptyMK
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either l EmptyMK -> l EmptyMK
forall a. a -> a
id l EmptyMK -> l EmptyMK
forall a. a -> a
id
    (Either (l EmptyMK) (l EmptyMK) -> l EmptyMK)
-> (DbChangelog l -> Either (l EmptyMK) (l EmptyMK))
-> DbChangelog l
-> l EmptyMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
-> Either (l EmptyMK) (l EmptyMK)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AS.head
    (AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
 -> Either (l EmptyMK) (l EmptyMK))
-> (DbChangelog l
    -> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> DbChangelog l
-> Either (l EmptyMK) (l EmptyMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates

-- | The ledger state at the anchor of the Volatile chain (i.e. the immutable
-- tip).
anchor :: DbChangelog l -> l EmptyMK
anchor :: forall (l :: (* -> * -> *) -> *). DbChangelog l -> l EmptyMK
anchor =
  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)
 -> l EmptyMK)
-> (DbChangelog l
    -> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> DbChangelog l
-> l EmptyMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates

-- | All snapshots currently stored by the ledger DB (new to old)
--
-- This also includes the snapshot at the anchor. For each snapshot we also
-- return the distance from the tip.
snapshots :: DbChangelog l -> [(Word64, l EmptyMK)]
snapshots :: forall (l :: (* -> * -> *) -> *).
DbChangelog l -> [(Word64, l EmptyMK)]
snapshots =
  [Word64] -> [l EmptyMK] -> [(Word64, l EmptyMK)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word64
0 ..]
    ([l EmptyMK] -> [(Word64, l EmptyMK)])
-> (DbChangelog l -> [l EmptyMK])
-> DbChangelog l
-> [(Word64, l EmptyMK)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
-> [l EmptyMK]
forall v a b. AnchoredSeq v a b -> [b]
AS.toNewestFirst
    (AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
 -> [l EmptyMK])
-> (DbChangelog l
    -> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> DbChangelog l
-> [l EmptyMK]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates

-- | How many blocks can we currently roll back?
maxRollback :: GetTip l => DbChangelog l -> Word64
maxRollback :: forall (l :: (* -> * -> *) -> *).
GetTip l =>
DbChangelog l -> Word64
maxRollback =
  Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    (Int -> Word64)
-> (DbChangelog l -> Int) -> DbChangelog l -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) -> Int)
-> (DbChangelog l
    -> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> DbChangelog l
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates

-- | Reference to the block at the tip of the chain
tip :: GetTip l => DbChangelog l -> Point l
tip :: forall (l :: (* -> * -> *) -> *).
GetTip l =>
DbChangelog l -> Point l
tip = Point l -> Point l
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point l -> Point l)
-> (DbChangelog l -> Point l) -> DbChangelog l -> Point l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l EmptyMK -> Point l
forall (mk :: * -> * -> *). l mk -> Point l
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> Point l
getTip (l EmptyMK -> Point l)
-> (DbChangelog l -> l EmptyMK) -> DbChangelog l -> Point l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbChangelog l -> l EmptyMK
forall (l :: (* -> * -> *) -> *).
GetTip l =>
DbChangelog l -> l EmptyMK
current

-- | Have we seen at least @k@ blocks?
isSaturated :: GetTip l => SecurityParam -> DbChangelog l -> Bool
isSaturated :: forall (l :: (* -> * -> *) -> *).
GetTip l =>
SecurityParam -> DbChangelog l -> Bool
isSaturated (SecurityParam NonZero Word64
k) DbChangelog l
db =
  DbChangelog l -> Word64
forall (l :: (* -> * -> *) -> *).
GetTip l =>
DbChangelog l -> Word64
maxRollback DbChangelog l
db Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k

-- | Get a past ledger state
--
--  \( O(\log(\min(i,n-i)) \)
--
-- When no ledger state (or anchor) has the given 'Point', 'Nothing' is
-- returned.
getPastLedgerAt ::
  ( HasHeader blk
  , IsLedger l
  , HeaderHash l ~ HeaderHash blk
  , StandardHash l
  , HasLedgerTables l
  ) =>
  Point blk ->
  DbChangelog l ->
  Maybe (l EmptyMK)
getPastLedgerAt :: forall blk (l :: (* -> * -> *) -> *).
(HasHeader blk, IsLedger l, HeaderHash l ~ HeaderHash blk,
 StandardHash l, HasLedgerTables l) =>
Point blk -> DbChangelog l -> Maybe (l EmptyMK)
getPastLedgerAt Point blk
pt DbChangelog l
db = DbChangelog l -> l EmptyMK
forall (l :: (* -> * -> *) -> *).
GetTip l =>
DbChangelog l -> l EmptyMK
current (DbChangelog l -> l EmptyMK)
-> Maybe (DbChangelog l) -> Maybe (l EmptyMK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point blk -> DbChangelog l -> Maybe (DbChangelog l)
forall blk (l :: (* -> * -> *) -> *).
(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
db

-- | Roll back the volatile states up to the specified point.
rollbackToPoint ::
  ( StandardHash l
  , GetTip l
  , HasLedgerTables l
  ) =>
  Point l -> DbChangelog l -> Maybe (DbChangelog l)
rollbackToPoint :: forall (l :: (* -> * -> *) -> *).
(StandardHash l, GetTip l, HasLedgerTables l) =>
Point l -> DbChangelog l -> Maybe (DbChangelog l)
rollbackToPoint Point l
pt DbChangelog l
dblog = do
  vol' <-
    WithOrigin SlotNo
-> (Either (l EmptyMK) (l EmptyMK) -> Bool)
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
-> Maybe (AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
forall v a b.
Anchorable v a b =>
v
-> (Either a b -> Bool)
-> AnchoredSeq v a b
-> Maybe (AnchoredSeq v a b)
AS.rollback
      (Point l -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point l
pt)
      ((Point l -> Point l -> Bool
forall a. Eq a => a -> a -> Bool
== Point l
pt) (Point l -> Bool)
-> (Either (l EmptyMK) (l EmptyMK) -> Point l)
-> Either (l EmptyMK) (l EmptyMK)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l EmptyMK -> Point l
forall (mk :: * -> * -> *). l mk -> Point l
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> Point l
getTip (l EmptyMK -> Point l)
-> (Either (l EmptyMK) (l EmptyMK) -> l EmptyMK)
-> Either (l EmptyMK) (l EmptyMK)
-> Point l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (l EmptyMK -> l EmptyMK)
-> (l EmptyMK -> l EmptyMK)
-> Either (l EmptyMK) (l EmptyMK)
-> l EmptyMK
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either l EmptyMK -> l EmptyMK
forall a. a -> a
id l EmptyMK -> l EmptyMK
forall a. a -> a
id)
      AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates
  let ndropped = 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)
changelogStates Int -> Int -> Int
forall a. Num a => a -> a -> a
- 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)
vol'
      diffs' = (forall k v.
 LedgerTableConstraints' l k v =>
 SeqDiffMK k v -> SeqDiffMK k v)
-> LedgerTables l SeqDiffMK -> LedgerTables l SeqDiffMK
forall (l :: (* -> * -> *) -> *) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *).
LedgerTableConstraints l =>
(forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2
ltmap (Int -> SeqDiffMK k v -> SeqDiffMK k v
forall k v. (Ord k, Eq v) => Int -> SeqDiffMK k v -> SeqDiffMK k v
trunc Int
ndropped) LedgerTables l SeqDiffMK
changelogDiffs
  Exn.assert (ndropped >= 0) $
    pure
      DbChangelog
        { changelogLastFlushedState
        , changelogDiffs = diffs'
        , changelogStates = vol'
        }
 where
  DbChangelog
    { l EmptyMK
changelogLastFlushedState :: forall (l :: (* -> * -> *) -> *). DbChangelog l -> l EmptyMK
changelogLastFlushedState :: l EmptyMK
changelogLastFlushedState
    , LedgerTables l SeqDiffMK
changelogDiffs :: forall (l :: (* -> * -> *) -> *).
DbChangelog l -> LedgerTables l SeqDiffMK
changelogDiffs :: LedgerTables l SeqDiffMK
changelogDiffs
    , AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates :: forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates :: AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates
    } = DbChangelog l
dblog

-- | Rollback the volatile states up to the volatile anchor.
rollbackToAnchor ::
  (GetTip l, HasLedgerTables l) =>
  DbChangelog l -> DbChangelog l
rollbackToAnchor :: forall (l :: (* -> * -> *) -> *).
(GetTip l, HasLedgerTables l) =>
DbChangelog l -> DbChangelog l
rollbackToAnchor DbChangelog l
dblog =
  DbChangelog
    { l EmptyMK
changelogLastFlushedState :: l EmptyMK
changelogLastFlushedState :: l EmptyMK
changelogLastFlushedState
    , changelogDiffs :: LedgerTables l SeqDiffMK
changelogDiffs = LedgerTables l SeqDiffMK
diffs'
    , changelogStates :: AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates = l EmptyMK
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AS.Empty (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)
vol)
    }
 where
  DbChangelog
    { l EmptyMK
changelogLastFlushedState :: forall (l :: (* -> * -> *) -> *). DbChangelog l -> l EmptyMK
changelogLastFlushedState :: l EmptyMK
changelogLastFlushedState
    , LedgerTables l SeqDiffMK
changelogDiffs :: forall (l :: (* -> * -> *) -> *).
DbChangelog l -> LedgerTables l SeqDiffMK
changelogDiffs :: LedgerTables l SeqDiffMK
changelogDiffs
    , changelogStates :: forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates = AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
vol
    } = DbChangelog l
dblog

  ndropped :: Int
ndropped = 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)
vol
  diffs' :: LedgerTables l SeqDiffMK
diffs' = (forall k v.
 LedgerTableConstraints' l k v =>
 SeqDiffMK k v -> SeqDiffMK k v)
-> LedgerTables l SeqDiffMK -> LedgerTables l SeqDiffMK
forall (l :: (* -> * -> *) -> *) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *).
LedgerTableConstraints l =>
(forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2
ltmap (Int -> SeqDiffMK k v -> SeqDiffMK k v
forall k v. (Ord k, Eq v) => Int -> SeqDiffMK k v -> SeqDiffMK k v
trunc Int
ndropped) LedgerTables l SeqDiffMK
changelogDiffs

trunc ::
  (Ord k, Eq v) =>
  Int -> SeqDiffMK k v -> SeqDiffMK k v
trunc :: forall k v. (Ord k, Eq v) => Int -> SeqDiffMK k v -> SeqDiffMK k v
trunc Int
n (SeqDiffMK DiffSeq k v
sq) =
  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
$ (DiffSeq k v, DiffSeq k v) -> DiffSeq k v
forall a b. (a, b) -> a
fst ((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
$ Int -> DiffSeq k v -> (DiffSeq k v, DiffSeq k v)
forall k v.
(SM k v, HasCallStack) =>
Int -> DiffSeq k v -> (DiffSeq k v, DiffSeq k v)
DS.splitAtFromEnd Int
n DiffSeq k v
sq

-- | Get a prefix of the DbChangelog that ends at the given point
--
--  \( O(\log(\min(i,n-i)) \)
--
-- When no ledger state (or anchor) has the given 'Point', 'Nothing' is
-- returned.
rollback ::
  ( HasHeader blk
  , IsLedger l
  , HeaderHash l ~ HeaderHash blk
  , StandardHash l
  , HasLedgerTables l
  ) =>
  Point blk ->
  DbChangelog l ->
  Maybe (DbChangelog l)
rollback :: forall blk (l :: (* -> * -> *) -> *).
(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
db
  | Point blk
pt Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point l -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (l EmptyMK -> Point l
forall (mk :: * -> * -> *). l mk -> Point l
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> Point l
getTip (DbChangelog l -> l EmptyMK
forall (l :: (* -> * -> *) -> *). DbChangelog l -> l EmptyMK
anchor DbChangelog l
db)) =
      DbChangelog l -> Maybe (DbChangelog l)
forall a. a -> Maybe a
Just (DbChangelog l -> Maybe (DbChangelog l))
-> DbChangelog l -> Maybe (DbChangelog l)
forall a b. (a -> b) -> a -> b
$ DbChangelog l -> DbChangelog l
forall (l :: (* -> * -> *) -> *).
(GetTip l, HasLedgerTables l) =>
DbChangelog l -> DbChangelog l
rollbackToAnchor DbChangelog l
db
  | Bool
otherwise =
      Point l -> DbChangelog l -> Maybe (DbChangelog l)
forall (l :: (* -> * -> *) -> *).
(StandardHash l, GetTip l, HasLedgerTables l) =>
Point l -> DbChangelog l -> Maybe (DbChangelog l)
rollbackToPoint (Point blk -> Point l
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
pt) DbChangelog l
db

immutableTipSlot ::
  GetTip l =>
  DbChangelog l -> WithOrigin SlotNo
immutableTipSlot :: forall (l :: (* -> * -> *) -> *).
GetTip l =>
DbChangelog l -> WithOrigin SlotNo
immutableTipSlot =
  l EmptyMK -> WithOrigin SlotNo
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot
    (l EmptyMK -> WithOrigin SlotNo)
-> (DbChangelog l -> l EmptyMK)
-> DbChangelog l
-> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
 -> l EmptyMK)
-> (DbChangelog l
    -> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> DbChangelog l
-> l EmptyMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates

-- | How many diffs we can flush to the backing store?
--
-- NOTE: This will be wrong once we have more than one table.
flushableLength ::
  (HasLedgerTables l, GetTip l) =>
  DbChangelog l ->
  Word64
flushableLength :: forall (l :: (* -> * -> *) -> *).
(HasLedgerTables l, GetTip l) =>
DbChangelog l -> Word64
flushableLength DbChangelog l
chlog =
  (\Word64
x -> Word64
x Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK) -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AS.length (DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates DbChangelog l
chlog)))
    (Word64 -> Word64)
-> (LedgerTables l SeqDiffMK -> Word64)
-> LedgerTables l SeqDiffMK
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerTables l (K2 Word64) -> Word64
forall (l :: (* -> * -> *) -> *) a. LedgerTables l (K2 a) -> a
ltcollapse
    (LedgerTables l (K2 Word64) -> Word64)
-> (LedgerTables l SeqDiffMK -> LedgerTables l (K2 Word64))
-> LedgerTables l SeqDiffMK
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k v.
 LedgerTableConstraints' l k v =>
 SeqDiffMK k v -> K2 Word64 k v)
-> LedgerTables l SeqDiffMK -> LedgerTables l (K2 Word64)
forall (l :: (* -> * -> *) -> *) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *).
LedgerTableConstraints l =>
(forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2
ltmap (Word64 -> K2 Word64 k v
forall k1 k2 a (b :: k1) (c :: k2). a -> K2 a b c
K2 (Word64 -> K2 Word64 k v)
-> (SeqDiffMK k v -> Word64) -> SeqDiffMK k v -> K2 Word64 k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SeqDiffMK k v -> Word64
forall k v. (Ord k, Eq v) => SeqDiffMK k v -> Word64
f)
    (LedgerTables l SeqDiffMK -> Word64)
-> LedgerTables l SeqDiffMK -> Word64
forall a b. (a -> b) -> a -> b
$ DbChangelog l -> LedgerTables l SeqDiffMK
forall (l :: (* -> * -> *) -> *).
DbChangelog l -> LedgerTables l SeqDiffMK
changelogDiffs DbChangelog l
chlog
 where
  f ::
    (Ord k, Eq v) =>
    SeqDiffMK k v ->
    Word64
  f :: forall k v. (Ord k, Eq v) => SeqDiffMK k v -> Word64
f (SeqDiffMK DiffSeq k v
sq) = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ DiffSeq k v -> Int
forall k v. SM k v => DiffSeq k v -> Int
DS.length DiffSeq k v
sq

-- | Transform the underlying volatile 'AnchoredSeq' using the given functions.
volatileStatesBimap ::
  AS.Anchorable (WithOrigin SlotNo) a b =>
  (l EmptyMK -> a) ->
  (l EmptyMK -> b) ->
  DbChangelog l ->
  AS.AnchoredSeq (WithOrigin SlotNo) a b
volatileStatesBimap :: forall a b (l :: (* -> * -> *) -> *).
Anchorable (WithOrigin SlotNo) a b =>
(l EmptyMK -> a)
-> (l EmptyMK -> b)
-> DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) a b
volatileStatesBimap l EmptyMK -> a
f l EmptyMK -> b
g =
  (l EmptyMK -> a)
-> (l EmptyMK -> b)
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
-> AnchoredSeq (WithOrigin SlotNo) a b
forall v2 a2 b2 a1 b1 v1.
Anchorable v2 a2 b2 =>
(a1 -> a2)
-> (b1 -> b2) -> AnchoredSeq v1 a1 b1 -> AnchoredSeq v2 a2 b2
AS.bimap l EmptyMK -> a
f l EmptyMK -> b
g
    (AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
 -> AnchoredSeq (WithOrigin SlotNo) a b)
-> (DbChangelog l
    -> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK))
-> DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
forall (l :: (* -> * -> *) -> *).
DbChangelog l
-> AnchoredSeq (WithOrigin SlotNo) (l EmptyMK) (l EmptyMK)
changelogStates

{-------------------------------------------------------------------------------
  Testing
-------------------------------------------------------------------------------}

reapplyThenPush' ::
  ApplyBlock l blk =>
  LedgerDbCfg l ->
  blk ->
  KeySetsReader Identity l ->
  DbChangelog l ->
  DbChangelog l
reapplyThenPush' :: forall (l :: (* -> * -> *) -> *) blk.
ApplyBlock l blk =>
LedgerDbCfg l
-> blk
-> KeySetsReader Identity l
-> DbChangelog l
-> DbChangelog l
reapplyThenPush' LedgerDbCfg l
cfg blk
b KeySetsReader Identity l
bk = Identity (DbChangelog l) -> DbChangelog l
forall a. Identity a -> a
runIdentity (Identity (DbChangelog l) -> DbChangelog l)
-> (DbChangelog l -> Identity (DbChangelog l))
-> DbChangelog l
-> DbChangelog l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDbCfg l
-> blk
-> KeySetsReader Identity l
-> DbChangelog l
-> Identity (DbChangelog l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(Monad m, ApplyBlock l blk) =>
LedgerDbCfg l
-> blk -> KeySetsReader m l -> DbChangelog l -> m (DbChangelog l)
reapplyThenPush LedgerDbCfg l
cfg blk
b KeySetsReader Identity l
bk

reapplyThenPushMany' ::
  (ApplyBlock l blk, LedgerTablesAreTrivial l) =>
  LedgerDbCfg l ->
  [blk] ->
  DbChangelog l ->
  DbChangelog l
reapplyThenPushMany' :: forall (l :: (* -> * -> *) -> *) blk.
(ApplyBlock l blk, LedgerTablesAreTrivial l) =>
LedgerDbCfg l -> [blk] -> DbChangelog l -> DbChangelog l
reapplyThenPushMany' LedgerDbCfg l
cfg [blk]
bs DbChangelog l
dblog =
  Identity (DbChangelog l) -> DbChangelog l
forall a. Identity a -> a
runIdentity
    (Identity (DbChangelog l) -> DbChangelog l)
-> (DbChangelog l -> Identity (DbChangelog l))
-> DbChangelog l
-> DbChangelog l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDbCfg l
-> [blk]
-> KeySetsReader Identity l
-> DbChangelog l
-> Identity (DbChangelog l)
forall (l :: (* -> * -> *) -> *) blk (m :: * -> *).
(ApplyBlock l blk, Monad m) =>
LedgerDbCfg l
-> [blk] -> KeySetsReader m l -> DbChangelog l -> m (DbChangelog l)
reapplyThenPushMany LedgerDbCfg l
cfg [blk]
bs (WithOrigin SlotNo -> KeySetsReader Identity l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
(Monad m, LedgerTablesAreTrivial l) =>
WithOrigin SlotNo -> KeySetsReader m l
trivialKeySetsReader (l EmptyMK -> WithOrigin SlotNo
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot (DbChangelog l -> l EmptyMK
forall (l :: (* -> * -> *) -> *). DbChangelog l -> l EmptyMK
changelogLastFlushedState DbChangelog l
dblog)))
    (DbChangelog l -> DbChangelog l) -> DbChangelog l -> DbChangelog l
forall a b. (a -> b) -> a -> b
$ DbChangelog l
dblog

reapplyThenPushMany ::
  (ApplyBlock l blk, Monad m) =>
  LedgerDbCfg l ->
  [blk] ->
  KeySetsReader m l ->
  DbChangelog l ->
  m (DbChangelog l)
reapplyThenPushMany :: forall (l :: (* -> * -> *) -> *) blk (m :: * -> *).
(ApplyBlock l blk, Monad m) =>
LedgerDbCfg l
-> [blk] -> KeySetsReader m l -> DbChangelog l -> m (DbChangelog l)
reapplyThenPushMany LedgerDbCfg l
cfg [blk]
aps KeySetsReader m l
ksReader =
  (blk -> DbChangelog l -> m (DbChangelog l))
-> [blk] -> DbChangelog l -> m (DbChangelog l)
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m b) -> [a] -> b -> m b
repeatedlyM (\blk
ap -> LedgerDbCfg l
-> blk -> KeySetsReader m l -> DbChangelog l -> m (DbChangelog l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(Monad m, ApplyBlock l blk) =>
LedgerDbCfg l
-> blk -> KeySetsReader m l -> DbChangelog l -> m (DbChangelog l)
reapplyThenPush LedgerDbCfg l
cfg blk
ap KeySetsReader m l
ksReader) [blk]
aps

switch ::
  (ApplyBlock l blk, Monad m) =>
  LedgerDbCfg l ->
  Word64 ->
  [blk] ->
  KeySetsReader m l ->
  DbChangelog l ->
  m (Either ExceededRollback (DbChangelog l))
switch :: forall (l :: (* -> * -> *) -> *) blk (m :: * -> *).
(ApplyBlock l blk, Monad m) =>
LedgerDbCfg l
-> Word64
-> [blk]
-> KeySetsReader m l
-> DbChangelog l
-> m (Either ExceededRollback (DbChangelog l))
switch LedgerDbCfg l
cfg Word64
numRollbacks [blk]
newBlocks KeySetsReader m l
ksReader DbChangelog l
db =
  case Word64 -> DbChangelog l -> Maybe (DbChangelog l)
forall (l :: (* -> * -> *) -> *).
(GetTip l, HasLedgerTables l) =>
Word64 -> DbChangelog l -> Maybe (DbChangelog l)
rollbackN Word64
numRollbacks DbChangelog l
db of
    Maybe (DbChangelog l)
Nothing ->
      Either ExceededRollback (DbChangelog l)
-> m (Either ExceededRollback (DbChangelog l))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ExceededRollback (DbChangelog l)
 -> m (Either ExceededRollback (DbChangelog l)))
-> Either ExceededRollback (DbChangelog l)
-> m (Either ExceededRollback (DbChangelog l))
forall a b. (a -> b) -> a -> b
$
        ExceededRollback -> Either ExceededRollback (DbChangelog l)
forall a b. a -> Either a b
Left (ExceededRollback -> Either ExceededRollback (DbChangelog l))
-> ExceededRollback -> Either ExceededRollback (DbChangelog l)
forall a b. (a -> b) -> a -> b
$
          ExceededRollback
            { rollbackMaximum :: Word64
rollbackMaximum = DbChangelog l -> Word64
forall (l :: (* -> * -> *) -> *).
GetTip l =>
DbChangelog l -> Word64
maxRollback DbChangelog l
db
            , rollbackRequested :: Word64
rollbackRequested = Word64
numRollbacks
            }
    Just DbChangelog l
db' ->
      if [blk] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [blk]
newBlocks
        then Either ExceededRollback (DbChangelog l)
-> m (Either ExceededRollback (DbChangelog l))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ExceededRollback (DbChangelog l)
 -> m (Either ExceededRollback (DbChangelog l)))
-> Either ExceededRollback (DbChangelog l)
-> m (Either ExceededRollback (DbChangelog l))
forall a b. (a -> b) -> a -> b
$ DbChangelog l -> Either ExceededRollback (DbChangelog l)
forall a b. b -> Either a b
Right DbChangelog l
db'
        -- no blocks to apply to ledger state, return current DbChangelog
        else
          DbChangelog l -> Either ExceededRollback (DbChangelog l)
forall a b. b -> Either a b
Right
            (DbChangelog l -> Either ExceededRollback (DbChangelog l))
-> m (DbChangelog l) -> m (Either ExceededRollback (DbChangelog l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerDbCfg l
-> [blk] -> KeySetsReader m l -> DbChangelog l -> m (DbChangelog l)
forall (l :: (* -> * -> *) -> *) blk (m :: * -> *).
(ApplyBlock l blk, Monad m) =>
LedgerDbCfg l
-> [blk] -> KeySetsReader m l -> DbChangelog l -> m (DbChangelog l)
reapplyThenPushMany
              LedgerDbCfg l
cfg
              [blk]
newBlocks
              KeySetsReader m l
ksReader
              DbChangelog l
db'

switch' ::
  (ApplyBlock l blk, LedgerTablesAreTrivial l) =>
  LedgerDbCfg l ->
  Word64 ->
  [blk] ->
  DbChangelog l ->
  Maybe (DbChangelog l)
switch' :: forall (l :: (* -> * -> *) -> *) blk.
(ApplyBlock l blk, LedgerTablesAreTrivial l) =>
LedgerDbCfg l
-> Word64 -> [blk] -> DbChangelog l -> Maybe (DbChangelog l)
switch' LedgerDbCfg l
cfg Word64
n [blk]
bs DbChangelog l
db =
  case Identity (Either ExceededRollback (DbChangelog l))
-> Either ExceededRollback (DbChangelog l)
forall a. Identity a -> a
runIdentity (Identity (Either ExceededRollback (DbChangelog l))
 -> Either ExceededRollback (DbChangelog l))
-> Identity (Either ExceededRollback (DbChangelog l))
-> Either ExceededRollback (DbChangelog l)
forall a b. (a -> b) -> a -> b
$ LedgerDbCfg l
-> Word64
-> [blk]
-> KeySetsReader Identity l
-> DbChangelog l
-> Identity (Either ExceededRollback (DbChangelog l))
forall (l :: (* -> * -> *) -> *) blk (m :: * -> *).
(ApplyBlock l blk, Monad m) =>
LedgerDbCfg l
-> Word64
-> [blk]
-> KeySetsReader m l
-> DbChangelog l
-> m (Either ExceededRollback (DbChangelog l))
switch LedgerDbCfg l
cfg Word64
n [blk]
bs (WithOrigin SlotNo -> KeySetsReader Identity l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
(Monad m, LedgerTablesAreTrivial l) =>
WithOrigin SlotNo -> KeySetsReader m l
trivialKeySetsReader (l EmptyMK -> WithOrigin SlotNo
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot (DbChangelog l -> l EmptyMK
forall (l :: (* -> * -> *) -> *). DbChangelog l -> l EmptyMK
changelogLastFlushedState DbChangelog l
db))) DbChangelog l
db of
    Left ExceededRollback{} -> Maybe (DbChangelog l)
forall a. Maybe a
Nothing
    Right DbChangelog l
db' -> DbChangelog l -> Maybe (DbChangelog l)
forall a. a -> Maybe a
Just DbChangelog l
db'