{-# 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 #-}
{-# LANGUAGE ViewPatterns #-}

-- | 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 Control.ResourceRegistry
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
-------------------------------------------------------------------------------}

data LedgerTablesHandle m l = LedgerTablesHandle
  { forall (m :: * -> *) (l :: LedgerStateKind).
LedgerTablesHandle m l -> m ()
close :: !(m ())
  , forall (m :: * -> *) (l :: LedgerStateKind).
LedgerTablesHandle m l -> m (LedgerTablesHandle m l)
duplicate :: !(m (LedgerTablesHandle m l))
  -- ^ It is expected that this operation takes constant time.
  , forall (m :: * -> *) (l :: LedgerStateKind).
LedgerTablesHandle m l
-> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
read :: !(LedgerTables l KeysMK -> m (LedgerTables l ValuesMK))
  , forall (m :: * -> *) (l :: LedgerStateKind).
LedgerTablesHandle m l
-> (Maybe (TxIn l), Int) -> m (LedgerTables l ValuesMK)
readRange :: !((Maybe (TxIn l), Int) -> m (LedgerTables l ValuesMK))
  , forall (m :: * -> *) (l :: LedgerStateKind).
LedgerTablesHandle m l -> m (LedgerTables l ValuesMK)
readAll :: !(m (LedgerTables l ValuesMK))
  -- ^ Costly read all operation, not to be used in Consensus but only in
  -- snapshot-converter executable.
  , forall (m :: * -> *) (l :: LedgerStateKind).
LedgerTablesHandle m l
-> forall (mk :: MapKind). l mk -> l DiffMK -> m ()
pushDiffs :: !(forall mk. l mk -> l DiffMK -> m ())
  -- ^ Push some diffs into the ledger tables handle.
  --
  -- 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'.
  , forall (m :: * -> *) (l :: LedgerStateKind).
LedgerTablesHandle m l -> l EmptyMK -> String -> m CRC
takeHandleSnapshot :: !(l EmptyMK -> String -> m CRC)
  , forall (m :: * -> *) (l :: LedgerStateKind).
LedgerTablesHandle m l -> m (Maybe Int)
tablesSize :: !(m (Maybe Int))
  -- ^ Consult the size of the ledger tables in the database. This will return
  -- 'Nothing' in backends that do not support this operation.
  }
  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 :: LedgerStateKind).
Context -> LedgerTablesHandle m l -> IO (Maybe ThunkInfo)
forall (m :: * -> *) (l :: LedgerStateKind).
Proxy (LedgerTablesHandle m l) -> String
$cnoThunks :: forall (m :: * -> *) (l :: LedgerStateKind).
Context -> LedgerTablesHandle m l -> IO (Maybe ThunkInfo)
noThunks :: Context -> LedgerTablesHandle m l -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) (l :: LedgerStateKind).
Context -> LedgerTablesHandle m l -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> LedgerTablesHandle m l -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *) (l :: LedgerStateKind).
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 :: LedgerStateKind).
StateRef m l -> l EmptyMK
state :: !(l EmptyMK)
  , forall (m :: * -> *) (l :: LedgerStateKind).
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 :: LedgerStateKind) x.
Rep (StateRef m l) x -> StateRef m l
forall (m :: * -> *) (l :: LedgerStateKind) x.
StateRef m l -> Rep (StateRef m l) x
$cfrom :: forall (m :: * -> *) (l :: LedgerStateKind) x.
StateRef m l -> Rep (StateRef m l) x
from :: forall x. StateRef m l -> Rep (StateRef m l) x
$cto :: forall (m :: * -> *) (l :: LedgerStateKind) 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 :: LedgerStateKind).
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 :: LedgerStateKind).
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 :: LedgerStateKind) (mk :: MapKind).
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 :: LedgerStateKind).
StateRef m l -> l EmptyMK
state

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

newtype LedgerSeq m l = LedgerSeq
  { forall (m :: * -> *) (l :: LedgerStateKind).
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 :: LedgerStateKind) x.
Rep (LedgerSeq m l) x -> LedgerSeq m l
forall (m :: * -> *) (l :: LedgerStateKind) x.
LedgerSeq m l -> Rep (LedgerSeq m l) x
$cfrom :: forall (m :: * -> *) (l :: LedgerStateKind) x.
LedgerSeq m l -> Rep (LedgerSeq m l) x
from :: forall x. LedgerSeq m l -> Rep (LedgerSeq m l) x
$cto :: forall (m :: * -> *) (l :: LedgerStateKind) 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 ->
  LedgerTables l ValuesMK ->
  (LedgerTables l ValuesMK -> m (LedgerTablesHandle m l)) ->
  m (LedgerSeq m l)
empty :: forall (l :: LedgerStateKind) (m :: * -> *).
(GetTip l, IOLike m) =>
l EmptyMK
-> LedgerTables l ValuesMK
-> (LedgerTables l ValuesMK -> m (LedgerTablesHandle m l))
-> m (LedgerSeq m l)
empty l EmptyMK
st LedgerTables l ValuesMK
tbs LedgerTables l ValuesMK -> m (LedgerTablesHandle m l)
new = AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
forall (m :: * -> *) (l :: LedgerStateKind).
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 :: LedgerStateKind).
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
<$> LedgerTables l ValuesMK -> m (LedgerTablesHandle m l)
new LedgerTables l ValuesMK
tbs

-- | Creates an empty @LedgerSeq@
empty' ::
  ( GetTip l
  , IOLike m
  , HasLedgerTables l
  ) =>
  l ValuesMK ->
  (LedgerTables l ValuesMK -> m (LedgerTablesHandle m l)) ->
  m (LedgerSeq m l)
empty' :: forall (l :: LedgerStateKind) (m :: * -> *).
(GetTip l, IOLike m, HasLedgerTables l) =>
l ValuesMK
-> (LedgerTables l ValuesMK -> m (LedgerTablesHandle m l))
-> m (LedgerSeq m l)
empty' l ValuesMK
st = l EmptyMK
-> LedgerTables l ValuesMK
-> (LedgerTables l ValuesMK -> m (LedgerTablesHandle m l))
-> m (LedgerSeq m l)
forall (l :: LedgerStateKind) (m :: * -> *).
(GetTip l, IOLike m) =>
l EmptyMK
-> LedgerTables l ValuesMK
-> (LedgerTables l ValuesMK -> m (LedgerTablesHandle m l))
-> m (LedgerSeq m l)
empty (l ValuesMK -> l EmptyMK
forall (l :: LedgerStateKind) (mk :: MapKind).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables l ValuesMK
st) (l ValuesMK -> LedgerTables l ValuesMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: MapKind).
(HasLedgerTables l, SameUtxoTypes l l', CanMapMK mk,
 CanMapKeysMK mk, ZeroableMK mk) =>
l mk -> LedgerTables l' mk
ltprj 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 :: LedgerStateKind).
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 :: LedgerStateKind).
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 :: LedgerStateKind).
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) =>
  ResourceRegistry m ->
  LedgerDbCfg l ->
  blk ->
  LedgerSeq m l ->
  m (m (), LedgerSeq m l)
reapplyThenPush :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, ApplyBlock l blk) =>
ResourceRegistry m
-> LedgerDbCfg l -> blk -> LedgerSeq m l -> m (m (), LedgerSeq m l)
reapplyThenPush ResourceRegistry m
rr LedgerDbCfg l
cfg blk
ap LedgerSeq m l
db =
  (\StateRef m l
current' -> LedgerDbPrune -> LedgerSeq m l -> (m (), LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind).
(Monad m, GetTip l) =>
LedgerDbPrune -> LedgerSeq m l -> (m (), LedgerSeq m l)
prune (SecurityParam -> LedgerDbPrune
LedgerDbPruneKeeping (LedgerDbCfg l -> HKD Identity SecurityParam
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f SecurityParam
ledgerDbCfgSecParam LedgerDbCfg l
cfg)) (LedgerSeq m l -> (m (), LedgerSeq m l))
-> LedgerSeq m l -> (m (), LedgerSeq m l)
forall a b. (a -> b) -> a -> b
$ StateRef m l -> LedgerSeq m l -> LedgerSeq m l
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
StateRef m l -> LedgerSeq m l -> LedgerSeq m l
extend StateRef m l
current' LedgerSeq m l
db)
    (StateRef m l -> (m (), LedgerSeq m l))
-> m (StateRef m l) -> m (m (), LedgerSeq m l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> ResourceRegistry m
-> LedgerSeq m l
-> m (StateRef m l)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(ApplyBlock l blk, IOLike m) =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> ResourceRegistry m
-> LedgerSeq m l
-> m (StateRef m l)
reapplyBlock (LedgerDbCfg l -> ComputeLedgerEvents
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> ComputeLedgerEvents
ledgerDbCfgComputeLedgerEvents LedgerDbCfg l
cfg) (LedgerDbCfg l -> HKD Identity (LedgerCfg l)
forall (f :: * -> *) (l :: LedgerStateKind).
LedgerDbCfgF f l -> HKD f (LedgerCfg l)
ledgerDbCfg LedgerDbCfg l
cfg) blk
ap ResourceRegistry m
rr LedgerSeq m l
db

reapplyBlock ::
  forall m l blk.
  (ApplyBlock l blk, IOLike m) =>
  ComputeLedgerEvents ->
  LedgerCfg l ->
  blk ->
  ResourceRegistry m ->
  LedgerSeq m l ->
  m (StateRef m l)
reapplyBlock :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(ApplyBlock l blk, IOLike m) =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> ResourceRegistry m
-> LedgerSeq m l
-> m (StateRef m l)
reapplyBlock ComputeLedgerEvents
evs LedgerCfg l
cfg blk
b ResourceRegistry m
_rr LedgerSeq m l
db = do
  let ks :: LedgerTables l KeysMK
ks = blk -> LedgerTables l KeysMK
forall (l :: LedgerStateKind) 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 :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> StateRef m l
currentHandle LedgerSeq m l
db
  newtbs <- LedgerTablesHandle m l -> m (LedgerTablesHandle m l)
forall (m :: * -> *) (l :: LedgerStateKind).
LedgerTablesHandle m l -> m (LedgerTablesHandle m l)
duplicate LedgerTablesHandle m l
tbs
  vals <- read newtbs ks
  let st' = ComputeLedgerEvents -> LedgerCfg l -> blk -> l ValuesMK -> l DiffMK
forall (l :: LedgerStateKind) 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 :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
forall (l :: LedgerStateKind) (mk :: MapKind) (any :: MapKind).
(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 :: LedgerStateKind) (mk :: MapKind).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables l DiffMK
st'

  pushDiffs newtbs st st'
  pure (StateRef newst newtbs)

-- | Prune older ledger states until at we have at most @k@ volatile states in
-- the LedgerDB, plus the one stored at the anchor.
--
-- 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 (LedgerDbPruneKeeping (SecurityParam (unsafeNonZero 2))) ldb) == ldb'
-- True
prune ::
  (Monad m, GetTip l) =>
  LedgerDbPrune ->
  LedgerSeq m l ->
  (m (), LedgerSeq m l)
prune :: forall (m :: * -> *) (l :: LedgerStateKind).
(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
  LedgerDbPruneKeeping (SecurityParam (Word64 -> Int
forall a. Enum a => a -> Int
fromEnum (Word64 -> Int)
-> (NonZero Word64 -> Word64) -> NonZero Word64 -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero -> Int
k))
    | Int
nvol Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k -> (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
forall (m :: * -> *) (l :: LedgerStateKind).
AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
LedgerSeq AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
ldb)
    | Bool
otherwise -> (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 :: LedgerStateKind).
AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
LedgerSeq AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
after)
   where
    nvol :: Int
nvol = 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)
ldb
    (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
before, AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
after) = Int
-> 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 =>
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
- Int
k) AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
ldb
  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 :: LedgerStateKind).
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))
 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 :: LedgerStateKind).
Monad m =>
LedgerSeq m l -> m ()
closeLedgerSeq (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
forall (m :: * -> *) (l :: LedgerStateKind).
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 :: LedgerStateKind) (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 :: LedgerStateKind).
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 :: LedgerStateKind).
LedgerSeq m l
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
getLedgerSeq

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

-- | When creating a new @LedgerDB@, we should load whichever snapshot we find
-- and then replay the chain up to the immutable tip. When we get there, the
-- @LedgerDB@ 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 @LedgerDB@ would accept rollbacks into the
-- immutable part of the chain, which must never be possible.
--
-- >>> 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 :: LedgerStateKind).
(Monad m, GetTip l) =>
LedgerSeq m l -> (m (), LedgerSeq m l)
pruneToImmTipOnly = LedgerDbPrune -> LedgerSeq m l -> (m (), LedgerSeq m l)
forall (m :: * -> *) (l :: LedgerStateKind).
(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 :: LedgerStateKind) (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 :: LedgerStateKind) (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 :: LedgerStateKind).
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 :: LedgerStateKind).
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 :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> l EmptyMK
current = StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: LedgerStateKind).
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 :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> StateRef m l
currentHandle

currentHandle :: GetTip l => LedgerSeq m l -> StateRef m l
currentHandle :: forall (l :: LedgerStateKind) (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 :: LedgerStateKind).
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 :: LedgerStateKind).
LedgerSeq m l -> l EmptyMK
anchor = StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: LedgerStateKind).
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 :: LedgerStateKind).
LedgerSeq m l -> StateRef m l
anchorHandle

anchorHandle :: LedgerSeq m l -> StateRef m l
anchorHandle :: forall (m :: * -> *) (l :: LedgerStateKind).
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 :: LedgerStateKind).
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 :: LedgerStateKind).
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 :: LedgerStateKind).
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 :: LedgerStateKind).
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 :: LedgerStateKind) (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 :: LedgerStateKind).
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 :: LedgerStateKind) (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 :: MapKind). l mk -> Point l
forall (l :: LedgerStateKind) (mk :: MapKind).
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 :: LedgerStateKind) (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 :: LedgerStateKind) (m :: * -> *).
GetTip l =>
SecurityParam -> LedgerSeq m l -> Bool
isSaturated (SecurityParam NonZero Word64
k) LedgerSeq m l
db =
  LedgerSeq m l -> Word64
forall (l :: LedgerStateKind) (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 :: LedgerStateKind) (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 :: LedgerStateKind) (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 :: LedgerStateKind) (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 :: LedgerStateKind) (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 :: LedgerStateKind).
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 :: MapKind). l mk -> Point l
forall (l :: LedgerStateKind) (mk :: MapKind).
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 :: LedgerStateKind).
StateRef m l -> l EmptyMK
state StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: LedgerStateKind).
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 :: LedgerStateKind) (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 :: LedgerStateKind).
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 :: LedgerStateKind) (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 :: MapKind). l mk -> Point l
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip (LedgerSeq m l -> l EmptyMK
forall (m :: * -> *) (l :: LedgerStateKind).
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 :: LedgerStateKind) (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 :: LedgerStateKind) (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 :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> WithOrigin SlotNo
immutableTipSlot =
  l EmptyMK -> WithOrigin SlotNo
forall (l :: LedgerStateKind) (mk :: MapKind).
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 :: LedgerStateKind).
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 :: LedgerStateKind).
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 :: LedgerStateKind) (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 :: LedgerStateKind).
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 :: LedgerStateKind).
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 :: LedgerStateKind).
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) (\_ -> undefined) (\_ -> undefined) (pure trivialLedgerTables) (\_ _ _ -> undefined) (\_ -> undefined) (pure Nothing)
-- >>> [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
-- :}