{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Accessors for the LedgerDB and management
--
-- This module defines the operations that can be done on a LedgerDB, as well as
-- the procedures to apply a block to a LedgerDB and pushing the resulting
-- LedgerState into the DB.
module Ouroboros.Consensus.Storage.LedgerDB.Update (
    -- * LedgerDB management
    ledgerDbWithAnchor
    -- * Applying blocks
  , AnnLedgerError (..)
  , AnnLedgerError'
  , Ap (..)
  , ExceededRollback (..)
  , ThrowsLedgerError (..)
  , defaultThrowLedgerErrors
    -- * Block resolution
  , ResolveBlock
  , ResolvesBlocks (..)
  , defaultResolveBlocks
    -- * Updates
  , defaultResolveWithErrors
  , ledgerDbBimap
  , ledgerDbPrune
  , ledgerDbPush
  , ledgerDbSwitch
    -- * Pure API
  , ledgerDbPush'
  , ledgerDbPushMany'
  , ledgerDbSwitch'
    -- * Trace
  , PushGoal (..)
  , PushStart (..)
  , Pushing (..)
  , UpdateLedgerDbTraceEvent (..)
  ) where

import           Control.Monad.Except (ExceptT, runExcept, runExceptT,
                     throwError)
import           Control.Monad.Reader (ReaderT (..), runReaderT)
import           Control.Monad.Trans.Class (lift)
import           Data.Functor.Identity
import           Data.Kind (Constraint, Type)
import           Data.Word
import           GHC.Generics
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Storage.LedgerDB.LedgerDB
import           Ouroboros.Consensus.Storage.LedgerDB.Query
import           Ouroboros.Consensus.Util
import           Ouroboros.Network.AnchoredSeq (Anchorable (..),
                     AnchoredSeq (..))
import qualified Ouroboros.Network.AnchoredSeq as AS

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

-- | '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.
type Ap :: (Type -> Type) -> Type -> Type -> Constraint -> Type
data Ap m l blk c 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 :: forall blk (m :: * -> *) l (c :: Constraint).
HasHeader blk =>
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 :: 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 = case Ap m l blk c
ap of
    ReapplyVal blk
b ->
      l -> m l
forall a. a -> m a
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 a. LedgerDB l -> RealPoint blk -> LedgerErr l -> m a
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 a. a -> m a
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
doResolveBlock RealPoint blk
r
      l -> m l
forall a. a -> m a
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
doResolveBlock 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 a. LedgerDB l -> RealPoint blk -> LedgerErr l -> m a
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 a. a -> m a
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

{-------------------------------------------------------------------------------
  Resolving blocks maybe from disk
-------------------------------------------------------------------------------}

-- | 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

-- | 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
  doResolveBlock :: ResolveBlock m blk

instance Monad m => ResolvesBlocks (ReaderT (ResolveBlock m blk) m) blk where
  doResolveBlock :: ResolveBlock (ReaderT (ResolveBlock m blk) m) blk
doResolveBlock 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 :: forall (m :: * -> *) blk a.
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
  doResolveBlock :: ResolveBlock (ExceptT e (ReaderT (ResolveBlock m blk) m)) blk
doResolveBlock = ReaderT (ResolveBlock m blk) m blk
-> ExceptT e (ReaderT (ResolveBlock m blk) m) blk
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
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
doResolveBlock

{-------------------------------------------------------------------------------
  A ledger error annotated with the LedgerDB
-------------------------------------------------------------------------------}

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

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

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

type AnnLedgerError' blk = AnnLedgerError (ExtLedgerState blk) blk

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

instance Monad m => ThrowsLedgerError (ExceptT (AnnLedgerError l blk) m) l blk where
  throwLedgerError :: forall a.
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 a.
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

defaultThrowLedgerErrors :: ExceptT (AnnLedgerError l blk) m a
                         -> m (Either (AnnLedgerError l blk) a)
defaultThrowLedgerErrors :: forall l blk (m :: * -> *) a.
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 :: forall (m :: * -> *) blk l a.
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

{-------------------------------------------------------------------------------
  LedgerDB management
-------------------------------------------------------------------------------}

-- | Ledger DB starting at the specified ledger state
ledgerDbWithAnchor :: GetTip l => l -> LedgerDB l
ledgerDbWithAnchor :: forall l. GetTip l => l -> LedgerDB l
ledgerDbWithAnchor l
anchor = 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)
    }

-- | 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 :: forall a b l.
Anchorable (WithOrigin SlotNo) a b =>
(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 :: forall l. GetTip l => SecurityParam -> LedgerDB l -> LedgerDB l
ledgerDbPrune (SecurityParam Word64
k) LedgerDB l
db = LedgerDB l
db {
      ledgerDbCheckpoints = AS.anchorNewest k (ledgerDbCheckpoints 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 :: forall l.
GetTip l =>
SecurityParam -> l -> LedgerDB l -> LedgerDB l
pushLedgerState SecurityParam
secParam l
current' db :: LedgerDB l
db@LedgerDB{AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: 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 = ledgerDbCheckpoints AS.:> Checkpoint current'
      }

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

-- | Rollback
--
-- Returns 'Nothing' if maximum rollback is exceeded.
rollback :: GetTip l => Word64 -> LedgerDB l -> Maybe (LedgerDB l)
rollback :: forall l. GetTip l => Word64 -> LedgerDB l -> Maybe (LedgerDB l)
rollback Word64
n db :: LedgerDB l
db@LedgerDB{AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: forall l.
LedgerDB l
-> AnchoredSeq (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l)
ledgerDbCheckpoints :: 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 = AS.dropNewest (fromIntegral n) 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 :: 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 =
    (\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 :: 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 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 :: 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
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 a. a -> m a
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 {
            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 a. a -> m a
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. HasCallStack => [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'

{-------------------------------------------------------------------------------
  Trace events
-------------------------------------------------------------------------------}

newtype PushStart blk = PushStart { forall blk. PushStart blk -> RealPoint blk
unPushStart :: RealPoint blk }
  deriving (Int -> PushStart blk -> ShowS
[PushStart blk] -> ShowS
PushStart blk -> String
(Int -> PushStart blk -> ShowS)
-> (PushStart blk -> String)
-> ([PushStart blk] -> ShowS)
-> Show (PushStart blk)
forall blk. StandardHash blk => Int -> PushStart blk -> ShowS
forall blk. StandardHash blk => [PushStart blk] -> ShowS
forall blk. StandardHash blk => PushStart blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. StandardHash blk => Int -> PushStart blk -> ShowS
showsPrec :: Int -> PushStart blk -> ShowS
$cshow :: forall blk. StandardHash blk => PushStart blk -> String
show :: PushStart blk -> String
$cshowList :: forall blk. StandardHash blk => [PushStart blk] -> ShowS
showList :: [PushStart blk] -> ShowS
Show, PushStart blk -> PushStart blk -> Bool
(PushStart blk -> PushStart blk -> Bool)
-> (PushStart blk -> PushStart blk -> Bool) -> Eq (PushStart blk)
forall blk.
StandardHash blk =>
PushStart blk -> PushStart blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
PushStart blk -> PushStart blk -> Bool
== :: PushStart blk -> PushStart blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
PushStart blk -> PushStart blk -> Bool
/= :: PushStart blk -> PushStart blk -> Bool
Eq)

newtype PushGoal blk = PushGoal { forall blk. PushGoal blk -> RealPoint blk
unPushGoal :: RealPoint blk }
  deriving (Int -> PushGoal blk -> ShowS
[PushGoal blk] -> ShowS
PushGoal blk -> String
(Int -> PushGoal blk -> ShowS)
-> (PushGoal blk -> String)
-> ([PushGoal blk] -> ShowS)
-> Show (PushGoal blk)
forall blk. StandardHash blk => Int -> PushGoal blk -> ShowS
forall blk. StandardHash blk => [PushGoal blk] -> ShowS
forall blk. StandardHash blk => PushGoal blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. StandardHash blk => Int -> PushGoal blk -> ShowS
showsPrec :: Int -> PushGoal blk -> ShowS
$cshow :: forall blk. StandardHash blk => PushGoal blk -> String
show :: PushGoal blk -> String
$cshowList :: forall blk. StandardHash blk => [PushGoal blk] -> ShowS
showList :: [PushGoal blk] -> ShowS
Show, PushGoal blk -> PushGoal blk -> Bool
(PushGoal blk -> PushGoal blk -> Bool)
-> (PushGoal blk -> PushGoal blk -> Bool) -> Eq (PushGoal blk)
forall blk.
StandardHash blk =>
PushGoal blk -> PushGoal blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
PushGoal blk -> PushGoal blk -> Bool
== :: PushGoal blk -> PushGoal blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
PushGoal blk -> PushGoal blk -> Bool
/= :: PushGoal blk -> PushGoal blk -> Bool
Eq)

newtype Pushing blk = Pushing { forall blk. Pushing blk -> RealPoint blk
unPushing :: RealPoint blk }
  deriving (Int -> Pushing blk -> ShowS
[Pushing blk] -> ShowS
Pushing blk -> String
(Int -> Pushing blk -> ShowS)
-> (Pushing blk -> String)
-> ([Pushing blk] -> ShowS)
-> Show (Pushing blk)
forall blk. StandardHash blk => Int -> Pushing blk -> ShowS
forall blk. StandardHash blk => [Pushing blk] -> ShowS
forall blk. StandardHash blk => Pushing blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. StandardHash blk => Int -> Pushing blk -> ShowS
showsPrec :: Int -> Pushing blk -> ShowS
$cshow :: forall blk. StandardHash blk => Pushing blk -> String
show :: Pushing blk -> String
$cshowList :: forall blk. StandardHash blk => [Pushing blk] -> ShowS
showList :: [Pushing blk] -> ShowS
Show, Pushing blk -> Pushing blk -> Bool
(Pushing blk -> Pushing blk -> Bool)
-> (Pushing blk -> Pushing blk -> Bool) -> Eq (Pushing blk)
forall blk. StandardHash blk => Pushing blk -> Pushing blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk. StandardHash blk => Pushing blk -> Pushing blk -> Bool
== :: Pushing blk -> Pushing blk -> Bool
$c/= :: forall blk. StandardHash blk => Pushing blk -> Pushing blk -> Bool
/= :: Pushing blk -> Pushing blk -> Bool
Eq)

data UpdateLedgerDbTraceEvent blk =
    -- | Event fired when we are about to push a block to the LedgerDB
      StartedPushingBlockToTheLedgerDb
        !(PushStart blk)
        -- ^ Point from which we started pushing new blocks
        (PushGoal blk)
        -- ^ Point to which we are updating the ledger, the last event
        -- StartedPushingBlockToTheLedgerDb will have Pushing and PushGoal
        -- wrapping over the same RealPoint
        !(Pushing blk)
        -- ^ Point which block we are about to push
  deriving (Int -> UpdateLedgerDbTraceEvent blk -> ShowS
[UpdateLedgerDbTraceEvent blk] -> ShowS
UpdateLedgerDbTraceEvent blk -> String
(Int -> UpdateLedgerDbTraceEvent blk -> ShowS)
-> (UpdateLedgerDbTraceEvent blk -> String)
-> ([UpdateLedgerDbTraceEvent blk] -> ShowS)
-> Show (UpdateLedgerDbTraceEvent blk)
forall blk.
StandardHash blk =>
Int -> UpdateLedgerDbTraceEvent blk -> ShowS
forall blk.
StandardHash blk =>
[UpdateLedgerDbTraceEvent blk] -> ShowS
forall blk.
StandardHash blk =>
UpdateLedgerDbTraceEvent blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk.
StandardHash blk =>
Int -> UpdateLedgerDbTraceEvent blk -> ShowS
showsPrec :: Int -> UpdateLedgerDbTraceEvent blk -> ShowS
$cshow :: forall blk.
StandardHash blk =>
UpdateLedgerDbTraceEvent blk -> String
show :: UpdateLedgerDbTraceEvent blk -> String
$cshowList :: forall blk.
StandardHash blk =>
[UpdateLedgerDbTraceEvent blk] -> ShowS
showList :: [UpdateLedgerDbTraceEvent blk] -> ShowS
Show, UpdateLedgerDbTraceEvent blk
-> UpdateLedgerDbTraceEvent blk -> Bool
(UpdateLedgerDbTraceEvent blk
 -> UpdateLedgerDbTraceEvent blk -> Bool)
-> (UpdateLedgerDbTraceEvent blk
    -> UpdateLedgerDbTraceEvent blk -> Bool)
-> Eq (UpdateLedgerDbTraceEvent blk)
forall blk.
StandardHash blk =>
UpdateLedgerDbTraceEvent blk
-> UpdateLedgerDbTraceEvent blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
UpdateLedgerDbTraceEvent blk
-> UpdateLedgerDbTraceEvent blk -> Bool
== :: UpdateLedgerDbTraceEvent blk
-> UpdateLedgerDbTraceEvent blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
UpdateLedgerDbTraceEvent blk
-> UpdateLedgerDbTraceEvent blk -> Bool
/= :: UpdateLedgerDbTraceEvent blk
-> UpdateLedgerDbTraceEvent blk -> Bool
Eq, (forall x.
 UpdateLedgerDbTraceEvent blk
 -> Rep (UpdateLedgerDbTraceEvent blk) x)
-> (forall x.
    Rep (UpdateLedgerDbTraceEvent blk) x
    -> UpdateLedgerDbTraceEvent blk)
-> Generic (UpdateLedgerDbTraceEvent blk)
forall x.
Rep (UpdateLedgerDbTraceEvent blk) x
-> UpdateLedgerDbTraceEvent blk
forall x.
UpdateLedgerDbTraceEvent blk
-> Rep (UpdateLedgerDbTraceEvent blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x.
Rep (UpdateLedgerDbTraceEvent blk) x
-> UpdateLedgerDbTraceEvent blk
forall blk x.
UpdateLedgerDbTraceEvent blk
-> Rep (UpdateLedgerDbTraceEvent blk) x
$cfrom :: forall blk x.
UpdateLedgerDbTraceEvent blk
-> Rep (UpdateLedgerDbTraceEvent blk) x
from :: forall x.
UpdateLedgerDbTraceEvent blk
-> Rep (UpdateLedgerDbTraceEvent blk) x
$cto :: forall blk x.
Rep (UpdateLedgerDbTraceEvent blk) x
-> UpdateLedgerDbTraceEvent blk
to :: forall x.
Rep (UpdateLedgerDbTraceEvent blk) x
-> UpdateLedgerDbTraceEvent blk
Generic)

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

pureBlock :: blk -> Ap m l blk ()
pureBlock :: forall blk (m :: * -> *) l. 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' :: forall l blk.
ApplyBlock l blk =>
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' :: forall l blk.
ApplyBlock l blk =>
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 a. a -> Identity a
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' :: forall l blk.
ApplyBlock l blk =>
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 a. a -> Identity a
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'