{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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 Control.ResourceRegistry
import qualified Data.Bifunctor as B
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)

closeLedgerSeq :: Monad m => LedgerSeq m l -> m ()
closeLedgerSeq :: forall (m :: * -> *) (l :: LedgerStateKind).
Monad m =>
LedgerSeq m l -> m ()
closeLedgerSeq = (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 ())
-> (LedgerSeq m l -> [StateRef m l]) -> LedgerSeq m l -> m ()
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]
toOldestFirst (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

{-------------------------------------------------------------------------------
  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 closed as it contains the pruned
-- states.
reapplyThenPush ::
  (IOLike m, ApplyBlock l blk) =>
  ResourceRegistry m ->
  LedgerDbCfg l ->
  blk ->
  LedgerSeq m l ->
  m (LedgerSeq m l, LedgerSeq m l)
reapplyThenPush :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, ApplyBlock l blk) =>
ResourceRegistry m
-> LedgerDbCfg l
-> blk
-> LedgerSeq m l
-> m (LedgerSeq m l, LedgerSeq m l)
reapplyThenPush ResourceRegistry m
rr LedgerDbCfg l
cfg blk
ap LedgerSeq m l
db =
  (\StateRef m l
current' -> LedgerDbPrune -> LedgerSeq m l -> (LedgerSeq m l, LedgerSeq m l)
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerDbPrune -> LedgerSeq m l -> (LedgerSeq m l, 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 -> (LedgerSeq m l, LedgerSeq m l))
-> LedgerSeq m l -> (LedgerSeq m l, 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 -> (LedgerSeq m l, LedgerSeq m l))
-> m (StateRef m l) -> m (LedgerSeq m l, 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 has to be @close@ed.
--
-- >>> 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 ::
  GetTip l =>
  LedgerDbPrune ->
  LedgerSeq m l ->
  (LedgerSeq m l, LedgerSeq m l)
prune :: forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerDbPrune -> LedgerSeq m l -> (LedgerSeq m l, LedgerSeq m l)
prune (LedgerDbPruneKeeping (SecurityParam NonZero Word64
k)) (LedgerSeq AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
ldb) =
  if Int -> Word64
forall a. Enum a => Int -> a
toEnum Int
nvol Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k
    then (AnchoredSeq (WithOrigin SlotNo) (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)
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
forall a b. (a -> b) -> a -> b
$ 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
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)
ldb), 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)
    else
      -- We remove the new anchor from the @fst@ component so that its handle is
      -- not closed.
      (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),
    AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> (LedgerSeq m l, LedgerSeq m l)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: MapKind) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
B.bimap (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)
-> (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)
-> LedgerSeq m l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
dropNewest Int
1) 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),
  AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
 -> (LedgerSeq m l, LedgerSeq m l))
-> (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l),
    AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> (LedgerSeq m l, LedgerSeq m l)
forall a b. (a -> b) -> a -> b
$ 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
- Word64 -> Int
forall a. Enum a => a -> Int
fromEnum (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k)) AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
ldb
 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
prune LedgerDbPrune
LedgerDbPruneAll (LedgerSeq AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
ldb) =
  (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),
    AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> (LedgerSeq m l, LedgerSeq m l)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: MapKind) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
B.bimap (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)
-> (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)
-> LedgerSeq m l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
dropNewest Int
1) 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),
  AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
 -> (LedgerSeq m l, LedgerSeq m l))
-> (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l),
    AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
-> (LedgerSeq m l, LedgerSeq m l)
forall a b. (a -> b) -> a -> b
$ 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 AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
ldb
 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

-- 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 ::
  GetTip l =>
  LedgerSeq m l ->
  (LedgerSeq m l, LedgerSeq m l)
pruneToImmTipOnly :: forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> (LedgerSeq m l, LedgerSeq m l)
pruneToImmTipOnly = LedgerDbPrune -> LedgerSeq m l -> (LedgerSeq m l, LedgerSeq m l)
forall (l :: LedgerStateKind) (m :: * -> *).
GetTip l =>
LedgerDbPrune -> LedgerSeq m l -> (LedgerSeq m l, 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
-- :}