{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | The data structure that holds the cached ledger states.
module Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
  ( -- * LedgerHandles
    LedgerTablesHandle (..)

    -- * The ledger seq
  , LedgerSeq (..)
  , LedgerSeq'
  , StateRef (..)
  , closeLedgerSeq
  , empty
  , empty'

    -- * Apply Blocks
  , extend
  , prune
  , pruneToImmTipOnly
  , reapplyBlock
  , reapplyThenPush

    -- * Queries
  , anchor
  , anchorHandle
  , current
  , currentHandle
  , getPastLedgerAt
  , immutableTipSlot
  , isSaturated
  , maxRollback
  , rollback
  , rollbackN
  , rollbackToAnchor
  , rollbackToPoint
  , snapshots
  , tip
  , volatileStatesBimap
  ) where

import Cardano.Ledger.BaseTypes
import Data.Function (on)
import Data.Word
import GHC.Generics
import NoThunks.Class
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config.SecurityParam
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.Util.IOLike
import Ouroboros.Network.AnchoredSeq hiding
  ( anchor
  , last
  , map
  , rollback
  )
import qualified Ouroboros.Network.AnchoredSeq as AS hiding (map)
import System.FS.CRC (CRC)
import Prelude hiding (read)

{-------------------------------------------------------------------------------
  LedgerTablesHandles
-------------------------------------------------------------------------------}

-- | The interface fulfilled by handles on both the InMemory and LSM handles.
--
-- The most relevant concept is handle duplication:
--
-- A duplicated handle must provide access to all the data that was there in
-- the original handle while being able to mutate in ways different than the
-- original handle.
--
-- When applying diffs to a table, we will first duplicate the handle, then
-- apply the diffs in the copy. It is expected that duplicating the handle
-- takes constant time.
data LedgerTablesHandle m l = LedgerTablesHandle
  { forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l -> m ()
close :: !(m ())
  -- ^ Close the handle
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l
-> l EmptyMK -> l DiffMK -> m (LedgerTablesHandle m l)
duplicateWithDiffs :: !(l EmptyMK -> l DiffMK -> m (LedgerTablesHandle m l))
  -- ^ Create a new handle by duplicating this one and push some diffs to it.
  --
  -- The first argument has to be the ledger state before applying
  -- the block, the second argument should be the ledger state after
  -- applying a block. See 'CanUpgradeLedgerTables'.
  --
  -- Note 'CanUpgradeLedgerTables' is only used in the InMemory backend.
  --
  -- This is expected to be used when applying new blocks onto a forker, which
  -- happens only in chain selection (see 'forkerPush') and initial chain
  -- selection (see 'reapplyBlock').
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l -> m (LedgerTablesHandle m l)
duplicate :: !(m (LedgerTablesHandle m l))
  -- ^ Create an duplicate of a handle. This will be used when opening read-only
  -- forkers and also to open the first handle for a forker used in chain
  -- selection.
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l
-> l EmptyMK
-> LedgerTables l KeysMK
-> m (LedgerTables l ValuesMK)
read :: !(l EmptyMK -> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK))
  -- ^ Read values for the given keys from the tables, and deserialize them as
  -- if they were from the same era as the given ledger state.
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l
-> l EmptyMK
-> (Maybe (TxIn l), Int)
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
readRange :: !(l EmptyMK -> (Maybe (TxIn l), Int) -> m (LedgerTables l ValuesMK, Maybe (TxIn l)))
  -- ^ Read the requested number of values, possibly starting from the given
  -- key, from the tables, and deserialize them as if they were from the same
  -- era as the given ledger state.
  --
  -- The returned value contains both the read values as well as the last key
  -- retrieved. This is necessary in case the backend uses a serialization
  -- format such that the order in the store (which will be used when reading)
  -- might not match the order in a Haskell @Map@ (induced by @Ord@), so the
  -- backend must tell which key it read last (if any).
  --
  -- The last key retrieved is part of the map too. It is intended to be fed
  -- back into the next iteration of the range read. If the function returns
  -- Nothing, it means the read returned no results, or in other words, we
  -- reached the end of the ledger tables.
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l -> l EmptyMK -> m (LedgerTables l ValuesMK)
readAll :: !(l EmptyMK -> m (LedgerTables l ValuesMK))
  -- ^ Costly read all operation, not to be used in Consensus but only in
  -- snapshot-converter executable. The values will be read as if they were from
  -- the same era as the given ledger state.
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l -> l EmptyMK -> String -> m (Maybe CRC)
takeHandleSnapshot :: !(l EmptyMK -> String -> m (Maybe CRC))
  -- ^ Take a snapshot of a handle. The given ledger state is used to decide the
  -- encoding of the values based on the current era.
  --
  -- It returns a CRC only on backends that support it, as the InMemory backend.
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l -> Int
tablesSize :: !Int
  -- ^ Consult the size of the ledger tables in the database.
  }
  deriving Context -> LedgerTablesHandle m l -> IO (Maybe ThunkInfo)
Proxy (LedgerTablesHandle m l) -> String
(Context -> LedgerTablesHandle m l -> IO (Maybe ThunkInfo))
-> (Context -> LedgerTablesHandle m l -> IO (Maybe ThunkInfo))
-> (Proxy (LedgerTablesHandle m l) -> String)
-> NoThunks (LedgerTablesHandle m l)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
Context -> LedgerTablesHandle m l -> IO (Maybe ThunkInfo)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
Proxy (LedgerTablesHandle m l) -> String
$cnoThunks :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
Context -> LedgerTablesHandle m l -> IO (Maybe ThunkInfo)
noThunks :: Context -> LedgerTablesHandle m l -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
Context -> LedgerTablesHandle m l -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> LedgerTablesHandle m l -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
Proxy (LedgerTablesHandle m l) -> String
showTypeOf :: Proxy (LedgerTablesHandle m l) -> String
NoThunks via OnlyCheckWhnfNamed "LedgerTablesHandle" (LedgerTablesHandle m l)

{-------------------------------------------------------------------------------
  StateRef, represents a full ledger state, i.e. with a handle for its tables
-------------------------------------------------------------------------------}

-- | For single era blocks, it would be the same to hold a stowed ledger state
-- (@'LedgerTables' ('LedgerState' blk) 'EmptyMK'@), an unstowed one
-- (@'LedgerTables' ('LedgerState' blk) 'ValuesMK'@) or a tuple with the state
-- and the tables ('LedgerState' blk 'EmptyMK', 'LedgerTables' ('LedgerState'
-- blk) 'ValuesMK'), however, for a hard fork block, these are not equivalent.
--
-- If we were to hold a sequence of type @LedgerState blk EmptyMK@ with stowed
-- values, we would have to translate the entirety of the tables on epoch
-- boundaries.
--
-- If we were to hold a sequence of type @LedgerState blk ValuesMK@ we would
-- have the same problem as the @mk@ in the state actually refers to the @mk@ in
-- the @HardForkState@'ed state.
--
-- Therefore it sounds reasonable to hold a @LedgerState blk EmptyMK@ with no
-- values, and a @LedgerTables blk ValuesMK@ next to it, that will live its
-- entire lifetime as @LedgerTables@ of the @HardForkBlock@.
data StateRef m l = StateRef
  { forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state :: !(l EmptyMK)
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> LedgerTablesHandle m l
tables :: !(LedgerTablesHandle m l)
  }
  deriving (forall x. StateRef m l -> Rep (StateRef m l) x)
-> (forall x. Rep (StateRef m l) x -> StateRef m l)
-> Generic (StateRef m l)
forall x. Rep (StateRef m l) x -> StateRef m l
forall x. StateRef m l -> Rep (StateRef m l) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) (l :: (* -> * -> *) -> *) x.
Rep (StateRef m l) x -> StateRef m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *) x.
StateRef m l -> Rep (StateRef m l) x
$cfrom :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) x.
StateRef m l -> Rep (StateRef m l) x
from :: forall x. StateRef m l -> Rep (StateRef m l) x
$cto :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) x.
Rep (StateRef m l) x -> StateRef m l
to :: forall x. Rep (StateRef m l) x -> StateRef m l
Generic

deriving instance (IOLike m, NoThunks (l EmptyMK)) => NoThunks (StateRef m l)

instance Eq (l EmptyMK) => Eq (StateRef m l) where
  == :: StateRef m l -> StateRef m l -> Bool
(==) = l EmptyMK -> l EmptyMK -> Bool
forall a. Eq a => a -> a -> Bool
(==) (l EmptyMK -> l EmptyMK -> Bool)
-> (StateRef m l -> l EmptyMK)
-> StateRef m l
-> StateRef m l
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state

instance Show (l EmptyMK) => Show (StateRef m l) where
  show :: StateRef m l -> String
show = l EmptyMK -> String
forall a. Show a => a -> String
show (l EmptyMK -> String)
-> (StateRef m l -> l EmptyMK) -> StateRef m l -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state

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

{-------------------------------------------------------------------------------
  The LedgerSeq
-------------------------------------------------------------------------------}

newtype LedgerSeq m l = LedgerSeq
  { forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
getLedgerSeq :: AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
  }
  deriving (forall x. LedgerSeq m l -> Rep (LedgerSeq m l) x)
-> (forall x. Rep (LedgerSeq m l) x -> LedgerSeq m l)
-> Generic (LedgerSeq m l)
forall x. Rep (LedgerSeq m l) x -> LedgerSeq m l
forall x. LedgerSeq m l -> Rep (LedgerSeq m l) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) (l :: (* -> * -> *) -> *) x.
Rep (LedgerSeq m l) x -> LedgerSeq m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *) x.
LedgerSeq m l -> Rep (LedgerSeq m l) x
$cfrom :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) x.
LedgerSeq m l -> Rep (LedgerSeq m l) x
from :: forall x. LedgerSeq m l -> Rep (LedgerSeq m l) x
$cto :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) x.
Rep (LedgerSeq m l) x -> LedgerSeq m l
to :: forall x. Rep (LedgerSeq m l) x -> LedgerSeq m l
Generic

deriving newtype instance (IOLike m, NoThunks (l EmptyMK)) => NoThunks (LedgerSeq m l)

deriving newtype instance Eq (l EmptyMK) => Eq (LedgerSeq m l)
deriving newtype instance Show (l EmptyMK) => Show (LedgerSeq m l)

type LedgerSeq' m blk = LedgerSeq m (ExtLedgerState blk)

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

-- | Creates an empty @LedgerSeq@
empty ::
  ( GetTip l
  , IOLike m
  ) =>
  l EmptyMK ->
  init ->
  (init -> m (LedgerTablesHandle m l)) ->
  m (LedgerSeq m l)
empty :: forall (l :: (* -> * -> *) -> *) (m :: * -> *) init.
(GetTip l, IOLike m) =>
l EmptyMK
-> init
-> (init -> m (LedgerTablesHandle m l))
-> m (LedgerSeq m l)
empty l EmptyMK
st init
tbs init -> m (LedgerTablesHandle m l)
new = AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
LedgerSeq (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
 -> LedgerSeq m l)
-> (LedgerTablesHandle m l
    -> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> LedgerTablesHandle m l
-> LedgerSeq m l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AS.Empty (StateRef m l
 -> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> (LedgerTablesHandle m l -> StateRef m l)
-> LedgerTablesHandle m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l EmptyMK -> LedgerTablesHandle m l -> StateRef m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
l EmptyMK -> LedgerTablesHandle m l -> StateRef m l
StateRef l EmptyMK
st (LedgerTablesHandle m l -> LedgerSeq m l)
-> m (LedgerTablesHandle m l) -> m (LedgerSeq m l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> init -> m (LedgerTablesHandle m l)
new init
tbs

-- | Creates an empty @LedgerSeq@
empty' ::
  ( GetTip l
  , IOLike m
  , HasLedgerTables l
  ) =>
  l ValuesMK ->
  (l ValuesMK -> m (LedgerTablesHandle m l)) ->
  m (LedgerSeq m l)
empty' :: forall (l :: (* -> * -> *) -> *) (m :: * -> *).
(GetTip l, IOLike m, HasLedgerTables l) =>
l ValuesMK
-> (l ValuesMK -> m (LedgerTablesHandle m l)) -> m (LedgerSeq m l)
empty' l ValuesMK
st = l EmptyMK
-> l ValuesMK
-> (l ValuesMK -> m (LedgerTablesHandle m l))
-> m (LedgerSeq m l)
forall (l :: (* -> * -> *) -> *) (m :: * -> *) init.
(GetTip l, IOLike m) =>
l EmptyMK
-> init
-> (init -> m (LedgerTablesHandle m l))
-> m (LedgerSeq m l)
empty (l ValuesMK -> l EmptyMK
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables l ValuesMK
st) l ValuesMK
st

-- | Close all 'LedgerTablesHandle' in this 'LedgerSeq', in particular that on
-- the anchor.
closeLedgerSeq :: Monad m => LedgerSeq m l -> m ()
closeLedgerSeq :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
Monad m =>
LedgerSeq m l -> m ()
closeLedgerSeq (LedgerSeq AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
l) =
  (StateRef m l -> m ()) -> [StateRef m l] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (LedgerTablesHandle m l -> m ()
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l -> m ()
close (LedgerTablesHandle m l -> m ())
-> (StateRef m l -> LedgerTablesHandle m l) -> StateRef m l -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef m l -> LedgerTablesHandle m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> LedgerTablesHandle m l
tables) ([StateRef m l] -> m ()) -> [StateRef m l] -> m ()
forall a b. (a -> b) -> a -> b
$ AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> StateRef m l
forall v a b. AnchoredSeq v a b -> a
AS.anchor AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
l StateRef m l -> [StateRef m l] -> [StateRef m l]
forall a. a -> [a] -> [a]
: AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> [StateRef m l]
forall v a b. AnchoredSeq v a b -> [b]
AS.toOldestFirst AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
l

{-------------------------------------------------------------------------------
  Apply blocks
-------------------------------------------------------------------------------}

-- | Apply a block on top of the ledger state and extend the LedgerSeq with
-- the result ledger state.
--
-- The @fst@ component of the result should be run to close the pruned states.
reapplyThenPush ::
  (IOLike m, ApplyBlock l blk) =>
  LedgerDbCfg l ->
  blk ->
  LedgerSeq m l ->
  m (LedgerSeq m l)
reapplyThenPush :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(IOLike m, ApplyBlock l blk) =>
LedgerDbCfg l -> blk -> LedgerSeq m l -> m (LedgerSeq m l)
reapplyThenPush LedgerDbCfg l
cfg blk
ap LedgerSeq m l
db = do
  newSt <- ComputeLedgerEvents
-> LedgerCfg l -> blk -> LedgerSeq m l -> m (StateRef m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(ApplyBlock l blk, IOLike m) =>
ComputeLedgerEvents
-> LedgerCfg l -> blk -> LedgerSeq m l -> m (StateRef m l)
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 LedgerSeq m l
db
  let (m, db') = pruneToImmTipOnly $ extend newSt db
  m
  pure db'

reapplyBlock ::
  forall m l blk.
  (ApplyBlock l blk, IOLike m) =>
  ComputeLedgerEvents ->
  LedgerCfg l ->
  blk ->
  LedgerSeq m l ->
  m (StateRef m l)
reapplyBlock :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(ApplyBlock l blk, IOLike m) =>
ComputeLedgerEvents
-> LedgerCfg l -> blk -> LedgerSeq m l -> m (StateRef m l)
reapplyBlock ComputeLedgerEvents
evs LedgerCfg l
cfg blk
b LedgerSeq m l
db = do
  let ks :: LedgerTables l KeysMK
ks = blk -> LedgerTables l KeysMK
forall (l :: (* -> * -> *) -> *) blk.
ApplyBlock l blk =>
blk -> LedgerTables l KeysMK
getBlockKeySets blk
b
      StateRef l EmptyMK
st LedgerTablesHandle m l
tbs = LedgerSeq m l -> StateRef m l
forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> StateRef m l
currentHandle LedgerSeq m l
db
  vals <- LedgerTablesHandle m l
-> l EmptyMK
-> LedgerTables l KeysMK
-> m (LedgerTables l ValuesMK)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l
-> l EmptyMK
-> LedgerTables l KeysMK
-> m (LedgerTables l ValuesMK)
read LedgerTablesHandle m l
tbs l EmptyMK
st LedgerTables l KeysMK
ks
  let st' = 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 (l EmptyMK
st 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` LedgerTables l ValuesMK
vals)
      newst = l DiffMK -> l EmptyMK
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables l DiffMK
st'

  newtbs <- duplicateWithDiffs tbs st st'
  pure (StateRef newst newtbs)

-- | Prune older ledger states according to the given 'LedgerDbPrune' strategy.
--
-- The @fst@ component of the returned value is an action closing the pruned
-- ledger states.
--
-- >>> ldb  = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
-- >>> ldb' = LedgerSeq $ AS.fromOldestFirst     l1 [l2, l3]
-- >>> snd (prune (LedgerDbPruneBeforeSlot 1) ldb) == ldb'
-- True
--
-- where @lX@ is a ledger state from slot @X-1@ (or 'Origin' for @l0@).
prune ::
  (Monad m, GetTip l) =>
  LedgerDbPrune ->
  LedgerSeq m l ->
  (m (), LedgerSeq m l)
prune :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
(Monad m, GetTip l) =>
LedgerDbPrune -> LedgerSeq m l -> (m (), LedgerSeq m l)
prune LedgerDbPrune
howToPrune (LedgerSeq AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
ldb) = case LedgerDbPrune
howToPrune of
  LedgerDbPrune
LedgerDbPruneAll ->
    (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> m ()
closeButHead AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
before, AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
LedgerSeq AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
after)
   where
    (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
before, AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
after) = (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
ldb, StateRef m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AS.Empty (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> StateRef m l
forall v a b. Anchorable v a b => AnchoredSeq v a b -> a
AS.headAnchor AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
ldb))
  LedgerDbPruneBeforeSlot SlotNo
slot ->
    (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> m ()
closeButHead AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
before, AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
LedgerSeq AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
after)
   where
    -- The anchor of @vol'@ might still have a tip slot older than @slot@, which
    -- is fine to ignore (we will prune it later).
    (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
before, AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
after) = WithOrigin SlotNo
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l),
    AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
forall v a b.
Anchorable v a b =>
v -> AnchoredSeq v a b -> (AnchoredSeq v a b, AnchoredSeq v a b)
AS.splitAtMeasure (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
slot) AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
ldb
 where
  -- Above, we split @ldb@ into two sequences @before@ and @after@ such that
  -- @AS.headAnchor before == AS.anchor after@. We want to close all handles of
  -- @ldb@ not present in @after@, which are none if @before@ is empty, and all
  -- (in particular the anchor) of @before@ apart from the the head of @before@
  -- if @before@ is non-empty.
  closeButHead :: AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> m ()
closeButHead = \case
    AS.Empty StateRef m l
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
toPrune AS.:> StateRef m l
_ -> LedgerSeq m l -> m ()
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
Monad m =>
LedgerSeq m l -> m ()
closeLedgerSeq (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
LedgerSeq AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
toPrune)

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

-- | Extending the LedgerDB with a valid ledger state.
--
-- >>> ldb            = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
-- >>> LedgerSeq ldb' = extend l4 ldb
-- >>> AS.toOldestFirst ldb' == [l1, l2, l3, l4]
-- True
extend ::
  GetTip l =>
  StateRef m l ->
  LedgerSeq m l ->
  LedgerSeq m l
extend :: forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
StateRef m l -> LedgerSeq m l -> LedgerSeq m l
extend StateRef m l
newState =
  AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
LedgerSeq (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
 -> LedgerSeq m l)
-> (LedgerSeq m l
    -> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> LedgerSeq m l
-> LedgerSeq m l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> StateRef m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
:> StateRef m l
newState) (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
 -> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> (LedgerSeq m l
    -> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
getLedgerSeq

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

-- | Set the volatile tip as the immutable tip and prune all older states.
--
-- >>> ldb  = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
-- >>> LedgerSeq ldb' = snd $ pruneToImmTipOnly ldb
-- >>> AS.anchor ldb' == l3 && AS.toOldestFirst ldb' == []
-- True
pruneToImmTipOnly ::
  (Monad m, GetTip l) =>
  LedgerSeq m l ->
  (m (), LedgerSeq m l)
pruneToImmTipOnly :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
(Monad m, GetTip l) =>
LedgerSeq m l -> (m (), LedgerSeq m l)
pruneToImmTipOnly = LedgerDbPrune -> LedgerSeq m l -> (m (), LedgerSeq m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
(Monad m, GetTip l) =>
LedgerDbPrune -> LedgerSeq m l -> (m (), LedgerSeq m 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.
--
-- >>> ldb = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
-- >>> fmap (([l1] ==) . AS.toOldestFirst . getLedgerSeq) (rollbackN 2 ldb)
-- Just True
rollbackN ::
  GetTip l =>
  Word64 ->
  LedgerSeq m l ->
  Maybe (LedgerSeq m l)
rollbackN :: forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
Word64 -> LedgerSeq m l -> Maybe (LedgerSeq m l)
rollbackN Word64
n LedgerSeq m l
ldb
  | Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= LedgerSeq m l -> Word64
forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> Word64
maxRollback LedgerSeq m l
ldb =
      LedgerSeq m l -> Maybe (LedgerSeq m l)
forall a. a -> Maybe a
Just (LedgerSeq m l -> Maybe (LedgerSeq m l))
-> LedgerSeq m l -> Maybe (LedgerSeq m l)
forall a b. (a -> b) -> a -> b
$ AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
LedgerSeq (Int
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AS.dropNewest (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
 -> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall a b. (a -> b) -> a -> b
$ LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
getLedgerSeq LedgerSeq m l
ldb)
  | Bool
otherwise =
      Maybe (LedgerSeq m l)
forall a. Maybe a
Nothing

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

-- | The ledger state at the tip of the chain
--
-- >>> ldb = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
-- >>> l3s == current ldb
-- True
current :: GetTip l => LedgerSeq m l -> l EmptyMK
current :: forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> l EmptyMK
current = StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state (StateRef m l -> l EmptyMK)
-> (LedgerSeq m l -> StateRef m l) -> LedgerSeq m l -> l EmptyMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m l -> StateRef m l
forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> StateRef m l
currentHandle

currentHandle :: GetTip l => LedgerSeq m l -> StateRef m l
currentHandle :: forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> StateRef m l
currentHandle = AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> StateRef m l
forall v a b. Anchorable v a b => AnchoredSeq v a b -> a
headAnchor (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
 -> StateRef m l)
-> (LedgerSeq m l
    -> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> LedgerSeq m l
-> StateRef m l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
getLedgerSeq

-- | The ledger state at the anchor of the Volatile chain (i.e. the immutable
-- tip).
--
-- >>> ldb = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
-- >>> l0s == anchor ldb
-- True
anchor :: LedgerSeq m l -> l EmptyMK
anchor :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerSeq m l -> l EmptyMK
anchor = StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state (StateRef m l -> l EmptyMK)
-> (LedgerSeq m l -> StateRef m l) -> LedgerSeq m l -> l EmptyMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m l -> StateRef m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerSeq m l -> StateRef m l
anchorHandle

anchorHandle :: LedgerSeq m l -> StateRef m l
anchorHandle :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerSeq m l -> StateRef m l
anchorHandle = AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> StateRef m l
forall v a b. AnchoredSeq v a b -> a
AS.anchor (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
 -> StateRef m l)
-> (LedgerSeq m l
    -> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> LedgerSeq m l
-> StateRef m l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
getLedgerSeq

-- | 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.
--
-- >>> ldb = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
-- >>> [(0, l3s), (1, l2s), (2, l1s)] == snapshots ldb
-- True
snapshots :: LedgerSeq m l -> [(Word64, l EmptyMK)]
snapshots :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerSeq m 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)])
-> (LedgerSeq m l -> [l EmptyMK])
-> LedgerSeq m l
-> [(Word64, l EmptyMK)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateRef m l -> l EmptyMK) -> [StateRef m l] -> [l EmptyMK]
forall a b. (a -> b) -> [a] -> [b]
map StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state
    ([StateRef m l] -> [l EmptyMK])
-> (LedgerSeq m l -> [StateRef m l])
-> LedgerSeq m l
-> [l EmptyMK]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> [StateRef m l]
forall v a b. AnchoredSeq v a b -> [b]
AS.toNewestFirst
    (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
 -> [StateRef m l])
-> (LedgerSeq m l
    -> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> LedgerSeq m l
-> [StateRef m l]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
getLedgerSeq

-- | How many blocks can we currently roll back?
--
-- >>> ldb = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
-- >>> maxRollback ldb
-- 3
maxRollback :: GetTip l => LedgerSeq m l -> Word64
maxRollback :: forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> Word64
maxRollback =
  Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    (Int -> Word64)
-> (LedgerSeq m l -> Int) -> LedgerSeq m l -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AS.length
    (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
 -> Int)
-> (LedgerSeq m l
    -> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> LedgerSeq m l
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
getLedgerSeq

-- | Reference to the block at the tip of the chain
--
-- >>> ldb = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
-- >>> tip ldb == getTip l3s
-- True
tip :: GetTip l => LedgerSeq m l -> Point l
tip :: forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m 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)
-> (LedgerSeq m l -> Point l) -> LedgerSeq m 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)
-> (LedgerSeq m l -> l EmptyMK) -> LedgerSeq m l -> Point l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m l -> l EmptyMK
forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> l EmptyMK
current

-- | Have we seen at least @k@ blocks?
--
-- >>> ldb = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
-- >>> isSaturated (SecurityParam (unsafeNonZero 3)) ldb
-- True
-- >>> isSaturated (SecurityParam (unsafeNonZero 4)) ldb
-- False
isSaturated :: GetTip l => SecurityParam -> LedgerSeq m l -> Bool
isSaturated :: forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
SecurityParam -> LedgerSeq m l -> Bool
isSaturated (SecurityParam NonZero Word64
k) LedgerSeq m l
db =
  LedgerSeq m l -> Word64
forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> Word64
maxRollback LedgerSeq m 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.
--
-- >>> ldb = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
-- >>> getPastLedgerAt (Point (At (Block 4 4)) :: Point B) ldb == Nothing
-- True
-- >>> getPastLedgerAt (Point (At (Block 1 1)) :: Point B) ldb == Just l2s
-- True
getPastLedgerAt ::
  ( HasHeader blk
  , GetTip l
  , HeaderHash l ~ HeaderHash blk
  , StandardHash l
  ) =>
  Point blk ->
  LedgerSeq m l ->
  Maybe (l EmptyMK)
getPastLedgerAt :: forall blk (l :: (* -> * -> *) -> *) (m :: * -> *).
(HasHeader blk, GetTip l, HeaderHash l ~ HeaderHash blk,
 StandardHash l) =>
Point blk -> LedgerSeq m l -> Maybe (l EmptyMK)
getPastLedgerAt Point blk
pt LedgerSeq m l
db = LedgerSeq m l -> l EmptyMK
forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> l EmptyMK
current (LedgerSeq m l -> l EmptyMK)
-> Maybe (LedgerSeq m l) -> Maybe (l EmptyMK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point blk -> LedgerSeq m l -> Maybe (LedgerSeq m l)
forall blk (l :: (* -> * -> *) -> *) (m :: * -> *).
(HasHeader blk, GetTip l, HeaderHash l ~ HeaderHash blk,
 StandardHash l) =>
Point blk -> LedgerSeq m l -> Maybe (LedgerSeq m l)
rollback Point blk
pt LedgerSeq m l
db

-- | Roll back the volatile states up to the specified point.
--
-- >>> ldb = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
-- >>> Just (LedgerSeq ldb') = rollbackToPoint (Point Origin) ldb
-- >>> AS.anchor ldb' == l0 && AS.toOldestFirst ldb' == []
-- True
-- >>> rollbackToPoint (Point (At (Block 1 2))) ldb == Nothing
-- True
-- >>> Just (LedgerSeq ldb') = rollbackToPoint (Point (At (Block 1 1))) ldb
-- >>> AS.anchor ldb' == l0 && AS.toOldestFirst ldb' == [l1, l2]
-- True
rollbackToPoint ::
  ( StandardHash l
  , GetTip l
  ) =>
  Point l -> LedgerSeq m l -> Maybe (LedgerSeq m l)
rollbackToPoint :: forall (l :: (* -> * -> *) -> *) (m :: * -> *).
(StandardHash l, GetTip l) =>
Point l -> LedgerSeq m l -> Maybe (LedgerSeq m l)
rollbackToPoint Point l
pt (LedgerSeq AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
ldb) = do
  AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
LedgerSeq
    (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
 -> LedgerSeq m l)
-> Maybe
     (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> Maybe (LedgerSeq m l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithOrigin SlotNo
-> (Either (StateRef m l) (StateRef m l) -> Bool)
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> Maybe
     (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
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 (StateRef m l) (StateRef m l) -> Point l)
-> Either (StateRef m l) (StateRef m l)
-> 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 (StateRef m l) (StateRef m l) -> l EmptyMK)
-> Either (StateRef m l) (StateRef m l)
-> Point l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateRef m l -> l EmptyMK)
-> (StateRef m l -> l EmptyMK)
-> Either (StateRef m l) (StateRef m l)
-> l EmptyMK
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state)
      AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
ldb

-- | Rollback the volatile states up to the volatile anchor.
--
-- >>> ldb = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
-- >>> LedgerSeq ldb' = rollbackToAnchor ldb
-- >>> AS.anchor ldb' == l0 && AS.toOldestFirst ldb' == []
-- True
rollbackToAnchor ::
  GetTip l =>
  LedgerSeq m l -> LedgerSeq m l
rollbackToAnchor :: forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> LedgerSeq m l
rollbackToAnchor (LedgerSeq AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
vol) =
  AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
LedgerSeq (StateRef m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AS.Empty (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> StateRef m l
forall v a b. AnchoredSeq v a b -> a
AS.anchor AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
vol))

-- | Get a prefix of the LedgerDB 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
  , GetTip l
  , HeaderHash l ~ HeaderHash blk
  , StandardHash l
  ) =>
  Point blk ->
  LedgerSeq m l ->
  Maybe (LedgerSeq m l)
rollback :: forall blk (l :: (* -> * -> *) -> *) (m :: * -> *).
(HasHeader blk, GetTip l, HeaderHash l ~ HeaderHash blk,
 StandardHash l) =>
Point blk -> LedgerSeq m l -> Maybe (LedgerSeq m l)
rollback Point blk
pt LedgerSeq m 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 (LedgerSeq m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerSeq m l -> l EmptyMK
anchor LedgerSeq m l
db)) =
      LedgerSeq m l -> Maybe (LedgerSeq m l)
forall a. a -> Maybe a
Just (LedgerSeq m l -> Maybe (LedgerSeq m l))
-> LedgerSeq m l -> Maybe (LedgerSeq m l)
forall a b. (a -> b) -> a -> b
$ LedgerSeq m l -> LedgerSeq m l
forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> LedgerSeq m l
rollbackToAnchor LedgerSeq m l
db
  | Bool
otherwise =
      Point l -> LedgerSeq m l -> Maybe (LedgerSeq m l)
forall (l :: (* -> * -> *) -> *) (m :: * -> *).
(StandardHash l, GetTip l) =>
Point l -> LedgerSeq m l -> Maybe (LedgerSeq m 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) LedgerSeq m l
db

immutableTipSlot ::
  GetTip l =>
  LedgerSeq m l -> WithOrigin SlotNo
immutableTipSlot :: forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> WithOrigin SlotNo
immutableTipSlot =
  l EmptyMK -> WithOrigin SlotNo
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot
    (l EmptyMK -> WithOrigin SlotNo)
-> (LedgerSeq m l -> l EmptyMK)
-> LedgerSeq m l
-> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state
    (StateRef m l -> l EmptyMK)
-> (LedgerSeq m l -> StateRef m l) -> LedgerSeq m l -> l EmptyMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> StateRef m l
forall v a b. AnchoredSeq v a b -> a
AS.anchor
    (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
 -> StateRef m l)
-> (LedgerSeq m l
    -> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> LedgerSeq m l
-> StateRef m l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
getLedgerSeq

-- | Transform the underlying volatile 'AnchoredSeq' using the given functions.
volatileStatesBimap ::
  AS.Anchorable (WithOrigin SlotNo) a b =>
  (l EmptyMK -> a) ->
  (l EmptyMK -> b) ->
  LedgerSeq m l ->
  AS.AnchoredSeq (WithOrigin SlotNo) a b
volatileStatesBimap :: forall a b (l :: (* -> * -> *) -> *) (m :: * -> *).
Anchorable (WithOrigin SlotNo) a b =>
(l EmptyMK -> a)
-> (l EmptyMK -> b)
-> LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) a b
volatileStatesBimap l EmptyMK -> a
f l EmptyMK -> b
g =
  (StateRef m l -> a)
-> (StateRef m l -> b)
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> 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 -> a)
-> (StateRef m l -> l EmptyMK) -> StateRef m l -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state) (l EmptyMK -> b
g (l EmptyMK -> b)
-> (StateRef m l -> l EmptyMK) -> StateRef m l -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state)
    (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
 -> AnchoredSeq (WithOrigin SlotNo) a b)
-> (LedgerSeq m l
    -> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
getLedgerSeq

{-------------------------------------------------------------------------------
  docspec setup
-------------------------------------------------------------------------------}

-- $setup
-- >>> :set -XTypeFamilies -XUndecidableInstances -XFlexibleInstances -XTypeApplications -XMultiParamTypeClasses
-- >>> import qualified Ouroboros.Network.AnchoredSeq as AS
-- >>> import Ouroboros.Network.Block
-- >>> import Ouroboros.Network.Point
-- >>> import Ouroboros.Consensus.Ledger.Tables
-- >>> import Ouroboros.Consensus.Ledger.Tables.Utils
-- >>> import Ouroboros.Consensus.Ledger.Basics
-- >>> import Ouroboros.Consensus.Config
-- >>> import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
-- >>> import Ouroboros.Consensus.Util.IndexedMemPack
-- >>> import Ouroboros.Consensus.Storage.LedgerDB.API
-- >>> import Cardano.Ledger.BaseTypes.NonZero
-- >>> import Data.Void
-- >>> import Cardano.Slotting.Slot
-- >>> data B
-- >>> data LS (mk :: MapKind) = LS (Point LS)
-- >>> type instance HeaderHash LS = Int
-- >>> type instance HeaderHash B = HeaderHash LS
-- >>> instance StandardHash LS
-- >>> type instance TxIn LS = Void
-- >>> type instance TxOut LS = Void
-- >>> instance LedgerTablesAreTrivial LS where convertMapKind (LS p) = LS p
-- >>> s = [LS (Point Origin), LS (Point (At (Block 0 0))), LS (Point (At (Block 1 1))), LS (Point (At (Block 2 2))), LS (Point (At (Block 3 3)))]
-- >>> [l0s, l1s, l2s, l3s, l4s] = s
-- >>> emptyHandle = LedgerTablesHandle (pure ()) (\_ _ -> pure emptyHandle) (pure emptyHandle) (\_ _ -> pure trivialLedgerTables) (\_ _ -> pure (trivialLedgerTables, Nothing)) (\_ -> pure trivialLedgerTables) (\_ _ -> undefined) 0 :: LedgerTablesHandle IO LS
-- >>> [l0, l1, l2, l3, l4] = map (flip StateRef emptyHandle) s
-- >>> instance GetTip LS where getTip (LS p) = p
-- >>> instance Eq (LS EmptyMK) where LS p1 == LS p2 = p1 == p2
-- >>> instance StandardHash B
-- >>> instance HasHeader B where getHeaderFields = undefined
-- >>> :{
--  instance HasLedgerTables LS where
--    projectLedgerTables _ = trivialLedgerTables
--    withLedgerTables st _ = convertMapKind st
--  instance IndexedMemPack (LS EmptyMK) Void where
--    indexedTypeName _ = typeName @Void
--    indexedPackedByteCount _ = packedByteCount
--    indexedPackM _ = packM
--    indexedUnpackM _ = unpackM
-- :}