{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE DeriveAnyClass         #-}
{-# LANGUAGE DeriveGeneric          #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE NamedFieldPuns         #-}
{-# LANGUAGE QuantifiedConstraints  #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE StandaloneDeriving     #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE UndecidableInstances   #-}

module Ouroboros.Consensus.Storage.LedgerDB.InMemory (
    -- * LedgerDB proper
    LedgerDbCfg (..)
  , ledgerDbWithAnchor
    -- ** opaque
  , LedgerDB
    -- ** Serialisation
  , decodeSnapshotBackwardsCompatible
  , encodeSnapshot
    -- ** Queries
  , ledgerDbAnchor
  , ledgerDbBimap
  , ledgerDbCurrent
  , ledgerDbPast
  , ledgerDbPrune
  , ledgerDbSnapshots
  , ledgerDbTip
    -- ** Running updates
  , AnnLedgerError (..)
  , Ap (..)
  , ResolveBlock
  , ResolvesBlocks (..)
  , ThrowsLedgerError (..)
  , defaultResolveBlocks
  , defaultResolveWithErrors
  , defaultThrowLedgerErrors
    -- ** Updates
  , ExceededRollback (..)
  , ledgerDbPush
  , ledgerDbSwitch
    -- * Exports for the benefit of tests
    -- ** Additional queries
  , ledgerDbIsSaturated
  , ledgerDbMaxRollback
    -- ** Pure API
  , ledgerDbPush'
  , ledgerDbPushMany'
  , ledgerDbSwitch'
  ) where

import           Codec.Serialise.Decoding (Decoder)
import qualified Codec.Serialise.Decoding as Dec
import           Codec.Serialise.Encoding (Encoding)
import           Control.Monad.Except hiding (ap)
import           Control.Monad.Reader hiding (ap)
import           Data.Foldable (find)
import           Data.Functor ((<&>))
import           Data.Functor.Identity
import           Data.Kind (Constraint, Type)
import           Data.Word
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)

import           Ouroboros.Network.AnchoredSeq (Anchorable (..),
                     AnchoredSeq (..))
import qualified Ouroboros.Network.AnchoredSeq as AS

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Storage.LedgerDB.Types (PushGoal (..),
                     PushStart (..), Pushing (..),
                     UpdateLedgerDbTraceEvent (..))
import           Ouroboros.Consensus.Ticked
import           Ouroboros.Consensus.Util
import           Ouroboros.Consensus.Util.CBOR (decodeWithOrigin)
import           Ouroboros.Consensus.Util.Versioned

{-------------------------------------------------------------------------------
  Ledger DB types
-------------------------------------------------------------------------------}

-- | Internal state of the ledger DB
--
-- The ledger DB looks like
--
-- > anchor |> snapshots <| current
--
-- where @anchor@ records the oldest known snapshot and @current@ the most
-- recent. The anchor is the oldest point we can roll back to.
--
-- We take a snapshot after each block is applied and keep in memory a window
-- of the last @k@ snapshots. We have verified empirically (#1936) that the
-- overhead of keeping @k snapshots in memory is small, i.e., about 5%
-- compared to keeping a snapshot every 100 blocks. This is thanks to sharing
-- between consecutive snapshots.
--
-- As an example, suppose we have @k = 6@. The ledger DB grows as illustrated
-- below, where we indicate the anchor number of blocks, the stored snapshots,
-- and the current ledger.
--
-- > anchor |> #   [ snapshots ]                   <| tip
-- > ---------------------------------------------------------------------------
-- > G      |> (0) [ ]                             <| G
-- > G      |> (1) [ L1]                           <| L1
-- > G      |> (2) [ L1,  L2]                      <| L2
-- > G      |> (3) [ L1,  L2,  L3]                 <| L3
-- > G      |> (4) [ L1,  L2,  L3,  L4]            <| L4
-- > G      |> (5) [ L1,  L2,  L3,  L4,  L5]       <| L5
-- > G      |> (6) [ L1,  L2,  L3,  L4,  L5,  L6]  <| L6
-- > L1     |> (6) [ L2,  L3,  L4,  L5,  L6,  L7]  <| L7
-- > L2     |> (6) [ L3,  L4,  L5,  L6,  L7,  L8]  <| L8
-- > L3     |> (6) [ L4,  L5,  L6,  L7,  L8,  L9]  <| L9   (*)
-- > L4     |> (6) [ L5,  L6,  L7,  L8,  L9,  L10] <| L10
-- > L5     |> (6) [*L6,  L7,  L8,  L9,  L10, L11] <| L11
-- > L6     |> (6) [ L7,  L8,  L9,  L10, L11, L12] <| L12
-- > L7     |> (6) [ L8,  L9,  L10, L12, L12, L13] <| L13
-- > L8     |> (6) [ L9,  L10, L12, L12, L13, L14] <| L14
--
-- The ledger DB must guarantee that at all times we are able to roll back @k@
-- blocks. For example, if we are on line (*), and roll back 6 blocks, we get
--
-- > L3 |> []
newtype LedgerDB l = LedgerDB {
      -- | Ledger states
      LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: AnchoredSeq
                               (WithOrigin SlotNo)
                               (Checkpoint l)
                               (Checkpoint l)
    }
  deriving (Int -> LedgerDB l -> ShowS
[LedgerDB l] -> ShowS
LedgerDB l -> String
(Int -> LedgerDB l -> ShowS)
-> (LedgerDB l -> String)
-> ([LedgerDB l] -> ShowS)
-> Show (LedgerDB l)
forall l. Show l => Int -> LedgerDB l -> ShowS
forall l. Show l => [LedgerDB l] -> ShowS
forall l. Show l => LedgerDB l -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LedgerDB l] -> ShowS
$cshowList :: forall l. Show l => [LedgerDB l] -> ShowS
show :: LedgerDB l -> String
$cshow :: forall l. Show l => LedgerDB l -> String
showsPrec :: Int -> LedgerDB l -> ShowS
$cshowsPrec :: forall l. Show l => Int -> LedgerDB l -> ShowS
Show, LedgerDB l -> LedgerDB l -> Bool
(LedgerDB l -> LedgerDB l -> Bool)
-> (LedgerDB l -> LedgerDB l -> Bool) -> Eq (LedgerDB l)
forall l. Eq l => LedgerDB l -> LedgerDB l -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LedgerDB l -> LedgerDB l -> Bool
$c/= :: forall l. Eq l => LedgerDB l -> LedgerDB l -> Bool
== :: LedgerDB l -> LedgerDB l -> Bool
$c== :: forall l. Eq l => LedgerDB l -> LedgerDB l -> Bool
Eq, (forall x. LedgerDB l -> Rep (LedgerDB l) x)
-> (forall x. Rep (LedgerDB l) x -> LedgerDB l)
-> Generic (LedgerDB l)
forall x. Rep (LedgerDB l) x -> LedgerDB l
forall x. LedgerDB l -> Rep (LedgerDB l) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (LedgerDB l) x -> LedgerDB l
forall l x. LedgerDB l -> Rep (LedgerDB l) x
$cto :: forall l x. Rep (LedgerDB l) x -> LedgerDB l
$cfrom :: forall l x. LedgerDB l -> Rep (LedgerDB l) x
Generic, Context -> LedgerDB l -> IO (Maybe ThunkInfo)
Proxy (LedgerDB l) -> String
(Context -> LedgerDB l -> IO (Maybe ThunkInfo))
-> (Context -> LedgerDB l -> IO (Maybe ThunkInfo))
-> (Proxy (LedgerDB l) -> String)
-> NoThunks (LedgerDB l)
forall l.
NoThunks l =>
Context -> LedgerDB l -> IO (Maybe ThunkInfo)
forall l. NoThunks l => Proxy (LedgerDB l) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (LedgerDB l) -> String
$cshowTypeOf :: forall l. NoThunks l => Proxy (LedgerDB l) -> String
wNoThunks :: Context -> LedgerDB l -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall l.
NoThunks l =>
Context -> LedgerDB l -> IO (Maybe ThunkInfo)
noThunks :: Context -> LedgerDB l -> IO (Maybe ThunkInfo)
$cnoThunks :: forall l.
NoThunks l =>
Context -> LedgerDB l -> IO (Maybe ThunkInfo)
NoThunks)

-- | Internal newtype wrapper around a ledger state @l@ so that we can define a
-- non-blanket 'Anchorable' instance.
newtype Checkpoint l = Checkpoint {
      Checkpoint l -> l
unCheckpoint :: l
    }
  deriving (Int -> Checkpoint l -> ShowS
[Checkpoint l] -> ShowS
Checkpoint l -> String
(Int -> Checkpoint l -> ShowS)
-> (Checkpoint l -> String)
-> ([Checkpoint l] -> ShowS)
-> Show (Checkpoint l)
forall l. Show l => Int -> Checkpoint l -> ShowS
forall l. Show l => [Checkpoint l] -> ShowS
forall l. Show l => Checkpoint l -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Checkpoint l] -> ShowS
$cshowList :: forall l. Show l => [Checkpoint l] -> ShowS
show :: Checkpoint l -> String
$cshow :: forall l. Show l => Checkpoint l -> String
showsPrec :: Int -> Checkpoint l -> ShowS
$cshowsPrec :: forall l. Show l => Int -> Checkpoint l -> ShowS
Show, Checkpoint l -> Checkpoint l -> Bool
(Checkpoint l -> Checkpoint l -> Bool)
-> (Checkpoint l -> Checkpoint l -> Bool) -> Eq (Checkpoint l)
forall l. Eq l => Checkpoint l -> Checkpoint l -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Checkpoint l -> Checkpoint l -> Bool
$c/= :: forall l. Eq l => Checkpoint l -> Checkpoint l -> Bool
== :: Checkpoint l -> Checkpoint l -> Bool
$c== :: forall l. Eq l => Checkpoint l -> Checkpoint l -> Bool
Eq, (forall x. Checkpoint l -> Rep (Checkpoint l) x)
-> (forall x. Rep (Checkpoint l) x -> Checkpoint l)
-> Generic (Checkpoint l)
forall x. Rep (Checkpoint l) x -> Checkpoint l
forall x. Checkpoint l -> Rep (Checkpoint l) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (Checkpoint l) x -> Checkpoint l
forall l x. Checkpoint l -> Rep (Checkpoint l) x
$cto :: forall l x. Rep (Checkpoint l) x -> Checkpoint l
$cfrom :: forall l x. Checkpoint l -> Rep (Checkpoint l) x
Generic, Context -> Checkpoint l -> IO (Maybe ThunkInfo)
Proxy (Checkpoint l) -> String
(Context -> Checkpoint l -> IO (Maybe ThunkInfo))
-> (Context -> Checkpoint l -> IO (Maybe ThunkInfo))
-> (Proxy (Checkpoint l) -> String)
-> NoThunks (Checkpoint l)
forall l.
NoThunks l =>
Context -> Checkpoint l -> IO (Maybe ThunkInfo)
forall l. NoThunks l => Proxy (Checkpoint l) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (Checkpoint l) -> String
$cshowTypeOf :: forall l. NoThunks l => Proxy (Checkpoint l) -> String
wNoThunks :: Context -> Checkpoint l -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall l.
NoThunks l =>
Context -> Checkpoint l -> IO (Maybe ThunkInfo)
noThunks :: Context -> Checkpoint l -> IO (Maybe ThunkInfo)
$cnoThunks :: forall l.
NoThunks l =>
Context -> Checkpoint l -> IO (Maybe ThunkInfo)
NoThunks)

instance GetTip l => Anchorable (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l) where
  asAnchor :: Checkpoint l -> Checkpoint l
asAnchor = Checkpoint l -> Checkpoint l
forall a. a -> a
id
  getAnchorMeasure :: Proxy (Checkpoint l) -> Checkpoint l -> WithOrigin SlotNo
getAnchorMeasure Proxy (Checkpoint l)
_ = l -> WithOrigin SlotNo
forall l. GetTip l => l -> WithOrigin SlotNo
getTipSlot (l -> WithOrigin SlotNo)
-> (Checkpoint l -> l) -> Checkpoint l -> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint

{-------------------------------------------------------------------------------
  Ticking
-------------------------------------------------------------------------------}

-- | Ticking the ledger DB just ticks the current state
--
-- We don't push the new state into the DB until we apply a block.
data instance Ticked (LedgerDB l) = TickedLedgerDB {
      Ticked (LedgerDB l) -> Ticked l
tickedLedgerDbTicked :: Ticked l
    , Ticked (LedgerDB l) -> LedgerDB l
tickedLedgerDbOrig   :: LedgerDB l
    }

{-------------------------------------------------------------------------------
  LedgerDB proper
-------------------------------------------------------------------------------}

-- | Ledger DB starting at the specified ledger state
ledgerDbWithAnchor :: GetTip l => l -> LedgerDB l
ledgerDbWithAnchor :: l -> LedgerDB l
ledgerDbWithAnchor l
anchor = LedgerDB :: forall l.
AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> LedgerDB l
LedgerDB {
      ledgerDbCheckpoints :: AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints = Checkpoint l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
Empty (l -> Checkpoint l
forall l. l -> Checkpoint l
Checkpoint l
anchor)
    }

{-------------------------------------------------------------------------------
  Compute signature

  Depending on the parameters (apply by value or by reference, previously
  applied or not) we get different signatures.
-------------------------------------------------------------------------------}

-- | Resolve a block
--
-- Resolving a block reference to the actual block lives in @m@ because
-- it might need to read the block from disk (and can therefore not be
-- done inside an STM transaction).
--
-- NOTE: The ledger DB will only ask the 'ChainDB' for blocks it knows
-- must exist. If the 'ChainDB' is unable to fulfill the request, data
-- corruption must have happened and the 'ChainDB' should trigger
-- validation mode.
type ResolveBlock m blk = RealPoint blk -> m blk

-- | Annotated ledger errors
data AnnLedgerError l blk = AnnLedgerError {
      -- | The ledger DB just /before/ this block was applied
      AnnLedgerError l blk -> LedgerDB l
annLedgerState  :: LedgerDB l

      -- | Reference to the block that had the error
    , AnnLedgerError l blk -> RealPoint blk
annLedgerErrRef :: RealPoint blk

      -- | The ledger error itself
    , AnnLedgerError l blk -> LedgerErr l
annLedgerErr    :: LedgerErr l
    }

-- | Monads in which we can resolve blocks
--
-- To guide type inference, we insist that we must be able to infer the type
-- of the block we are resolving from the type of the monad.
class Monad m => ResolvesBlocks m blk | m -> blk where
  resolveBlock :: ResolveBlock m blk

instance Monad m => ResolvesBlocks (ReaderT (ResolveBlock m blk) m) blk where
  resolveBlock :: ResolveBlock (ReaderT (ResolveBlock m blk) m) blk
resolveBlock RealPoint blk
r = (ResolveBlock m blk -> m blk) -> ReaderT (ResolveBlock m blk) m blk
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((ResolveBlock m blk -> m blk)
 -> ReaderT (ResolveBlock m blk) m blk)
-> (ResolveBlock m blk -> m blk)
-> ReaderT (ResolveBlock m blk) m blk
forall a b. (a -> b) -> a -> b
$ \ResolveBlock m blk
f -> ResolveBlock m blk
f RealPoint blk
r

defaultResolveBlocks :: ResolveBlock m blk
                     -> ReaderT (ResolveBlock m blk) m a
                     -> m a
defaultResolveBlocks :: ResolveBlock m blk -> ReaderT (ResolveBlock m blk) m a -> m a
defaultResolveBlocks = (ReaderT (ResolveBlock m blk) m a -> ResolveBlock m blk -> m a)
-> ResolveBlock m blk -> ReaderT (ResolveBlock m blk) m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (ResolveBlock m blk) m a -> ResolveBlock m blk -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT

-- Quite a specific instance so we can satisfy the fundep
instance Monad m
      => ResolvesBlocks (ExceptT e (ReaderT (ResolveBlock m blk) m)) blk where
  resolveBlock :: ResolveBlock (ExceptT e (ReaderT (ResolveBlock m blk) m)) blk
resolveBlock = ReaderT (ResolveBlock m blk) m blk
-> ExceptT e (ReaderT (ResolveBlock m blk) m) blk
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (ResolveBlock m blk) m blk
 -> ExceptT e (ReaderT (ResolveBlock m blk) m) blk)
-> (RealPoint blk -> ReaderT (ResolveBlock m blk) m blk)
-> ResolveBlock (ExceptT e (ReaderT (ResolveBlock m blk) m)) blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealPoint blk -> ReaderT (ResolveBlock m blk) m blk
forall (m :: * -> *) blk.
ResolvesBlocks m blk =>
ResolveBlock m blk
resolveBlock

class Monad m => ThrowsLedgerError m l blk where
  throwLedgerError :: LedgerDB l -> RealPoint blk -> LedgerErr l -> m a

defaultThrowLedgerErrors :: ExceptT (AnnLedgerError l blk) m a
                         -> m (Either (AnnLedgerError l blk) a)
defaultThrowLedgerErrors :: ExceptT (AnnLedgerError l blk) m a
-> m (Either (AnnLedgerError l blk) a)
defaultThrowLedgerErrors = ExceptT (AnnLedgerError l blk) m a
-> m (Either (AnnLedgerError l blk) a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

defaultResolveWithErrors :: ResolveBlock m blk
                         -> ExceptT (AnnLedgerError l blk)
                                    (ReaderT (ResolveBlock m blk) m)
                                    a
                         -> m (Either (AnnLedgerError l blk) a)
defaultResolveWithErrors :: ResolveBlock m blk
-> ExceptT
     (AnnLedgerError l blk) (ReaderT (ResolveBlock m blk) m) a
-> m (Either (AnnLedgerError l blk) a)
defaultResolveWithErrors ResolveBlock m blk
resolve =
      ResolveBlock m blk
-> ReaderT (ResolveBlock m blk) m (Either (AnnLedgerError l blk) a)
-> m (Either (AnnLedgerError l blk) a)
forall (m :: * -> *) blk a.
ResolveBlock m blk -> ReaderT (ResolveBlock m blk) m a -> m a
defaultResolveBlocks ResolveBlock m blk
resolve
    (ReaderT (ResolveBlock m blk) m (Either (AnnLedgerError l blk) a)
 -> m (Either (AnnLedgerError l blk) a))
-> (ExceptT
      (AnnLedgerError l blk) (ReaderT (ResolveBlock m blk) m) a
    -> ReaderT
         (ResolveBlock m blk) m (Either (AnnLedgerError l blk) a))
-> ExceptT
     (AnnLedgerError l blk) (ReaderT (ResolveBlock m blk) m) a
-> m (Either (AnnLedgerError l blk) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT (AnnLedgerError l blk) (ReaderT (ResolveBlock m blk) m) a
-> ReaderT (ResolveBlock m blk) m (Either (AnnLedgerError l blk) a)
forall l blk (m :: * -> *) a.
ExceptT (AnnLedgerError l blk) m a
-> m (Either (AnnLedgerError l blk) a)
defaultThrowLedgerErrors

instance Monad m => ThrowsLedgerError (ExceptT (AnnLedgerError l blk) m) l blk where
  throwLedgerError :: LedgerDB l
-> RealPoint blk
-> LedgerErr l
-> ExceptT (AnnLedgerError l blk) m a
throwLedgerError LedgerDB l
l RealPoint blk
r LedgerErr l
e = AnnLedgerError l blk -> ExceptT (AnnLedgerError l blk) m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AnnLedgerError l blk -> ExceptT (AnnLedgerError l blk) m a)
-> AnnLedgerError l blk -> ExceptT (AnnLedgerError l blk) m a
forall a b. (a -> b) -> a -> b
$ LedgerDB l -> RealPoint blk -> LedgerErr l -> AnnLedgerError l blk
forall l blk.
LedgerDB l -> RealPoint blk -> LedgerErr l -> AnnLedgerError l blk
AnnLedgerError LedgerDB l
l RealPoint blk
r LedgerErr l
e

-- | 'Ap' is used to pass information about blocks to ledger DB updates
--
-- The constructors serve two purposes:
--
-- * Specify the various parameters
--   a. Are we passing the block by value or by reference?
--   b. Are we applying or reapplying the block?
--
-- * Compute the constraint @c@ on the monad @m@ in order to run the query:
--   a. If we are passing a block by reference, we must be able to resolve it.
--   b. If we are applying rather than reapplying, we might have ledger errors.
data Ap :: (Type -> Type) -> Type -> Type -> Constraint -> Type where
  ReapplyVal ::           blk -> Ap m l blk ()
  ApplyVal   ::           blk -> Ap m l blk (                      ThrowsLedgerError m l blk)
  ReapplyRef :: RealPoint blk -> Ap m l blk (ResolvesBlocks m blk)
  ApplyRef   :: RealPoint blk -> Ap m l blk (ResolvesBlocks m blk, ThrowsLedgerError m l blk)

  -- | 'Weaken' increases the constraint on the monad @m@.
  --
  -- This is primarily useful when combining multiple 'Ap's in a single
  -- homogeneous structure.
  Weaken :: (c' => c) => Ap m l blk c -> Ap m l blk c'

{-------------------------------------------------------------------------------
  Internal utilities for 'Ap'
-------------------------------------------------------------------------------}

toRealPoint :: HasHeader blk => Ap m l blk c -> RealPoint blk
toRealPoint :: Ap m l blk c -> RealPoint blk
toRealPoint (ReapplyVal blk
blk) = blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
blk
toRealPoint (ApplyVal blk
blk)   = blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
blk
toRealPoint (ReapplyRef RealPoint blk
rp)  = RealPoint blk
rp
toRealPoint (ApplyRef RealPoint blk
rp)    = RealPoint blk
rp
toRealPoint (Weaken Ap m l blk c
ap)      = Ap m l blk c -> RealPoint blk
forall blk (m :: * -> *) l (c :: Constraint).
HasHeader blk =>
Ap m l blk c -> RealPoint blk
toRealPoint Ap m l blk c
ap

-- | Apply block to the current ledger state
--
-- We take in the entire 'LedgerDB' because we record that as part of errors.
applyBlock :: forall m c l blk. (ApplyBlock l blk, Monad m, c)
           => LedgerCfg l
           -> Ap m l blk c
           -> LedgerDB l -> m l
applyBlock :: LedgerCfg l -> Ap m l blk c -> LedgerDB l -> m l
applyBlock LedgerCfg l
cfg Ap m l blk c
ap LedgerDB l
db = case Ap m l blk c
ap of
    ReapplyVal blk
b ->
      l -> m l
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> m l) -> l -> m l
forall a b. (a -> b) -> a -> b
$
        LedgerCfg l -> blk -> l -> l
forall l blk. ApplyBlock l blk => LedgerCfg l -> blk -> l -> l
tickThenReapply LedgerCfg l
cfg blk
b l
l
    ApplyVal blk
b ->
      (LedgerErr l -> m l) -> (l -> m l) -> Either (LedgerErr l) l -> m l
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (LedgerDB l -> RealPoint blk -> LedgerErr l -> m l
forall (m :: * -> *) l blk a.
ThrowsLedgerError m l blk =>
LedgerDB l -> RealPoint blk -> LedgerErr l -> m a
throwLedgerError LedgerDB l
db (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
b)) l -> m l
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (LedgerErr l) l -> m l) -> Either (LedgerErr l) l -> m l
forall a b. (a -> b) -> a -> b
$ Except (LedgerErr l) l -> Either (LedgerErr l) l
forall e a. Except e a -> Either e a
runExcept (Except (LedgerErr l) l -> Either (LedgerErr l) l)
-> Except (LedgerErr l) l -> Either (LedgerErr l) l
forall a b. (a -> b) -> a -> b
$
        LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
tickThenApply LedgerCfg l
cfg blk
b l
l
    ReapplyRef RealPoint blk
r  -> do
      blk
b <- ResolveBlock m blk
forall (m :: * -> *) blk.
ResolvesBlocks m blk =>
ResolveBlock m blk
resolveBlock RealPoint blk
r
      l -> m l
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> m l) -> l -> m l
forall a b. (a -> b) -> a -> b
$
        LedgerCfg l -> blk -> l -> l
forall l blk. ApplyBlock l blk => LedgerCfg l -> blk -> l -> l
tickThenReapply LedgerCfg l
cfg blk
b l
l
    ApplyRef RealPoint blk
r -> do
      blk
b <- ResolveBlock m blk
forall (m :: * -> *) blk.
ResolvesBlocks m blk =>
ResolveBlock m blk
resolveBlock RealPoint blk
r
      (LedgerErr l -> m l) -> (l -> m l) -> Either (LedgerErr l) l -> m l
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (LedgerDB l -> RealPoint blk -> LedgerErr l -> m l
forall (m :: * -> *) l blk a.
ThrowsLedgerError m l blk =>
LedgerDB l -> RealPoint blk -> LedgerErr l -> m a
throwLedgerError LedgerDB l
db RealPoint blk
r) l -> m l
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (LedgerErr l) l -> m l) -> Either (LedgerErr l) l -> m l
forall a b. (a -> b) -> a -> b
$ Except (LedgerErr l) l -> Either (LedgerErr l) l
forall e a. Except e a -> Either e a
runExcept (Except (LedgerErr l) l -> Either (LedgerErr l) l)
-> Except (LedgerErr l) l -> Either (LedgerErr l) l
forall a b. (a -> b) -> a -> b
$
        LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
tickThenApply LedgerCfg l
cfg blk
b l
l
    Weaken Ap m l blk c
ap' ->
      LedgerCfg l -> Ap m l blk c -> LedgerDB l -> m l
forall (m :: * -> *) (c :: Constraint) l blk.
(ApplyBlock l blk, Monad m, c) =>
LedgerCfg l -> Ap m l blk c -> LedgerDB l -> m l
applyBlock LedgerCfg l
cfg Ap m l blk c
ap' LedgerDB l
db
  where
    l :: l
    l :: l
l = LedgerDB l -> l
forall l. GetTip l => LedgerDB l -> l
ledgerDbCurrent LedgerDB l
db

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

-- | The ledger state at the tip of the chain
ledgerDbCurrent :: GetTip l => LedgerDB l -> l
ledgerDbCurrent :: LedgerDB l -> l
ledgerDbCurrent = (Checkpoint l -> l)
-> (Checkpoint l -> l) -> Either (Checkpoint l) (Checkpoint l) -> l
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint (Either (Checkpoint l) (Checkpoint l) -> l)
-> (LedgerDB l -> Either (Checkpoint l) (Checkpoint l))
-> LedgerDB l
-> l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> Either (Checkpoint l) (Checkpoint l)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AS.head (AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
 -> Either (Checkpoint l) (Checkpoint l))
-> (LedgerDB l
    -> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l))
-> LedgerDB l
-> Either (Checkpoint l) (Checkpoint l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints

-- | Information about the state of the ledger at the anchor
ledgerDbAnchor :: LedgerDB l -> l
ledgerDbAnchor :: LedgerDB l -> l
ledgerDbAnchor = Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint (Checkpoint l -> l)
-> (LedgerDB l -> Checkpoint l) -> LedgerDB l -> l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> Checkpoint l
forall v a b. AnchoredSeq v a b -> a
AS.anchor (AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
 -> Checkpoint l)
-> (LedgerDB l
    -> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l))
-> LedgerDB l
-> Checkpoint l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints

-- | 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.
ledgerDbSnapshots :: LedgerDB l -> [(Word64, l)]
ledgerDbSnapshots :: LedgerDB l -> [(Word64, l)]
ledgerDbSnapshots LedgerDB{AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
..} =
    [Word64] -> [l] -> [(Word64, l)]
forall a b. [a] -> [b] -> [(a, b)]
zip
      [Word64
0..]
      ((Checkpoint l -> l) -> [Checkpoint l] -> [l]
forall a b. (a -> b) -> [a] -> [b]
map Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint (AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> [Checkpoint l]
forall v a b. AnchoredSeq v a b -> [b]
AS.toNewestFirst AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints)
        [l] -> [l] -> [l]
forall a. Semigroup a => a -> a -> a
<> [Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint (AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> Checkpoint l
forall v a b. AnchoredSeq v a b -> a
AS.anchor AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints)])

-- | How many blocks can we currently roll back?
ledgerDbMaxRollback :: GetTip l => LedgerDB l -> Word64
ledgerDbMaxRollback :: LedgerDB l -> Word64
ledgerDbMaxRollback LedgerDB{AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
..} = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AS.length AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints)

-- | Reference to the block at the tip of the chain
ledgerDbTip :: GetTip l => LedgerDB l -> Point l
ledgerDbTip :: LedgerDB l -> Point l
ledgerDbTip = l -> Point l
forall l. GetTip l => l -> Point l
getTip (l -> Point l) -> (LedgerDB l -> l) -> LedgerDB l -> Point l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDB l -> l
forall l. GetTip l => LedgerDB l -> l
ledgerDbCurrent

-- | Have we seen at least @k@ blocks?
ledgerDbIsSaturated :: GetTip l => SecurityParam -> LedgerDB l -> Bool
ledgerDbIsSaturated :: SecurityParam -> LedgerDB l -> Bool
ledgerDbIsSaturated (SecurityParam Word64
k) LedgerDB l
db =
    LedgerDB l -> Word64
forall l. GetTip l => LedgerDB l -> Word64
ledgerDbMaxRollback LedgerDB l
db Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= 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.
ledgerDbPast ::
     (HasHeader blk, IsLedger l, HeaderHash l ~ HeaderHash blk)
  => Point blk
  -> LedgerDB l
  -> Maybe l
ledgerDbPast :: Point blk -> LedgerDB l -> Maybe l
ledgerDbPast Point blk
pt LedgerDB l
db
    | Point blk
pt Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point l -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (l -> Point l
forall l. GetTip l => l -> Point l
getTip (LedgerDB l -> l
forall l. LedgerDB l -> l
ledgerDbAnchor LedgerDB l
db))
    = l -> Maybe l
forall a. a -> Maybe a
Just (l -> Maybe l) -> l -> Maybe l
forall a b. (a -> b) -> a -> b
$ LedgerDB l -> l
forall l. LedgerDB l -> l
ledgerDbAnchor LedgerDB l
db
    | Bool
otherwise
    = (Checkpoint l -> l) -> Maybe (Checkpoint l) -> Maybe l
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint (Maybe (Checkpoint l) -> Maybe l)
-> Maybe (Checkpoint l) -> Maybe l
forall a b. (a -> b) -> a -> b
$
        (Checkpoint l -> Bool) -> [Checkpoint l] -> Maybe (Checkpoint l)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk
pt) (Point blk -> Bool)
-> (Checkpoint l -> Point blk) -> Checkpoint l -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point l -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point l -> Point blk)
-> (Checkpoint l -> Point l) -> Checkpoint l -> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l -> Point l
forall l. GetTip l => l -> Point l
getTip (l -> Point l) -> (Checkpoint l -> l) -> Checkpoint l -> Point l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint) ([Checkpoint l] -> Maybe (Checkpoint l))
-> [Checkpoint l] -> Maybe (Checkpoint l)
forall a b. (a -> b) -> a -> b
$
          WithOrigin SlotNo
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> [Checkpoint l]
forall v a b. Anchorable v a b => v -> AnchoredSeq v a b -> [b]
AS.lookupByMeasure (Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
pt) (LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints LedgerDB l
db)

-- | Transform the underlying 'AnchoredSeq' using the given functions.
ledgerDbBimap ::
     Anchorable (WithOrigin SlotNo) a b
  => (l -> a)
  -> (l -> b)
  -> LedgerDB l
  -> AnchoredSeq (WithOrigin SlotNo) a b
ledgerDbBimap :: (l -> a)
-> (l -> b) -> LedgerDB l -> AnchoredSeq (WithOrigin SlotNo) a b
ledgerDbBimap l -> a
f l -> b
g =
    -- Instead of exposing 'ledgerDbCheckpoints' directly, this function hides
    -- the internal 'Checkpoint' type.
    (Checkpoint l -> a)
-> (Checkpoint l -> b)
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint 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 -> a
f (l -> a) -> (Checkpoint l -> l) -> Checkpoint l -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint) (l -> b
g (l -> b) -> (Checkpoint l -> l) -> Checkpoint l -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Checkpoint l -> l
forall l. Checkpoint l -> l
unCheckpoint) (AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
 -> AnchoredSeq (WithOrigin SlotNo) a b)
-> (LedgerDB l
    -> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l))
-> LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints


-- | Prune snapshots until at we have at most @k@ snapshots in the LedgerDB,
-- excluding the snapshots stored at the anchor.
ledgerDbPrune :: GetTip l => SecurityParam -> LedgerDB l -> LedgerDB l
ledgerDbPrune :: SecurityParam -> LedgerDB l -> LedgerDB l
ledgerDbPrune (SecurityParam Word64
k) LedgerDB l
db = LedgerDB l
db {
      ledgerDbCheckpoints :: AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints = Word64
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
forall v a b.
Anchorable v a b =>
Word64 -> AnchoredSeq v a b -> AnchoredSeq v a b
AS.anchorNewest Word64
k (LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints LedgerDB l
db)
    }

 -- NOTE: we must inline 'ledgerDbPrune' otherwise we get unexplained thunks in
 -- 'LedgerDB' and thus a space leak. Alternatively, we could disable the
 -- @-fstrictness@ optimisation (enabled by default for -O1). See #2532.
{-# INLINE ledgerDbPrune #-}

{-------------------------------------------------------------------------------
  Internal updates
-------------------------------------------------------------------------------}

-- | Push an updated ledger state
pushLedgerState ::
     GetTip l
  => SecurityParam
  -> l -- ^ Updated ledger state
  -> LedgerDB l -> LedgerDB l
pushLedgerState :: SecurityParam -> l -> LedgerDB l -> LedgerDB l
pushLedgerState SecurityParam
secParam l
current' db :: LedgerDB l
db@LedgerDB{AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
..}  =
    SecurityParam -> LedgerDB l -> LedgerDB l
forall l. GetTip l => SecurityParam -> LedgerDB l -> LedgerDB l
ledgerDbPrune SecurityParam
secParam (LedgerDB l -> LedgerDB l) -> LedgerDB l -> LedgerDB l
forall a b. (a -> b) -> a -> b
$ LedgerDB l
db {
        ledgerDbCheckpoints :: AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints = AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> Checkpoint l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
AS.:> l -> Checkpoint l
forall l. l -> Checkpoint l
Checkpoint l
current'
      }

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

-- | Rollback
--
-- Returns 'Nothing' if maximum rollback is exceeded.
rollback :: GetTip l => Word64 -> LedgerDB l -> Maybe (LedgerDB l)
rollback :: Word64 -> LedgerDB l -> Maybe (LedgerDB l)
rollback Word64
n db :: LedgerDB l
db@LedgerDB{AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
..}
    | Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= LedgerDB l -> Word64
forall l. GetTip l => LedgerDB l -> Word64
ledgerDbMaxRollback LedgerDB l
db
    = LedgerDB l -> Maybe (LedgerDB l)
forall a. a -> Maybe a
Just LedgerDB l
db {
          ledgerDbCheckpoints :: AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints = Int
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint 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) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints
        }
    | Bool
otherwise
    = Maybe (LedgerDB l)
forall a. Maybe a
Nothing

{-------------------------------------------------------------------------------
  Updates
-------------------------------------------------------------------------------}

-- | Exceeded maximum rollback supported by the current ledger DB state
--
-- Under normal circumstances this will not arise. It can really only happen
-- in the presence of data corruption (or when switching to a shorter fork,
-- but that is disallowed by all currently known Ouroboros protocols).
--
-- Records both the supported and the requested rollback.
data ExceededRollback = ExceededRollback {
      ExceededRollback -> Word64
rollbackMaximum   :: Word64
    , ExceededRollback -> Word64
rollbackRequested :: Word64
    }

ledgerDbPush :: forall m c l blk. (ApplyBlock l blk, Monad m, c)
             => LedgerDbCfg l
             -> Ap m l blk c -> LedgerDB l -> m (LedgerDB l)
ledgerDbPush :: LedgerDbCfg l -> Ap m l blk c -> LedgerDB l -> m (LedgerDB l)
ledgerDbPush LedgerDbCfg l
cfg Ap m l blk c
ap LedgerDB l
db =
    (\l
current' -> SecurityParam -> l -> LedgerDB l -> LedgerDB l
forall l.
GetTip l =>
SecurityParam -> l -> LedgerDB l -> LedgerDB l
pushLedgerState (LedgerDbCfg l -> SecurityParam
forall l. LedgerDbCfg l -> SecurityParam
ledgerDbCfgSecParam LedgerDbCfg l
cfg) l
current' LedgerDB l
db) (l -> LedgerDB l) -> m l -> m (LedgerDB l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      LedgerCfg l -> Ap m l blk c -> LedgerDB l -> m l
forall (m :: * -> *) (c :: Constraint) l blk.
(ApplyBlock l blk, Monad m, c) =>
LedgerCfg l -> Ap m l blk c -> LedgerDB l -> m l
applyBlock (LedgerDbCfg l -> LedgerCfg l
forall l. LedgerDbCfg l -> LedgerCfg l
ledgerDbCfg LedgerDbCfg l
cfg) Ap m l blk c
ap LedgerDB l
db

-- | Push a bunch of blocks (oldest first)
ledgerDbPushMany ::
     forall m c l blk . (ApplyBlock l blk, Monad m, c)
  => (Pushing blk -> m ())
  -> LedgerDbCfg l
  -> [Ap m l blk c] -> LedgerDB l -> m (LedgerDB l)
ledgerDbPushMany :: (Pushing blk -> m ())
-> LedgerDbCfg l -> [Ap m l blk c] -> LedgerDB l -> m (LedgerDB l)
ledgerDbPushMany Pushing blk -> m ()
trace LedgerDbCfg l
cfg [Ap m l blk c]
aps LedgerDB l
initDb = ((Ap m l blk c -> LedgerDB l -> m (LedgerDB l))
-> [Ap m l blk c] -> LedgerDB l -> m (LedgerDB l)
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m b) -> [a] -> b -> m b
repeatedlyM Ap m l blk c -> LedgerDB l -> m (LedgerDB l)
pushAndTrace) [Ap m l blk c]
aps LedgerDB l
initDb
  where
    pushAndTrace :: Ap m l blk c -> LedgerDB l -> m (LedgerDB l)
pushAndTrace Ap m l blk c
ap LedgerDB l
db = do
      let pushing :: Pushing blk
pushing = RealPoint blk -> Pushing blk
forall blk. RealPoint blk -> Pushing blk
Pushing (RealPoint blk -> Pushing blk)
-> (Ap m l blk c -> RealPoint blk) -> Ap m l blk c -> Pushing blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ap m l blk c -> RealPoint blk
forall blk (m :: * -> *) l (c :: Constraint).
HasHeader blk =>
Ap m l blk c -> RealPoint blk
toRealPoint (Ap m l blk c -> Pushing blk) -> Ap m l blk c -> Pushing blk
forall a b. (a -> b) -> a -> b
$ Ap m l blk c
ap
      Pushing blk -> m ()
trace Pushing blk
pushing
      LedgerDbCfg l -> Ap m l blk c -> LedgerDB l -> m (LedgerDB l)
forall (m :: * -> *) (c :: Constraint) l blk.
(ApplyBlock l blk, Monad m, c) =>
LedgerDbCfg l -> Ap m l blk c -> LedgerDB l -> m (LedgerDB l)
ledgerDbPush LedgerDbCfg l
cfg Ap m l blk c
ap LedgerDB l
db

-- | Switch to a fork
ledgerDbSwitch :: (ApplyBlock l blk, Monad m, c)
               => LedgerDbCfg l
               -> Word64          -- ^ How many blocks to roll back
               -> (UpdateLedgerDbTraceEvent blk -> m ())
               -> [Ap m l blk c]  -- ^ New blocks to apply
               -> LedgerDB l
               -> m (Either ExceededRollback (LedgerDB l))
ledgerDbSwitch :: LedgerDbCfg l
-> Word64
-> (UpdateLedgerDbTraceEvent blk -> m ())
-> [Ap m l blk c]
-> LedgerDB l
-> m (Either ExceededRollback (LedgerDB l))
ledgerDbSwitch LedgerDbCfg l
cfg Word64
numRollbacks UpdateLedgerDbTraceEvent blk -> m ()
trace [Ap m l blk c]
newBlocks LedgerDB l
db =
    case Word64 -> LedgerDB l -> Maybe (LedgerDB l)
forall l. GetTip l => Word64 -> LedgerDB l -> Maybe (LedgerDB l)
rollback Word64
numRollbacks LedgerDB l
db of
      Maybe (LedgerDB l)
Nothing ->
        Either ExceededRollback (LedgerDB l)
-> m (Either ExceededRollback (LedgerDB l))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ExceededRollback (LedgerDB l)
 -> m (Either ExceededRollback (LedgerDB l)))
-> Either ExceededRollback (LedgerDB l)
-> m (Either ExceededRollback (LedgerDB l))
forall a b. (a -> b) -> a -> b
$ ExceededRollback -> Either ExceededRollback (LedgerDB l)
forall a b. a -> Either a b
Left (ExceededRollback -> Either ExceededRollback (LedgerDB l))
-> ExceededRollback -> Either ExceededRollback (LedgerDB l)
forall a b. (a -> b) -> a -> b
$ ExceededRollback :: Word64 -> Word64 -> ExceededRollback
ExceededRollback {
            rollbackMaximum :: Word64
rollbackMaximum   = LedgerDB l -> Word64
forall l. GetTip l => LedgerDB l -> Word64
ledgerDbMaxRollback LedgerDB l
db
          , rollbackRequested :: Word64
rollbackRequested = Word64
numRollbacks
          }
      Just LedgerDB l
db' -> case [Ap m l blk c]
newBlocks of
        [] -> Either ExceededRollback (LedgerDB l)
-> m (Either ExceededRollback (LedgerDB l))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ExceededRollback (LedgerDB l)
 -> m (Either ExceededRollback (LedgerDB l)))
-> Either ExceededRollback (LedgerDB l)
-> m (Either ExceededRollback (LedgerDB l))
forall a b. (a -> b) -> a -> b
$ LedgerDB l -> Either ExceededRollback (LedgerDB l)
forall a b. b -> Either a b
Right LedgerDB l
db'
        -- no blocks to apply to ledger state, return current LedgerDB
        (Ap m l blk c
firstBlock:[Ap m l blk c]
_) -> do
          let start :: PushStart blk
start   = RealPoint blk -> PushStart blk
forall blk. RealPoint blk -> PushStart blk
PushStart (RealPoint blk -> PushStart blk)
-> (Ap m l blk c -> RealPoint blk) -> Ap m l blk c -> PushStart blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ap m l blk c -> RealPoint blk
forall blk (m :: * -> *) l (c :: Constraint).
HasHeader blk =>
Ap m l blk c -> RealPoint blk
toRealPoint (Ap m l blk c -> PushStart blk) -> Ap m l blk c -> PushStart blk
forall a b. (a -> b) -> a -> b
$ Ap m l blk c
firstBlock
              goal :: PushGoal blk
goal    = RealPoint blk -> PushGoal blk
forall blk. RealPoint blk -> PushGoal blk
PushGoal  (RealPoint blk -> PushGoal blk)
-> ([Ap m l blk c] -> RealPoint blk)
-> [Ap m l blk c]
-> PushGoal blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ap m l blk c -> RealPoint blk
forall blk (m :: * -> *) l (c :: Constraint).
HasHeader blk =>
Ap m l blk c -> RealPoint blk
toRealPoint (Ap m l blk c -> RealPoint blk)
-> ([Ap m l blk c] -> Ap m l blk c)
-> [Ap m l blk c]
-> RealPoint blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ap m l blk c] -> Ap m l blk c
forall a. [a] -> a
last ([Ap m l blk c] -> PushGoal blk) -> [Ap m l blk c] -> PushGoal blk
forall a b. (a -> b) -> a -> b
$ [Ap m l blk c]
newBlocks
          LedgerDB l -> Either ExceededRollback (LedgerDB l)
forall a b. b -> Either a b
Right (LedgerDB l -> Either ExceededRollback (LedgerDB l))
-> m (LedgerDB l) -> m (Either ExceededRollback (LedgerDB l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pushing blk -> m ())
-> LedgerDbCfg l -> [Ap m l blk c] -> LedgerDB l -> m (LedgerDB l)
forall (m :: * -> *) (c :: Constraint) l blk.
(ApplyBlock l blk, Monad m, c) =>
(Pushing blk -> m ())
-> LedgerDbCfg l -> [Ap m l blk c] -> LedgerDB l -> m (LedgerDB l)
ledgerDbPushMany (UpdateLedgerDbTraceEvent blk -> m ()
trace (UpdateLedgerDbTraceEvent blk -> m ())
-> (Pushing blk -> UpdateLedgerDbTraceEvent blk)
-> Pushing blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PushStart blk
-> PushGoal blk -> Pushing blk -> UpdateLedgerDbTraceEvent blk
forall blk.
PushStart blk
-> PushGoal blk -> Pushing blk -> UpdateLedgerDbTraceEvent blk
StartedPushingBlockToTheLedgerDb PushStart blk
start PushGoal blk
goal))
                                     LedgerDbCfg l
cfg
                                     [Ap m l blk c]
newBlocks
                                     LedgerDB l
db'

{-------------------------------------------------------------------------------
  The LedgerDB itself behaves like a ledger
-------------------------------------------------------------------------------}

data LedgerDbCfg l = LedgerDbCfg {
      LedgerDbCfg l -> SecurityParam
ledgerDbCfgSecParam :: !SecurityParam
    , LedgerDbCfg l -> LedgerCfg l
ledgerDbCfg         :: !(LedgerCfg l)
    }
  deriving ((forall x. LedgerDbCfg l -> Rep (LedgerDbCfg l) x)
-> (forall x. Rep (LedgerDbCfg l) x -> LedgerDbCfg l)
-> Generic (LedgerDbCfg l)
forall x. Rep (LedgerDbCfg l) x -> LedgerDbCfg l
forall x. LedgerDbCfg l -> Rep (LedgerDbCfg l) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall l x. Rep (LedgerDbCfg l) x -> LedgerDbCfg l
forall l x. LedgerDbCfg l -> Rep (LedgerDbCfg l) x
$cto :: forall l x. Rep (LedgerDbCfg l) x -> LedgerDbCfg l
$cfrom :: forall l x. LedgerDbCfg l -> Rep (LedgerDbCfg l) x
Generic)

deriving instance NoThunks (LedgerCfg l) => NoThunks (LedgerDbCfg l)

type instance LedgerCfg (LedgerDB l) = LedgerDbCfg l

type instance HeaderHash (LedgerDB l) = HeaderHash l

instance IsLedger l => GetTip (LedgerDB l) where
  getTip :: LedgerDB l -> Point (LedgerDB l)
getTip = Point l -> Point (LedgerDB l)
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point l -> Point (LedgerDB l))
-> (LedgerDB l -> Point l) -> LedgerDB l -> Point (LedgerDB l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l -> Point l
forall l. GetTip l => l -> Point l
getTip (l -> Point l) -> (LedgerDB l -> l) -> LedgerDB l -> Point l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDB l -> l
forall l. GetTip l => LedgerDB l -> l
ledgerDbCurrent

instance IsLedger l => GetTip (Ticked (LedgerDB l)) where
  getTip :: Ticked (LedgerDB l) -> Point (Ticked (LedgerDB l))
getTip = Point (LedgerDB l) -> Point (Ticked (LedgerDB l))
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (LedgerDB l) -> Point (Ticked (LedgerDB l)))
-> (Ticked (LedgerDB l) -> Point (LedgerDB l))
-> Ticked (LedgerDB l)
-> Point (Ticked (LedgerDB l))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDB l -> Point (LedgerDB l)
forall l. GetTip l => l -> Point l
getTip (LedgerDB l -> Point (LedgerDB l))
-> (Ticked (LedgerDB l) -> LedgerDB l)
-> Ticked (LedgerDB l)
-> Point (LedgerDB l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerDB l) -> LedgerDB l
forall l. Ticked (LedgerDB l) -> LedgerDB l
tickedLedgerDbOrig

instance IsLedger l => IsLedger (LedgerDB l) where
  type LedgerErr (LedgerDB l) = LedgerErr l

  type AuxLedgerEvent (LedgerDB l) = AuxLedgerEvent l

  applyChainTickLedgerResult :: LedgerCfg (LedgerDB l)
-> SlotNo
-> LedgerDB l
-> LedgerResult (LedgerDB l) (Ticked (LedgerDB l))
applyChainTickLedgerResult LedgerCfg (LedgerDB l)
cfg SlotNo
slot LedgerDB l
db =
      LedgerResult l (Ticked l) -> LedgerResult (LedgerDB l) (Ticked l)
forall l l' a.
(AuxLedgerEvent l ~ AuxLedgerEvent l') =>
LedgerResult l a -> LedgerResult l' a
castLedgerResult LedgerResult l (Ticked l)
ledgerResult LedgerResult (LedgerDB l) (Ticked l)
-> (Ticked l -> Ticked (LedgerDB l))
-> LedgerResult (LedgerDB l) (Ticked (LedgerDB l))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Ticked l
l -> TickedLedgerDB :: forall l. Ticked l -> LedgerDB l -> Ticked (LedgerDB l)
TickedLedgerDB {
          tickedLedgerDbTicked :: Ticked l
tickedLedgerDbTicked = Ticked l
l
        , tickedLedgerDbOrig :: LedgerDB l
tickedLedgerDbOrig   = LedgerDB l
db
        }
    where
      ledgerResult :: LedgerResult l (Ticked l)
ledgerResult = LedgerCfg l -> SlotNo -> l -> LedgerResult l (Ticked l)
forall l.
IsLedger l =>
LedgerCfg l -> SlotNo -> l -> LedgerResult l (Ticked l)
applyChainTickLedgerResult
                       (LedgerDbCfg l -> LedgerCfg l
forall l. LedgerDbCfg l -> LedgerCfg l
ledgerDbCfg LedgerCfg (LedgerDB l)
LedgerDbCfg l
cfg)
                       SlotNo
slot
                       (LedgerDB l -> l
forall l. GetTip l => LedgerDB l -> l
ledgerDbCurrent LedgerDB l
db)

instance ApplyBlock l blk => ApplyBlock (LedgerDB l) blk where
  applyBlockLedgerResult :: LedgerCfg (LedgerDB l)
-> blk
-> Ticked (LedgerDB l)
-> Except
     (LedgerErr (LedgerDB l)) (LedgerResult (LedgerDB l) (LedgerDB l))
applyBlockLedgerResult LedgerCfg (LedgerDB l)
cfg blk
blk TickedLedgerDB{..} = do
      LedgerResult l l
ledgerResult <- LedgerCfg l
-> blk
-> Ticked l
-> ExceptT (LedgerErr l) Identity (LedgerResult l l)
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l
-> blk -> Ticked l -> Except (LedgerErr l) (LedgerResult l l)
applyBlockLedgerResult
                        (LedgerDbCfg l -> LedgerCfg l
forall l. LedgerDbCfg l -> LedgerCfg l
ledgerDbCfg LedgerCfg (LedgerDB l)
LedgerDbCfg l
cfg)
                        blk
blk
                        Ticked l
tickedLedgerDbTicked

      LedgerResult (LedgerDB l) (LedgerDB l)
-> ExceptT
     (LedgerErr l) Identity (LedgerResult (LedgerDB l) (LedgerDB l))
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerResult (LedgerDB l) (LedgerDB l)
 -> ExceptT
      (LedgerErr l) Identity (LedgerResult (LedgerDB l) (LedgerDB l)))
-> LedgerResult (LedgerDB l) (LedgerDB l)
-> ExceptT
     (LedgerErr l) Identity (LedgerResult (LedgerDB l) (LedgerDB l))
forall a b. (a -> b) -> a -> b
$ l -> LedgerDB l
push (l -> LedgerDB l)
-> LedgerResult (LedgerDB l) l
-> LedgerResult (LedgerDB l) (LedgerDB l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerResult l l -> LedgerResult (LedgerDB l) l
forall l l' a.
(AuxLedgerEvent l ~ AuxLedgerEvent l') =>
LedgerResult l a -> LedgerResult l' a
castLedgerResult LedgerResult l l
ledgerResult
    where
      push :: l -> LedgerDB l
      push :: l -> LedgerDB l
push l
l = SecurityParam -> l -> LedgerDB l -> LedgerDB l
forall l.
GetTip l =>
SecurityParam -> l -> LedgerDB l -> LedgerDB l
pushLedgerState (LedgerDbCfg l -> SecurityParam
forall l. LedgerDbCfg l -> SecurityParam
ledgerDbCfgSecParam LedgerCfg (LedgerDB l)
LedgerDbCfg l
cfg) l
l LedgerDB l
tickedLedgerDbOrig

  reapplyBlockLedgerResult :: LedgerCfg (LedgerDB l)
-> blk
-> Ticked (LedgerDB l)
-> LedgerResult (LedgerDB l) (LedgerDB l)
reapplyBlockLedgerResult LedgerCfg (LedgerDB l)
cfg blk
blk TickedLedgerDB{..} =
      l -> LedgerDB l
push (l -> LedgerDB l)
-> LedgerResult (LedgerDB l) l
-> LedgerResult (LedgerDB l) (LedgerDB l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerResult l l -> LedgerResult (LedgerDB l) l
forall l l' a.
(AuxLedgerEvent l ~ AuxLedgerEvent l') =>
LedgerResult l a -> LedgerResult l' a
castLedgerResult LedgerResult l l
ledgerResult
    where
      push :: l -> LedgerDB l
      push :: l -> LedgerDB l
push l
l = SecurityParam -> l -> LedgerDB l -> LedgerDB l
forall l.
GetTip l =>
SecurityParam -> l -> LedgerDB l -> LedgerDB l
pushLedgerState (LedgerDbCfg l -> SecurityParam
forall l. LedgerDbCfg l -> SecurityParam
ledgerDbCfgSecParam LedgerCfg (LedgerDB l)
LedgerDbCfg l
cfg) l
l LedgerDB l
tickedLedgerDbOrig

      ledgerResult :: LedgerResult l l
ledgerResult = LedgerCfg l -> blk -> Ticked l -> LedgerResult l l
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l -> blk -> Ticked l -> LedgerResult l l
reapplyBlockLedgerResult
                       (LedgerDbCfg l -> LedgerCfg l
forall l. LedgerDbCfg l -> LedgerCfg l
ledgerDbCfg LedgerCfg (LedgerDB l)
LedgerDbCfg l
cfg)
                       blk
blk
                       Ticked l
tickedLedgerDbTicked

{-------------------------------------------------------------------------------
  Support for testing
-------------------------------------------------------------------------------}

pureBlock :: blk -> Ap m l blk ()
pureBlock :: blk -> Ap m l blk (() :: Constraint)
pureBlock = blk -> Ap m l blk (() :: Constraint)
forall blk (m :: * -> *) l. blk -> Ap m l blk (() :: Constraint)
ReapplyVal

ledgerDbPush' :: ApplyBlock l blk
              => LedgerDbCfg l -> blk -> LedgerDB l -> LedgerDB l
ledgerDbPush' :: LedgerDbCfg l -> blk -> LedgerDB l -> LedgerDB l
ledgerDbPush' LedgerDbCfg l
cfg blk
b = Identity (LedgerDB l) -> LedgerDB l
forall a. Identity a -> a
runIdentity (Identity (LedgerDB l) -> LedgerDB l)
-> (LedgerDB l -> Identity (LedgerDB l))
-> LedgerDB l
-> LedgerDB l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDbCfg l
-> Ap Identity l blk (() :: Constraint)
-> LedgerDB l
-> Identity (LedgerDB l)
forall (m :: * -> *) (c :: Constraint) l blk.
(ApplyBlock l blk, Monad m, c) =>
LedgerDbCfg l -> Ap m l blk c -> LedgerDB l -> m (LedgerDB l)
ledgerDbPush LedgerDbCfg l
cfg (blk -> Ap Identity l blk (() :: Constraint)
forall blk (m :: * -> *) l. blk -> Ap m l blk (() :: Constraint)
pureBlock blk
b)

ledgerDbPushMany' :: ApplyBlock l blk
                  => LedgerDbCfg l -> [blk] -> LedgerDB l -> LedgerDB l
ledgerDbPushMany' :: LedgerDbCfg l -> [blk] -> LedgerDB l -> LedgerDB l
ledgerDbPushMany' LedgerDbCfg l
cfg [blk]
bs =
  Identity (LedgerDB l) -> LedgerDB l
forall a. Identity a -> a
runIdentity (Identity (LedgerDB l) -> LedgerDB l)
-> (LedgerDB l -> Identity (LedgerDB l))
-> LedgerDB l
-> LedgerDB l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pushing blk -> Identity ())
-> LedgerDbCfg l
-> [Ap Identity l blk (() :: Constraint)]
-> LedgerDB l
-> Identity (LedgerDB l)
forall (m :: * -> *) (c :: Constraint) l blk.
(ApplyBlock l blk, Monad m, c) =>
(Pushing blk -> m ())
-> LedgerDbCfg l -> [Ap m l blk c] -> LedgerDB l -> m (LedgerDB l)
ledgerDbPushMany (Identity () -> Pushing blk -> Identity ()
forall a b. a -> b -> a
const (Identity () -> Pushing blk -> Identity ())
-> Identity () -> Pushing blk -> Identity ()
forall a b. (a -> b) -> a -> b
$ () -> Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) LedgerDbCfg l
cfg ((blk -> Ap Identity l blk (() :: Constraint))
-> [blk] -> [Ap Identity l blk (() :: Constraint)]
forall a b. (a -> b) -> [a] -> [b]
map blk -> Ap Identity l blk (() :: Constraint)
forall blk (m :: * -> *) l. blk -> Ap m l blk (() :: Constraint)
pureBlock [blk]
bs)

ledgerDbSwitch' :: forall l blk. ApplyBlock l blk
                => LedgerDbCfg l
                -> Word64 -> [blk] -> LedgerDB l -> Maybe (LedgerDB l)
ledgerDbSwitch' :: LedgerDbCfg l
-> Word64 -> [blk] -> LedgerDB l -> Maybe (LedgerDB l)
ledgerDbSwitch' LedgerDbCfg l
cfg Word64
n [blk]
bs LedgerDB l
db =
    case Identity (Either ExceededRollback (LedgerDB l))
-> Either ExceededRollback (LedgerDB l)
forall a. Identity a -> a
runIdentity (Identity (Either ExceededRollback (LedgerDB l))
 -> Either ExceededRollback (LedgerDB l))
-> Identity (Either ExceededRollback (LedgerDB l))
-> Either ExceededRollback (LedgerDB l)
forall a b. (a -> b) -> a -> b
$ LedgerDbCfg l
-> Word64
-> (UpdateLedgerDbTraceEvent blk -> Identity ())
-> [Ap Identity l blk (() :: Constraint)]
-> LedgerDB l
-> Identity (Either ExceededRollback (LedgerDB l))
forall l blk (m :: * -> *) (c :: Constraint).
(ApplyBlock l blk, Monad m, c) =>
LedgerDbCfg l
-> Word64
-> (UpdateLedgerDbTraceEvent blk -> m ())
-> [Ap m l blk c]
-> LedgerDB l
-> m (Either ExceededRollback (LedgerDB l))
ledgerDbSwitch LedgerDbCfg l
cfg Word64
n (Identity () -> UpdateLedgerDbTraceEvent blk -> Identity ()
forall a b. a -> b -> a
const (Identity () -> UpdateLedgerDbTraceEvent blk -> Identity ())
-> Identity () -> UpdateLedgerDbTraceEvent blk -> Identity ()
forall a b. (a -> b) -> a -> b
$ () -> Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ((blk -> Ap Identity l blk (() :: Constraint))
-> [blk] -> [Ap Identity l blk (() :: Constraint)]
forall a b. (a -> b) -> [a] -> [b]
map blk -> Ap Identity l blk (() :: Constraint)
forall blk (m :: * -> *) l. blk -> Ap m l blk (() :: Constraint)
pureBlock [blk]
bs) LedgerDB l
db of
      Left  ExceededRollback{} -> Maybe (LedgerDB l)
forall a. Maybe a
Nothing
      Right LedgerDB l
db'                -> LedgerDB l -> Maybe (LedgerDB l)
forall a. a -> Maybe a
Just LedgerDB l
db'

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

-- | Version 1: uses versioning ('Ouroboros.Consensus.Util.Versioned') and only
-- encodes the ledger state @l@.
snapshotEncodingVersion1 :: VersionNumber
snapshotEncodingVersion1 :: VersionNumber
snapshotEncodingVersion1 = VersionNumber
1

-- | Encoder to be used in combination with 'decodeSnapshotBackwardsCompatible'.
encodeSnapshot :: (l -> Encoding) -> l -> Encoding
encodeSnapshot :: (l -> Encoding) -> l -> Encoding
encodeSnapshot l -> Encoding
encodeLedger l
l =
    VersionNumber -> Encoding -> Encoding
encodeVersion VersionNumber
snapshotEncodingVersion1 (l -> Encoding
encodeLedger l
l)

-- | To remain backwards compatible with existing snapshots stored on disk, we
-- must accept the old format as well as the new format.
--
-- The old format:
-- * The tip: @WithOrigin (RealPoint blk)@
-- * The chain length: @Word64@
-- * The ledger state: @l@
--
-- The new format is described by 'snapshotEncodingVersion1'.
--
-- This decoder will accept and ignore them. The encoder ('encodeSnapshot') will
-- no longer encode them.
decodeSnapshotBackwardsCompatible ::
     forall l blk.
     Proxy blk
  -> (forall s. Decoder s l)
  -> (forall s. Decoder s (HeaderHash blk))
  -> forall s. Decoder s l
decodeSnapshotBackwardsCompatible :: Proxy blk
-> (forall s. Decoder s l)
-> (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s l
decodeSnapshotBackwardsCompatible Proxy blk
_ forall s. Decoder s l
decodeLedger forall s. Decoder s (HeaderHash blk)
decodeHash =
    (forall s. Maybe Int -> Decoder s l)
-> [(VersionNumber, VersionDecoder l)] -> forall s. Decoder s l
forall a.
(forall s. Maybe Int -> Decoder s a)
-> [(VersionNumber, VersionDecoder a)] -> forall s. Decoder s a
decodeVersionWithHook
      Maybe Int -> forall s. Decoder s l
forall s. Maybe Int -> Decoder s l
decodeOldFormat
      [(VersionNumber
snapshotEncodingVersion1, (forall s. Decoder s l) -> VersionDecoder l
forall a. (forall s. Decoder s a) -> VersionDecoder a
Decode forall s. Decoder s l
decodeVersion1)]
  where
    decodeVersion1 :: forall s. Decoder s l
    decodeVersion1 :: Decoder s l
decodeVersion1 = Decoder s l
forall s. Decoder s l
decodeLedger

    decodeOldFormat :: Maybe Int -> forall s. Decoder s l
    decodeOldFormat :: Maybe Int -> forall s. Decoder s l
decodeOldFormat (Just Int
3) = do
        Point blk
_ <- WithOrigin (RealPoint blk) -> Point blk
forall blk. WithOrigin (RealPoint blk) -> Point blk
withOriginRealPointToPoint (WithOrigin (RealPoint blk) -> Point blk)
-> Decoder s (WithOrigin (RealPoint blk)) -> Decoder s (Point blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
               Decoder s (RealPoint blk) -> Decoder s (WithOrigin (RealPoint blk))
forall s a. Decoder s a -> Decoder s (WithOrigin a)
decodeWithOrigin ((forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (RealPoint blk)
forall blk.
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (RealPoint blk)
decodeRealPoint @blk forall s. Decoder s (HeaderHash blk)
decodeHash)
        Word64
_ <- Decoder s Word64
forall s. Decoder s Word64
Dec.decodeWord64
        Decoder s l
forall s. Decoder s l
decodeLedger
    decodeOldFormat Maybe Int
mbListLen =
        String -> Decoder s l
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s l) -> String -> Decoder s l
forall a b. (a -> b) -> a -> b
$
          String
"decodeSnapshotBackwardsCompatible: invalid start " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
          Maybe Int -> String
forall a. Show a => a -> String
show Maybe Int
mbListLen