{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Storage.LedgerDB.Forker
  ( -- * Forker API
    ExceededRollback (..)
  , Forker (..)
  , Forker'
  , ForkerKey (..)
  , GetForkerError (..)
  , RangeQuery (..)
  , RangeQueryPrevious (..)
  , Statistics (..)
  , forkerCurrentPoint
  , castRangeQueryPrevious
  , ledgerStateReadOnlyForker

    -- ** Read only
  , ReadOnlyForker (..)
  , ReadOnlyForker'
  , readOnlyForker

    -- ** Tracing
  , TraceForkerEvent (..)
  , TraceForkerEventWithKey (..)
  , ForkerWasCommitted (..)

    -- * Validation
  , AnnLedgerError (..)
  , AnnLedgerError'
  , ResolveBlock
  , ValidateArgs (..)
  , ValidateResult (..)
  , validate

    -- ** Tracing
  , PushGoal (..)
  , PushStart (..)
  , Pushing (..)
  , TraceValidateEvent (..)
  ) where

import Control.Monad.Except
  ( runExcept
  )
import Control.ResourceRegistry
import Data.Bifunctor (first)
import Data.Kind
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word
import GHC.Generics
import NoThunks.Class
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache as BlockCache
import Ouroboros.Consensus.Util.CallStack
import Ouroboros.Consensus.Util.Enclose
import Ouroboros.Consensus.Util.IOLike

{-------------------------------------------------------------------------------
  Forker
-------------------------------------------------------------------------------}

-- | An independent handle to a point in the LedgerDB, which can be advanced to
-- evaluate forks in the chain.
type Forker :: (Type -> Type) -> LedgerStateKind -> Type
data Forker m l = Forker
  { forall (m :: * -> *) (l :: LedgerStateKind). Forker m l -> m ()
forkerClose :: !(m ())
  -- ^ Close the current forker (idempotent).
  --
  -- Other functions on forkers should throw a 'ClosedForkError' once the
  -- forker is closed.
  --
  -- Note: always use this functions before the forker is forgotten!
  -- Otherwise, cleanup of (on-disk) state might not be prompt or guaranteed.
  --
  -- This function should release any resources that are held by the forker,
  -- and not by the LedgerDB.
  , -- Queries

    forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l -> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
forkerReadTables :: !(LedgerTables l KeysMK -> m (LedgerTables l ValuesMK))
  -- ^ Read ledger tables from disk.
  , forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l
-> RangeQueryPrevious l
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
forkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK, Maybe (TxIn l)))
  -- ^ Range-read ledger tables from disk.
  --
  -- This range read will return as many values as the 'QueryBatchSize' that was
  -- passed when opening the LedgerDB.
  --
  -- The second component of the returned tuple is the maximal key found by the
  -- forker. This is only necessary because some backends have a different
  -- sorting for the keys than the order defined in Haskell.
  --
  -- The last key retrieved is part of the map too. It is intended to be fed
  -- back into the next iteration of the range read. If the function returns
  -- Nothing, it means the read returned no results, or in other words, we
  -- reached the end of the ledger tables.
  , forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l -> STM m (l EmptyMK)
forkerGetLedgerState :: !(STM m (l EmptyMK))
  -- ^ Get the full ledger state without tables.
  --
  -- If an empty ledger state is all you need, use 'getVolatileTip',
  -- 'getImmutableTip', or 'getPastLedgerState' instead of using a 'Forker'.
  , forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l -> m Statistics
forkerReadStatistics :: !(m Statistics)
  -- ^ Get statistics about the current state of the handle if possible.
  --
  -- Returns 'Nothing' if the implementation is backed by @lsm-tree@.
  , -- Updates

    forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l -> l DiffMK -> m ()
forkerPush :: !(l DiffMK -> m ())
  -- ^ Advance the fork handle by pushing a new ledger state to the tip of the
  -- current fork.
  , forall (m :: * -> *) (l :: LedgerStateKind). Forker m l -> STM m ()
forkerCommit :: !(STM m ())
  -- ^ Commit the fork, which was constructed using 'forkerPush', as the
  -- current version of the LedgerDB.
  }
  deriving (forall x. Forker m l -> Rep (Forker m l) x)
-> (forall x. Rep (Forker m l) x -> Forker m l)
-> Generic (Forker m l)
forall x. Rep (Forker m l) x -> Forker m l
forall x. Forker m l -> Rep (Forker m l) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) (l :: LedgerStateKind) x.
Rep (Forker m l) x -> Forker m l
forall (m :: * -> *) (l :: LedgerStateKind) x.
Forker m l -> Rep (Forker m l) x
$cfrom :: forall (m :: * -> *) (l :: LedgerStateKind) x.
Forker m l -> Rep (Forker m l) x
from :: forall x. Forker m l -> Rep (Forker m l) x
$cto :: forall (m :: * -> *) (l :: LedgerStateKind) x.
Rep (Forker m l) x -> Forker m l
to :: forall x. Rep (Forker m l) x -> Forker m l
Generic
  deriving Context -> Forker m l -> IO (Maybe ThunkInfo)
Proxy (Forker m l) -> String
(Context -> Forker m l -> IO (Maybe ThunkInfo))
-> (Context -> Forker m l -> IO (Maybe ThunkInfo))
-> (Proxy (Forker m l) -> String)
-> NoThunks (Forker m l)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) (l :: LedgerStateKind).
(Typeable l, Typeable m) =>
Context -> Forker m l -> IO (Maybe ThunkInfo)
forall (m :: * -> *) (l :: LedgerStateKind).
(Typeable l, Typeable m) =>
Proxy (Forker m l) -> String
$cnoThunks :: forall (m :: * -> *) (l :: LedgerStateKind).
(Typeable l, Typeable m) =>
Context -> Forker m l -> IO (Maybe ThunkInfo)
noThunks :: Context -> Forker m l -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) (l :: LedgerStateKind).
(Typeable l, Typeable m) =>
Context -> Forker m l -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Forker m l -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *) (l :: LedgerStateKind).
(Typeable l, Typeable m) =>
Proxy (Forker m l) -> String
showTypeOf :: Proxy (Forker m l) -> String
NoThunks via OnlyCheckWhnf (Forker m l)

-- | An identifier for a 'Forker'. See 'ldbForkers'.
newtype ForkerKey = ForkerKey Word16
  deriving stock (Int -> ForkerKey -> ShowS
[ForkerKey] -> ShowS
ForkerKey -> String
(Int -> ForkerKey -> ShowS)
-> (ForkerKey -> String)
-> ([ForkerKey] -> ShowS)
-> Show ForkerKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ForkerKey -> ShowS
showsPrec :: Int -> ForkerKey -> ShowS
$cshow :: ForkerKey -> String
show :: ForkerKey -> String
$cshowList :: [ForkerKey] -> ShowS
showList :: [ForkerKey] -> ShowS
Show, ForkerKey -> ForkerKey -> Bool
(ForkerKey -> ForkerKey -> Bool)
-> (ForkerKey -> ForkerKey -> Bool) -> Eq ForkerKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ForkerKey -> ForkerKey -> Bool
== :: ForkerKey -> ForkerKey -> Bool
$c/= :: ForkerKey -> ForkerKey -> Bool
/= :: ForkerKey -> ForkerKey -> Bool
Eq, Eq ForkerKey
Eq ForkerKey =>
(ForkerKey -> ForkerKey -> Ordering)
-> (ForkerKey -> ForkerKey -> Bool)
-> (ForkerKey -> ForkerKey -> Bool)
-> (ForkerKey -> ForkerKey -> Bool)
-> (ForkerKey -> ForkerKey -> Bool)
-> (ForkerKey -> ForkerKey -> ForkerKey)
-> (ForkerKey -> ForkerKey -> ForkerKey)
-> Ord ForkerKey
ForkerKey -> ForkerKey -> Bool
ForkerKey -> ForkerKey -> Ordering
ForkerKey -> ForkerKey -> ForkerKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ForkerKey -> ForkerKey -> Ordering
compare :: ForkerKey -> ForkerKey -> Ordering
$c< :: ForkerKey -> ForkerKey -> Bool
< :: ForkerKey -> ForkerKey -> Bool
$c<= :: ForkerKey -> ForkerKey -> Bool
<= :: ForkerKey -> ForkerKey -> Bool
$c> :: ForkerKey -> ForkerKey -> Bool
> :: ForkerKey -> ForkerKey -> Bool
$c>= :: ForkerKey -> ForkerKey -> Bool
>= :: ForkerKey -> ForkerKey -> Bool
$cmax :: ForkerKey -> ForkerKey -> ForkerKey
max :: ForkerKey -> ForkerKey -> ForkerKey
$cmin :: ForkerKey -> ForkerKey -> ForkerKey
min :: ForkerKey -> ForkerKey -> ForkerKey
Ord)
  deriving newtype (Int -> ForkerKey
ForkerKey -> Int
ForkerKey -> [ForkerKey]
ForkerKey -> ForkerKey
ForkerKey -> ForkerKey -> [ForkerKey]
ForkerKey -> ForkerKey -> ForkerKey -> [ForkerKey]
(ForkerKey -> ForkerKey)
-> (ForkerKey -> ForkerKey)
-> (Int -> ForkerKey)
-> (ForkerKey -> Int)
-> (ForkerKey -> [ForkerKey])
-> (ForkerKey -> ForkerKey -> [ForkerKey])
-> (ForkerKey -> ForkerKey -> [ForkerKey])
-> (ForkerKey -> ForkerKey -> ForkerKey -> [ForkerKey])
-> Enum ForkerKey
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ForkerKey -> ForkerKey
succ :: ForkerKey -> ForkerKey
$cpred :: ForkerKey -> ForkerKey
pred :: ForkerKey -> ForkerKey
$ctoEnum :: Int -> ForkerKey
toEnum :: Int -> ForkerKey
$cfromEnum :: ForkerKey -> Int
fromEnum :: ForkerKey -> Int
$cenumFrom :: ForkerKey -> [ForkerKey]
enumFrom :: ForkerKey -> [ForkerKey]
$cenumFromThen :: ForkerKey -> ForkerKey -> [ForkerKey]
enumFromThen :: ForkerKey -> ForkerKey -> [ForkerKey]
$cenumFromTo :: ForkerKey -> ForkerKey -> [ForkerKey]
enumFromTo :: ForkerKey -> ForkerKey -> [ForkerKey]
$cenumFromThenTo :: ForkerKey -> ForkerKey -> ForkerKey -> [ForkerKey]
enumFromThenTo :: ForkerKey -> ForkerKey -> ForkerKey -> [ForkerKey]
Enum, Context -> ForkerKey -> IO (Maybe ThunkInfo)
Proxy ForkerKey -> String
(Context -> ForkerKey -> IO (Maybe ThunkInfo))
-> (Context -> ForkerKey -> IO (Maybe ThunkInfo))
-> (Proxy ForkerKey -> String)
-> NoThunks ForkerKey
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> ForkerKey -> IO (Maybe ThunkInfo)
noThunks :: Context -> ForkerKey -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ForkerKey -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ForkerKey -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy ForkerKey -> String
showTypeOf :: Proxy ForkerKey -> String
NoThunks, Integer -> ForkerKey
ForkerKey -> ForkerKey
ForkerKey -> ForkerKey -> ForkerKey
(ForkerKey -> ForkerKey -> ForkerKey)
-> (ForkerKey -> ForkerKey -> ForkerKey)
-> (ForkerKey -> ForkerKey -> ForkerKey)
-> (ForkerKey -> ForkerKey)
-> (ForkerKey -> ForkerKey)
-> (ForkerKey -> ForkerKey)
-> (Integer -> ForkerKey)
-> Num ForkerKey
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: ForkerKey -> ForkerKey -> ForkerKey
+ :: ForkerKey -> ForkerKey -> ForkerKey
$c- :: ForkerKey -> ForkerKey -> ForkerKey
- :: ForkerKey -> ForkerKey -> ForkerKey
$c* :: ForkerKey -> ForkerKey -> ForkerKey
* :: ForkerKey -> ForkerKey -> ForkerKey
$cnegate :: ForkerKey -> ForkerKey
negate :: ForkerKey -> ForkerKey
$cabs :: ForkerKey -> ForkerKey
abs :: ForkerKey -> ForkerKey
$csignum :: ForkerKey -> ForkerKey
signum :: ForkerKey -> ForkerKey
$cfromInteger :: Integer -> ForkerKey
fromInteger :: Integer -> ForkerKey
Num)

type instance HeaderHash (Forker m l) = HeaderHash l

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

instance
  (GetTip l, MonadSTM m) =>
  GetTipSTM m (Forker m l)
  where
  getTipSTM :: Forker m l -> STM m (Point (Forker m l))
getTipSTM Forker m l
forker = Point l -> Point (Forker m l)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point l -> Point (Forker m l))
-> (l EmptyMK -> Point l) -> l EmptyMK -> Point (Forker m l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l EmptyMK -> Point l
forall (mk :: MapKind). l mk -> Point l
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip (l EmptyMK -> Point (Forker m l))
-> STM m (l EmptyMK) -> STM m (Point (Forker m l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Forker m l -> STM m (l EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l -> STM m (l EmptyMK)
forkerGetLedgerState Forker m l
forker

data RangeQueryPrevious l = NoPreviousQuery | PreviousQueryWasFinal | PreviousQueryWasUpTo (TxIn l)

castRangeQueryPrevious :: TxIn l ~ TxIn l' => RangeQueryPrevious l -> RangeQueryPrevious l'
castRangeQueryPrevious :: forall (l :: LedgerStateKind) (l' :: LedgerStateKind).
(TxIn l ~ TxIn l') =>
RangeQueryPrevious l -> RangeQueryPrevious l'
castRangeQueryPrevious RangeQueryPrevious l
NoPreviousQuery = RangeQueryPrevious l'
forall (l :: LedgerStateKind). RangeQueryPrevious l
NoPreviousQuery
castRangeQueryPrevious RangeQueryPrevious l
PreviousQueryWasFinal = RangeQueryPrevious l'
forall (l :: LedgerStateKind). RangeQueryPrevious l
PreviousQueryWasFinal
castRangeQueryPrevious (PreviousQueryWasUpTo TxIn l
txin) = TxIn l' -> RangeQueryPrevious l'
forall (l :: LedgerStateKind). TxIn l -> RangeQueryPrevious l
PreviousQueryWasUpTo TxIn l
TxIn l'
txin

data RangeQuery l = RangeQuery
  { forall (l :: LedgerStateKind). RangeQuery l -> RangeQueryPrevious l
rqPrev :: !(RangeQueryPrevious l)
  , forall (l :: LedgerStateKind). RangeQuery l -> Int
rqCount :: !Int
  }

-- | This type captures the size of the ledger tables at a particular point in
-- the LedgerDB.
--
-- This is for now the only metric that was requested from other components, but
-- this type might be augmented in the future with more statistics.
newtype Statistics = Statistics
  { Statistics -> Int
ledgerTableSize :: Int
  }

-- | Errors that can be thrown while acquiring forkers.
data GetForkerError
  = -- | The requested point was not found in the LedgerDB, but the point is
    -- recent enough that the point is not in the immutable part of the chain,
    -- i.e. it belongs to an unselected fork.
    PointNotOnChain
  | -- | The requested point was not found in the LedgerDB because the point
    -- older than the immutable tip.
    PointTooOld !(Maybe ExceededRollback)
  deriving (Int -> GetForkerError -> ShowS
[GetForkerError] -> ShowS
GetForkerError -> String
(Int -> GetForkerError -> ShowS)
-> (GetForkerError -> String)
-> ([GetForkerError] -> ShowS)
-> Show GetForkerError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GetForkerError -> ShowS
showsPrec :: Int -> GetForkerError -> ShowS
$cshow :: GetForkerError -> String
show :: GetForkerError -> String
$cshowList :: [GetForkerError] -> ShowS
showList :: [GetForkerError] -> ShowS
Show, GetForkerError -> GetForkerError -> Bool
(GetForkerError -> GetForkerError -> Bool)
-> (GetForkerError -> GetForkerError -> Bool) -> Eq GetForkerError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GetForkerError -> GetForkerError -> Bool
== :: GetForkerError -> GetForkerError -> Bool
$c/= :: GetForkerError -> GetForkerError -> Bool
/= :: GetForkerError -> GetForkerError -> Bool
Eq)

-- | 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
  }
  deriving (Int -> ExceededRollback -> ShowS
[ExceededRollback] -> ShowS
ExceededRollback -> String
(Int -> ExceededRollback -> ShowS)
-> (ExceededRollback -> String)
-> ([ExceededRollback] -> ShowS)
-> Show ExceededRollback
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExceededRollback -> ShowS
showsPrec :: Int -> ExceededRollback -> ShowS
$cshow :: ExceededRollback -> String
show :: ExceededRollback -> String
$cshowList :: [ExceededRollback] -> ShowS
showList :: [ExceededRollback] -> ShowS
Show, ExceededRollback -> ExceededRollback -> Bool
(ExceededRollback -> ExceededRollback -> Bool)
-> (ExceededRollback -> ExceededRollback -> Bool)
-> Eq ExceededRollback
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExceededRollback -> ExceededRollback -> Bool
== :: ExceededRollback -> ExceededRollback -> Bool
$c/= :: ExceededRollback -> ExceededRollback -> Bool
/= :: ExceededRollback -> ExceededRollback -> Bool
Eq)

forkerCurrentPoint ::
  (GetTip l, HeaderHash l ~ HeaderHash blk, Functor (STM m)) =>
  Proxy blk ->
  Forker m l ->
  STM m (Point blk)
forkerCurrentPoint :: forall (l :: LedgerStateKind) blk (m :: * -> *).
(GetTip l, HeaderHash l ~ HeaderHash blk, Functor (STM m)) =>
Proxy blk -> Forker m l -> STM m (Point blk)
forkerCurrentPoint Proxy blk
_ Forker m l
forker =
  Point l -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint
    (Point l -> Point blk)
-> (l EmptyMK -> Point l) -> l EmptyMK -> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l EmptyMK -> Point l
forall (mk :: MapKind). l mk -> Point l
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip
    (l EmptyMK -> Point blk) -> STM m (l EmptyMK) -> STM m (Point blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Forker m l -> STM m (l EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l -> STM m (l EmptyMK)
forkerGetLedgerState Forker m l
forker

ledgerStateReadOnlyForker ::
  IOLike m => ReadOnlyForker m (ExtLedgerState blk) -> ReadOnlyForker m (LedgerState blk)
ledgerStateReadOnlyForker :: forall (m :: * -> *) blk.
IOLike m =>
ReadOnlyForker m (ExtLedgerState blk)
-> ReadOnlyForker m (LedgerState blk)
ledgerStateReadOnlyForker ReadOnlyForker m (ExtLedgerState blk)
frk =
  ReadOnlyForker
    { roforkerClose :: m ()
roforkerClose = m ()
roforkerClose
    , roforkerReadTables :: LedgerTables (LedgerState blk) KeysMK
-> m (LedgerTables (LedgerState blk) ValuesMK)
roforkerReadTables = (LedgerTables (ExtLedgerState blk) ValuesMK
 -> LedgerTables (LedgerState blk) ValuesMK)
-> m (LedgerTables (ExtLedgerState blk) ValuesMK)
-> m (LedgerTables (LedgerState blk) ValuesMK)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LedgerTables (ExtLedgerState blk) ValuesMK
-> LedgerTables (LedgerState blk) ValuesMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: MapKind).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables (m (LedgerTables (ExtLedgerState blk) ValuesMK)
 -> m (LedgerTables (LedgerState blk) ValuesMK))
-> (LedgerTables (LedgerState blk) KeysMK
    -> m (LedgerTables (ExtLedgerState blk) ValuesMK))
-> LedgerTables (LedgerState blk) KeysMK
-> m (LedgerTables (LedgerState blk) ValuesMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerTables (ExtLedgerState blk) KeysMK
-> m (LedgerTables (ExtLedgerState blk) ValuesMK)
roforkerReadTables (LedgerTables (ExtLedgerState blk) KeysMK
 -> m (LedgerTables (ExtLedgerState blk) ValuesMK))
-> (LedgerTables (LedgerState blk) KeysMK
    -> LedgerTables (ExtLedgerState blk) KeysMK)
-> LedgerTables (LedgerState blk) KeysMK
-> m (LedgerTables (ExtLedgerState blk) ValuesMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerTables (LedgerState blk) KeysMK
-> LedgerTables (ExtLedgerState blk) KeysMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: MapKind).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables
    , roforkerRangeReadTables :: RangeQueryPrevious (LedgerState blk)
-> m (LedgerTables (LedgerState blk) ValuesMK,
      Maybe (TxIn (LedgerState blk)))
roforkerRangeReadTables =
        ((LedgerTables (ExtLedgerState blk) ValuesMK,
  Maybe (TxIn (LedgerState blk)))
 -> (LedgerTables (LedgerState blk) ValuesMK,
     Maybe (TxIn (LedgerState blk))))
-> m (LedgerTables (ExtLedgerState blk) ValuesMK,
      Maybe (TxIn (LedgerState blk)))
-> m (LedgerTables (LedgerState blk) ValuesMK,
      Maybe (TxIn (LedgerState blk)))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LedgerTables (ExtLedgerState blk) ValuesMK
 -> LedgerTables (LedgerState blk) ValuesMK)
-> (LedgerTables (ExtLedgerState blk) ValuesMK,
    Maybe (TxIn (LedgerState blk)))
-> (LedgerTables (LedgerState blk) ValuesMK,
    Maybe (TxIn (LedgerState blk)))
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: MapKind) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first LedgerTables (ExtLedgerState blk) ValuesMK
-> LedgerTables (LedgerState blk) ValuesMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: MapKind).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables) (m (LedgerTables (ExtLedgerState blk) ValuesMK,
    Maybe (TxIn (LedgerState blk)))
 -> m (LedgerTables (LedgerState blk) ValuesMK,
       Maybe (TxIn (LedgerState blk))))
-> (RangeQueryPrevious (LedgerState blk)
    -> m (LedgerTables (ExtLedgerState blk) ValuesMK,
          Maybe (TxIn (LedgerState blk))))
-> RangeQueryPrevious (LedgerState blk)
-> m (LedgerTables (LedgerState blk) ValuesMK,
      Maybe (TxIn (LedgerState blk)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RangeQueryPrevious (ExtLedgerState blk)
-> m (LedgerTables (ExtLedgerState blk) ValuesMK,
      Maybe (TxIn (LedgerState blk)))
RangeQueryPrevious (ExtLedgerState blk)
-> m (LedgerTables (ExtLedgerState blk) ValuesMK,
      Maybe (TxIn (ExtLedgerState blk)))
roforkerRangeReadTables (RangeQueryPrevious (ExtLedgerState blk)
 -> m (LedgerTables (ExtLedgerState blk) ValuesMK,
       Maybe (TxIn (LedgerState blk))))
-> (RangeQueryPrevious (LedgerState blk)
    -> RangeQueryPrevious (ExtLedgerState blk))
-> RangeQueryPrevious (LedgerState blk)
-> m (LedgerTables (ExtLedgerState blk) ValuesMK,
      Maybe (TxIn (LedgerState blk)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RangeQueryPrevious (LedgerState blk)
-> RangeQueryPrevious (ExtLedgerState blk)
forall (l :: LedgerStateKind) (l' :: LedgerStateKind).
(TxIn l ~ TxIn l') =>
RangeQueryPrevious l -> RangeQueryPrevious l'
castRangeQueryPrevious
    , roforkerGetLedgerState :: STM m (LedgerState blk EmptyMK)
roforkerGetLedgerState = ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState (ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK)
-> STM m (ExtLedgerState blk EmptyMK)
-> STM m (LedgerState blk EmptyMK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (ExtLedgerState blk EmptyMK)
roforkerGetLedgerState
    , roforkerReadStatistics :: m Statistics
roforkerReadStatistics = m Statistics
roforkerReadStatistics
    }
 where
  ReadOnlyForker
    { m ()
roforkerClose :: forall (m :: * -> *) (l :: LedgerStateKind).
ReadOnlyForker m l -> m ()
roforkerClose :: m ()
roforkerClose
    , LedgerTables (ExtLedgerState blk) KeysMK
-> m (LedgerTables (ExtLedgerState blk) ValuesMK)
roforkerReadTables :: forall (m :: * -> *) (l :: LedgerStateKind).
ReadOnlyForker m l
-> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
roforkerReadTables :: LedgerTables (ExtLedgerState blk) KeysMK
-> m (LedgerTables (ExtLedgerState blk) ValuesMK)
roforkerReadTables
    , RangeQueryPrevious (ExtLedgerState blk)
-> m (LedgerTables (ExtLedgerState blk) ValuesMK,
      Maybe (TxIn (ExtLedgerState blk)))
roforkerRangeReadTables :: forall (m :: * -> *) (l :: LedgerStateKind).
ReadOnlyForker m l
-> RangeQueryPrevious l
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
roforkerRangeReadTables :: RangeQueryPrevious (ExtLedgerState blk)
-> m (LedgerTables (ExtLedgerState blk) ValuesMK,
      Maybe (TxIn (ExtLedgerState blk)))
roforkerRangeReadTables
    , STM m (ExtLedgerState blk EmptyMK)
roforkerGetLedgerState :: forall (m :: * -> *) (l :: LedgerStateKind).
ReadOnlyForker m l -> STM m (l EmptyMK)
roforkerGetLedgerState :: STM m (ExtLedgerState blk EmptyMK)
roforkerGetLedgerState
    , m Statistics
roforkerReadStatistics :: forall (m :: * -> *) (l :: LedgerStateKind).
ReadOnlyForker m l -> m Statistics
roforkerReadStatistics :: m Statistics
roforkerReadStatistics
    } = ReadOnlyForker m (ExtLedgerState blk)
frk

{-------------------------------------------------------------------------------
  Read-only forkers
-------------------------------------------------------------------------------}

-- | Read-only 'Forker'.
--
-- These forkers are not allowed to commit. They are used everywhere except in
-- Chain Selection. In particular they are now used in:
--
-- - LocalStateQuery server, via 'getReadOnlyForkerAtPoint'
--
-- - Forging loop.
--
-- - Mempool.
type ReadOnlyForker :: (Type -> Type) -> LedgerStateKind -> Type
data ReadOnlyForker m l = ReadOnlyForker
  { forall (m :: * -> *) (l :: LedgerStateKind).
ReadOnlyForker m l -> m ()
roforkerClose :: !(m ())
  -- ^ See 'forkerClose'
  , forall (m :: * -> *) (l :: LedgerStateKind).
ReadOnlyForker m l
-> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
roforkerReadTables :: !(LedgerTables l KeysMK -> m (LedgerTables l ValuesMK))
  -- ^ See 'forkerReadTables'
  , forall (m :: * -> *) (l :: LedgerStateKind).
ReadOnlyForker m l
-> RangeQueryPrevious l
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
roforkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK, Maybe (TxIn l)))
  -- ^ See 'forkerRangeReadTables'.
  , forall (m :: * -> *) (l :: LedgerStateKind).
ReadOnlyForker m l -> STM m (l EmptyMK)
roforkerGetLedgerState :: !(STM m (l EmptyMK))
  -- ^ See 'forkerGetLedgerState'
  , forall (m :: * -> *) (l :: LedgerStateKind).
ReadOnlyForker m l -> m Statistics
roforkerReadStatistics :: !(m Statistics)
  -- ^ See 'forkerReadStatistics'
  }
  deriving (forall x. ReadOnlyForker m l -> Rep (ReadOnlyForker m l) x)
-> (forall x. Rep (ReadOnlyForker m l) x -> ReadOnlyForker m l)
-> Generic (ReadOnlyForker m l)
forall x. Rep (ReadOnlyForker m l) x -> ReadOnlyForker m l
forall x. ReadOnlyForker m l -> Rep (ReadOnlyForker m l) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) (l :: LedgerStateKind) x.
Rep (ReadOnlyForker m l) x -> ReadOnlyForker m l
forall (m :: * -> *) (l :: LedgerStateKind) x.
ReadOnlyForker m l -> Rep (ReadOnlyForker m l) x
$cfrom :: forall (m :: * -> *) (l :: LedgerStateKind) x.
ReadOnlyForker m l -> Rep (ReadOnlyForker m l) x
from :: forall x. ReadOnlyForker m l -> Rep (ReadOnlyForker m l) x
$cto :: forall (m :: * -> *) (l :: LedgerStateKind) x.
Rep (ReadOnlyForker m l) x -> ReadOnlyForker m l
to :: forall x. Rep (ReadOnlyForker m l) x -> ReadOnlyForker m l
Generic

instance NoThunks (ReadOnlyForker m l) where
  wNoThunks :: Context -> ReadOnlyForker m l -> IO (Maybe ThunkInfo)
wNoThunks Context
_ ReadOnlyForker m l
_ = Maybe ThunkInfo -> IO (Maybe ThunkInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ThunkInfo
forall a. Maybe a
Nothing
  showTypeOf :: Proxy (ReadOnlyForker m l) -> String
showTypeOf Proxy (ReadOnlyForker m l)
_ = String
"ReadOnlyForker"

type instance HeaderHash (ReadOnlyForker m l) = HeaderHash l

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

readOnlyForker :: Forker m l -> ReadOnlyForker m l
readOnlyForker :: forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l -> ReadOnlyForker m l
readOnlyForker Forker m l
forker =
  ReadOnlyForker
    { roforkerClose :: m ()
roforkerClose = Forker m l -> m ()
forall (m :: * -> *) (l :: LedgerStateKind). Forker m l -> m ()
forkerClose Forker m l
forker
    , roforkerReadTables :: LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
roforkerReadTables = Forker m l -> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l -> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
forkerReadTables Forker m l
forker
    , roforkerRangeReadTables :: RangeQueryPrevious l -> m (LedgerTables l ValuesMK, Maybe (TxIn l))
roforkerRangeReadTables = Forker m l
-> RangeQueryPrevious l
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l
-> RangeQueryPrevious l
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
forkerRangeReadTables Forker m l
forker
    , roforkerGetLedgerState :: STM m (l EmptyMK)
roforkerGetLedgerState = Forker m l -> STM m (l EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l -> STM m (l EmptyMK)
forkerGetLedgerState Forker m l
forker
    , roforkerReadStatistics :: m Statistics
roforkerReadStatistics = Forker m l -> m Statistics
forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l -> m Statistics
forkerReadStatistics Forker m l
forker
    }

{-------------------------------------------------------------------------------
  Validation
-------------------------------------------------------------------------------}

data ValidateArgs m l blk = ValidateArgs
  { forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> ResolveBlock m blk
resolve :: !(ResolveBlock m blk)
  -- ^ How to retrieve blocks from headers
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> LedgerCfg l
validateConfig :: !(LedgerCfg l)
  -- ^ The config
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> [RealPoint blk] -> STM m ()
addPrevApplied :: !([RealPoint blk] -> STM m ())
  -- ^ How to add a previously applied block to the set of known blocks
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> STM m (Set (RealPoint blk))
prevApplied :: !(STM m (Set (RealPoint blk)))
  -- ^ Get the current set of previously applied blocks
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk
-> ResourceRegistry m
-> Word64
-> m (Either GetForkerError (Forker m l))
forkerAtFromTip :: !(ResourceRegistry m -> Word64 -> m (Either GetForkerError (Forker m l)))
  -- ^ Create a forker from the tip
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> ResourceRegistry m
resourceReg :: !(ResourceRegistry m)
  -- ^ The resource registry
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> TraceValidateEvent blk -> m ()
trace :: !(TraceValidateEvent blk -> m ())
  -- ^ A tracer for validate events
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> BlockCache blk
blockCache :: BlockCache blk
  -- ^ The block cache
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> Word64
numRollbacks :: Word64
  -- ^ How many blocks to roll back before applying the blocks
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> NonEmpty (Header blk)
hdrs :: NonEmpty (Header blk)
  -- ^ The headers we want to apply
  }

validate ::
  forall m l blk.
  ( IOLike m
  , HasCallStack
  , ApplyBlock l blk
  ) =>
  ComputeLedgerEvents ->
  ValidateArgs m l blk ->
  m (ValidateResult m l blk)
validate :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(IOLike m, HasCallStack, ApplyBlock l blk) =>
ComputeLedgerEvents
-> ValidateArgs m l blk -> m (ValidateResult m l blk)
validate ComputeLedgerEvents
evs ValidateArgs m l blk
args = do
  aps <- Set (RealPoint blk) -> NonEmpty (Ap m l blk)
mkAps (Set (RealPoint blk) -> NonEmpty (Ap m l blk))
-> m (Set (RealPoint blk)) -> m (NonEmpty (Ap m l blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (Set (RealPoint blk)) -> m (Set (RealPoint blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (Set (RealPoint blk))
prevApplied
  res <-
    fmap rewrap $
      switch
        forkerAtFromTip
        resourceReg
        evs
        validateConfig
        numRollbacks
        trace
        aps
        resolve
  atomically $ addPrevApplied (validBlockPoints res (map headerRealPoint $ NE.toList hdrs))
  return res
 where
  ValidateArgs
    { ResolveBlock m blk
resolve :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> ResolveBlock m blk
resolve :: ResolveBlock m blk
resolve
    , LedgerCfg l
validateConfig :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> LedgerCfg l
validateConfig :: LedgerCfg l
validateConfig
    , [RealPoint blk] -> STM m ()
addPrevApplied :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> [RealPoint blk] -> STM m ()
addPrevApplied :: [RealPoint blk] -> STM m ()
addPrevApplied
    , STM m (Set (RealPoint blk))
prevApplied :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> STM m (Set (RealPoint blk))
prevApplied :: STM m (Set (RealPoint blk))
prevApplied
    , ResourceRegistry m
-> Word64 -> m (Either GetForkerError (Forker m l))
forkerAtFromTip :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk
-> ResourceRegistry m
-> Word64
-> m (Either GetForkerError (Forker m l))
forkerAtFromTip :: ResourceRegistry m
-> Word64 -> m (Either GetForkerError (Forker m l))
forkerAtFromTip
    , ResourceRegistry m
resourceReg :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> ResourceRegistry m
resourceReg :: ResourceRegistry m
resourceReg
    , TraceValidateEvent blk -> m ()
trace :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> TraceValidateEvent blk -> m ()
trace :: TraceValidateEvent blk -> m ()
trace
    , BlockCache blk
blockCache :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> BlockCache blk
blockCache :: BlockCache blk
blockCache
    , Word64
numRollbacks :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> Word64
numRollbacks :: Word64
numRollbacks
    , NonEmpty (Header blk)
hdrs :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
ValidateArgs m l blk -> NonEmpty (Header blk)
hdrs :: NonEmpty (Header blk)
hdrs
    } = ValidateArgs m l blk
args

  rewrap ::
    Either (AnnLedgerError l blk) (Either GetForkerError (Forker n l)) ->
    ValidateResult n l blk
  rewrap :: forall (n :: * -> *).
Either (AnnLedgerError l blk) (Either GetForkerError (Forker n l))
-> ValidateResult n l blk
rewrap (Left AnnLedgerError l blk
e) = AnnLedgerError l blk -> ValidateResult n l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
AnnLedgerError l blk -> ValidateResult m l blk
ValidateLedgerError AnnLedgerError l blk
e
  rewrap (Right (Left (PointTooOld (Just ExceededRollback
e)))) = ExceededRollback -> ValidateResult n l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ExceededRollback -> ValidateResult m l blk
ValidateExceededRollBack ExceededRollback
e
  rewrap (Right (Left GetForkerError
_)) = String -> ValidateResult n l blk
forall a. HasCallStack => String -> a
error String
"Unreachable, validating will always rollback from the tip"
  rewrap (Right (Right Forker n l
l)) = Forker n l -> ValidateResult n l blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l -> ValidateResult m l blk
ValidateSuccessful Forker n l
l

  mkAps ::
    Set (RealPoint blk) ->
    NonEmpty (Ap m l blk)
  mkAps :: Set (RealPoint blk) -> NonEmpty (Ap m l blk)
mkAps Set (RealPoint blk)
prev =
    (Header blk -> Ap m l blk)
-> NonEmpty (Header blk) -> NonEmpty (Ap m l blk)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map
      ( \Header blk
hdr -> case ( RealPoint blk -> Set (RealPoint blk) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Header blk -> RealPoint blk
forall blk. HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint Header blk
hdr) Set (RealPoint blk)
prev
                     , HeaderHash blk -> BlockCache blk -> Maybe blk
forall blk.
HasHeader blk =>
HeaderHash blk -> BlockCache blk -> Maybe blk
BlockCache.lookup (Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr) BlockCache blk
blockCache
                     ) of
          (Bool
False, Maybe blk
Nothing) -> RealPoint blk -> Ap m l blk
forall blk (m :: * -> *) (l :: LedgerStateKind).
RealPoint blk -> Ap m l blk
ApplyRef (Header blk -> RealPoint blk
forall blk. HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint Header blk
hdr)
          (Bool
True, Maybe blk
Nothing) -> RealPoint blk -> Ap m l blk
forall blk (m :: * -> *) (l :: LedgerStateKind).
RealPoint blk -> Ap m l blk
ReapplyRef (Header blk -> RealPoint blk
forall blk. HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint Header blk
hdr)
          (Bool
False, Just blk
blk) -> blk -> Ap m l blk
forall blk (m :: * -> *) (l :: LedgerStateKind). blk -> Ap m l blk
ApplyVal blk
blk
          (Bool
True, Just blk
blk) -> blk -> Ap m l blk
forall blk (m :: * -> *) (l :: LedgerStateKind). blk -> Ap m l blk
ReapplyVal blk
blk
      )
      NonEmpty (Header blk)
hdrs

  -- \| Based on the 'ValidateResult', return the hashes corresponding to
  -- valid blocks.
  validBlockPoints :: ValidateResult m l blk -> [RealPoint blk] -> [RealPoint blk]
  validBlockPoints :: ValidateResult m l blk -> [RealPoint blk] -> [RealPoint blk]
validBlockPoints = \case
    ValidateExceededRollBack ExceededRollback
_ -> [RealPoint blk] -> [RealPoint blk] -> [RealPoint blk]
forall a b. a -> b -> a
const []
    ValidateSuccessful Forker m l
_ -> [RealPoint blk] -> [RealPoint blk]
forall a. a -> a
id
    ValidateLedgerError AnnLedgerError l blk
e -> (RealPoint blk -> Bool) -> [RealPoint blk] -> [RealPoint blk]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (RealPoint blk -> RealPoint blk -> Bool
forall a. Eq a => a -> a -> Bool
/= AnnLedgerError l blk -> RealPoint blk
forall (l :: LedgerStateKind) blk.
AnnLedgerError l blk -> RealPoint blk
annLedgerErrRef AnnLedgerError l blk
e)

-- | Switch to a fork by rolling back a number of blocks and then pushing the
-- new blocks.
switch ::
  (ApplyBlock l blk, MonadSTM m) =>
  (ResourceRegistry m -> Word64 -> m (Either GetForkerError (Forker m l))) ->
  ResourceRegistry m ->
  ComputeLedgerEvents ->
  LedgerCfg l ->
  -- | How many blocks to roll back
  Word64 ->
  (TraceValidateEvent blk -> m ()) ->
  -- | New blocks to apply
  NonEmpty (Ap m l blk) ->
  ResolveBlock m blk ->
  m (Either (AnnLedgerError l blk) (Either GetForkerError (Forker m l)))
switch :: forall (l :: LedgerStateKind) blk (m :: * -> *).
(ApplyBlock l blk, MonadSTM m) =>
(ResourceRegistry m
 -> Word64 -> m (Either GetForkerError (Forker m l)))
-> ResourceRegistry m
-> ComputeLedgerEvents
-> LedgerCfg l
-> Word64
-> (TraceValidateEvent blk -> m ())
-> NonEmpty (Ap m l blk)
-> ResolveBlock m blk
-> m (Either
        (AnnLedgerError l blk) (Either GetForkerError (Forker m l)))
switch ResourceRegistry m
-> Word64 -> m (Either GetForkerError (Forker m l))
forkerAtFromTip ResourceRegistry m
rr ComputeLedgerEvents
evs LedgerCfg l
cfg Word64
numRollbacks TraceValidateEvent blk -> m ()
trace NonEmpty (Ap m l blk)
newBlocks ResolveBlock m blk
doResolve = do
  foEith <- ResourceRegistry m
-> Word64 -> m (Either GetForkerError (Forker m l))
forkerAtFromTip ResourceRegistry m
rr Word64
numRollbacks
  case foEith of
    Left GetForkerError
rbExceeded -> Either (AnnLedgerError l blk) (Either GetForkerError (Forker m l))
-> m (Either
        (AnnLedgerError l blk) (Either GetForkerError (Forker m l)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (AnnLedgerError l blk) (Either GetForkerError (Forker m l))
 -> m (Either
         (AnnLedgerError l blk) (Either GetForkerError (Forker m l))))
-> Either
     (AnnLedgerError l blk) (Either GetForkerError (Forker m l))
-> m (Either
        (AnnLedgerError l blk) (Either GetForkerError (Forker m l)))
forall a b. (a -> b) -> a -> b
$ Either GetForkerError (Forker m l)
-> Either
     (AnnLedgerError l blk) (Either GetForkerError (Forker m l))
forall a b. b -> Either a b
Right (Either GetForkerError (Forker m l)
 -> Either
      (AnnLedgerError l blk) (Either GetForkerError (Forker m l)))
-> Either GetForkerError (Forker m l)
-> Either
     (AnnLedgerError l blk) (Either GetForkerError (Forker m l))
forall a b. (a -> b) -> a -> b
$ GetForkerError -> Either GetForkerError (Forker m l)
forall a b. a -> Either a b
Left GetForkerError
rbExceeded
    Right Forker m l
fo -> do
      let start :: PushStart blk
start = RealPoint blk -> PushStart blk
forall blk. RealPoint blk -> PushStart blk
PushStart (RealPoint blk -> PushStart blk)
-> (NonEmpty (Ap m l blk) -> RealPoint blk)
-> NonEmpty (Ap m l blk)
-> PushStart blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ap m l blk -> RealPoint blk
forall blk (m :: * -> *) (l :: LedgerStateKind).
HasHeader blk =>
Ap m l blk -> RealPoint blk
toRealPoint (Ap m l blk -> RealPoint blk)
-> (NonEmpty (Ap m l blk) -> Ap m l blk)
-> NonEmpty (Ap m l blk)
-> RealPoint blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Ap m l blk) -> Ap m l blk
forall a. NonEmpty a -> a
NE.head (NonEmpty (Ap m l blk) -> PushStart blk)
-> NonEmpty (Ap m l blk) -> PushStart blk
forall a b. (a -> b) -> a -> b
$ NonEmpty (Ap m l blk)
newBlocks
          goal :: PushGoal blk
goal = RealPoint blk -> PushGoal blk
forall blk. RealPoint blk -> PushGoal blk
PushGoal (RealPoint blk -> PushGoal blk)
-> (NonEmpty (Ap m l blk) -> RealPoint blk)
-> NonEmpty (Ap m l blk)
-> PushGoal blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ap m l blk -> RealPoint blk
forall blk (m :: * -> *) (l :: LedgerStateKind).
HasHeader blk =>
Ap m l blk -> RealPoint blk
toRealPoint (Ap m l blk -> RealPoint blk)
-> (NonEmpty (Ap m l blk) -> Ap m l blk)
-> NonEmpty (Ap m l blk)
-> RealPoint blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Ap m l blk) -> Ap m l blk
forall a. NonEmpty a -> a
NE.last (NonEmpty (Ap m l blk) -> PushGoal blk)
-> NonEmpty (Ap m l blk) -> PushGoal blk
forall a b. (a -> b) -> a -> b
$ NonEmpty (Ap m l blk)
newBlocks
      ePush <-
        (Pushing blk -> m ())
-> ComputeLedgerEvents
-> LedgerCfg l
-> [Ap m l blk]
-> Forker m l
-> ResolveBlock m blk
-> m (Either (AnnLedgerError l blk) ())
forall (l :: LedgerStateKind) blk (m :: * -> *).
(ApplyBlock l blk, MonadSTM m) =>
(Pushing blk -> m ())
-> ComputeLedgerEvents
-> LedgerCfg l
-> [Ap m l blk]
-> Forker m l
-> ResolveBlock m blk
-> m (Either (AnnLedgerError l blk) ())
applyThenPushMany
          (TraceValidateEvent blk -> m ()
trace (TraceValidateEvent blk -> m ())
-> (Pushing blk -> TraceValidateEvent blk) -> Pushing blk -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PushStart blk
-> PushGoal blk -> Pushing blk -> TraceValidateEvent blk
forall blk.
PushStart blk
-> PushGoal blk -> Pushing blk -> TraceValidateEvent blk
StartedPushingBlockToTheLedgerDb PushStart blk
start PushGoal blk
goal)
          ComputeLedgerEvents
evs
          LedgerCfg l
cfg
          (NonEmpty (Ap m l blk) -> [Ap m l blk]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Ap m l blk)
newBlocks)
          Forker m l
fo
          ResolveBlock m blk
doResolve
      case ePush of
        Left AnnLedgerError l blk
err -> Forker m l -> m ()
forall (m :: * -> *) (l :: LedgerStateKind). Forker m l -> m ()
forkerClose Forker m l
fo m ()
-> m (Either
        (AnnLedgerError l blk) (Either GetForkerError (Forker m l)))
-> m (Either
        (AnnLedgerError l blk) (Either GetForkerError (Forker m l)))
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either (AnnLedgerError l blk) (Either GetForkerError (Forker m l))
-> m (Either
        (AnnLedgerError l blk) (Either GetForkerError (Forker m l)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnLedgerError l blk
-> Either
     (AnnLedgerError l blk) (Either GetForkerError (Forker m l))
forall a b. a -> Either a b
Left AnnLedgerError l blk
err)
        Right () -> Either (AnnLedgerError l blk) (Either GetForkerError (Forker m l))
-> m (Either
        (AnnLedgerError l blk) (Either GetForkerError (Forker m l)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (AnnLedgerError l blk) (Either GetForkerError (Forker m l))
 -> m (Either
         (AnnLedgerError l blk) (Either GetForkerError (Forker m l))))
-> Either
     (AnnLedgerError l blk) (Either GetForkerError (Forker m l))
-> m (Either
        (AnnLedgerError l blk) (Either GetForkerError (Forker m l)))
forall a b. (a -> b) -> a -> b
$ Either GetForkerError (Forker m l)
-> Either
     (AnnLedgerError l blk) (Either GetForkerError (Forker m l))
forall a b. b -> Either a b
Right (Either GetForkerError (Forker m l)
 -> Either
      (AnnLedgerError l blk) (Either GetForkerError (Forker m l)))
-> Either GetForkerError (Forker m l)
-> Either
     (AnnLedgerError l blk) (Either GetForkerError (Forker m l))
forall a b. (a -> b) -> a -> b
$ Forker m l -> Either GetForkerError (Forker m l)
forall a b. b -> Either a b
Right Forker m l
fo

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

-- | 'Ap' is used to pass information about blocks to ledger DB updates
--
-- The constructors provide answers to two questions:
--
--     1. Are we passing the block by value or by reference?
--
--     2. Are we applying or reapplying the block?
type Ap :: (Type -> Type) -> LedgerStateKind -> Type -> Type
data Ap m l blk where
  ReapplyVal :: blk -> Ap m l blk
  ApplyVal :: blk -> Ap m l blk
  ReapplyRef :: RealPoint blk -> Ap m l blk
  ApplyRef :: RealPoint blk -> Ap m l blk

toRealPoint :: HasHeader blk => Ap m l blk -> RealPoint blk
toRealPoint :: forall blk (m :: * -> *) (l :: LedgerStateKind).
HasHeader blk =>
Ap m l blk -> 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

-- | Apply blocks to the given forker
applyBlock ::
  forall m l blk.
  (ApplyBlock l blk, MonadSTM m) =>
  ComputeLedgerEvents ->
  LedgerCfg l ->
  Ap m l blk ->
  Forker m l ->
  ResolveBlock m blk ->
  m (Either (AnnLedgerError l blk) (l DiffMK))
applyBlock :: forall (m :: * -> *) (l :: LedgerStateKind) blk.
(ApplyBlock l blk, MonadSTM m) =>
ComputeLedgerEvents
-> LedgerCfg l
-> Ap m l blk
-> Forker m l
-> ResolveBlock m blk
-> m (Either (AnnLedgerError l blk) (l DiffMK))
applyBlock ComputeLedgerEvents
evs LedgerCfg l
cfg Ap m l blk
ap Forker m l
fo ResolveBlock m blk
doResolveBlock = case Ap m l blk
ap of
  ReapplyVal blk
b ->
    blk
-> (l ValuesMK -> m (Either (AnnLedgerError l blk) (l DiffMK)))
-> m (Either (AnnLedgerError l blk) (l DiffMK))
withValues blk
b (Either (AnnLedgerError l blk) (l DiffMK)
-> m (Either (AnnLedgerError l blk) (l DiffMK))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (AnnLedgerError l blk) (l DiffMK)
 -> m (Either (AnnLedgerError l blk) (l DiffMK)))
-> (l ValuesMK -> Either (AnnLedgerError l blk) (l DiffMK))
-> l ValuesMK
-> m (Either (AnnLedgerError l blk) (l DiffMK))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l DiffMK -> Either (AnnLedgerError l blk) (l DiffMK)
forall a b. b -> Either a b
Right (l DiffMK -> Either (AnnLedgerError l blk) (l DiffMK))
-> (l ValuesMK -> l DiffMK)
-> l ValuesMK
-> Either (AnnLedgerError l blk) (l DiffMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComputeLedgerEvents -> LedgerCfg l -> blk -> l ValuesMK -> l DiffMK
forall (l :: LedgerStateKind) blk.
ApplyBlock l blk =>
ComputeLedgerEvents -> LedgerCfg l -> blk -> l ValuesMK -> l DiffMK
tickThenReapply ComputeLedgerEvents
evs LedgerCfg l
cfg blk
b)
  ApplyVal blk
b ->
    blk
-> (l ValuesMK -> m (Either (AnnLedgerError l blk) (l DiffMK)))
-> m (Either (AnnLedgerError l blk) (l DiffMK))
withValues
      blk
b
      ( \l ValuesMK
v ->
          case Except (LedgerErr l) (l DiffMK) -> Either (LedgerErr l) (l DiffMK)
forall e a. Except e a -> Either e a
runExcept (Except (LedgerErr l) (l DiffMK)
 -> Either (LedgerErr l) (l DiffMK))
-> Except (LedgerErr l) (l DiffMK)
-> Either (LedgerErr l) (l DiffMK)
forall a b. (a -> b) -> a -> b
$ ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> l ValuesMK
-> Except (LedgerErr l) (l DiffMK)
forall (l :: LedgerStateKind) blk.
ApplyBlock l blk =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> l ValuesMK
-> Except (LedgerErr l) (l DiffMK)
tickThenApply ComputeLedgerEvents
evs LedgerCfg l
cfg blk
b l ValuesMK
v of
            Left LedgerErr l
lerr -> Either (AnnLedgerError l blk) (l DiffMK)
-> m (Either (AnnLedgerError l blk) (l DiffMK))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnLedgerError l blk -> Either (AnnLedgerError l blk) (l DiffMK)
forall a b. a -> Either a b
Left (Point blk -> RealPoint blk -> LedgerErr l -> AnnLedgerError l blk
forall (l :: LedgerStateKind) blk.
Point blk -> RealPoint blk -> LedgerErr l -> AnnLedgerError l blk
AnnLedgerError (Point l -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point l -> Point blk) -> Point l -> Point blk
forall a b. (a -> b) -> a -> b
$ l ValuesMK -> Point l
forall (mk :: MapKind). l mk -> Point l
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip l ValuesMK
v) (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
b) LedgerErr l
lerr))
            Right l DiffMK
st -> Either (AnnLedgerError l blk) (l DiffMK)
-> m (Either (AnnLedgerError l blk) (l DiffMK))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (l DiffMK -> Either (AnnLedgerError l blk) (l DiffMK)
forall a b. b -> Either a b
Right l DiffMK
st)
      )
  ReapplyRef RealPoint blk
r -> do
    b <- ResolveBlock m blk
doResolveBlock RealPoint blk
r
    applyBlock evs cfg (ReapplyVal b) fo doResolveBlock
  ApplyRef RealPoint blk
r -> do
    b <- ResolveBlock m blk
doResolveBlock RealPoint blk
r
    applyBlock evs cfg (ApplyVal b) fo doResolveBlock
 where
  withValues ::
    blk ->
    (l ValuesMK -> m (Either (AnnLedgerError l blk) (l DiffMK))) ->
    m (Either (AnnLedgerError l blk) (l DiffMK))
  withValues :: blk
-> (l ValuesMK -> m (Either (AnnLedgerError l blk) (l DiffMK)))
-> m (Either (AnnLedgerError l blk) (l DiffMK))
withValues blk
blk l ValuesMK -> m (Either (AnnLedgerError l blk) (l DiffMK))
f = do
    l <- STM m (l EmptyMK) -> m (l EmptyMK)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (l EmptyMK) -> m (l EmptyMK))
-> STM m (l EmptyMK) -> m (l EmptyMK)
forall a b. (a -> b) -> a -> b
$ Forker m l -> STM m (l EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l -> STM m (l EmptyMK)
forkerGetLedgerState Forker m l
fo
    vs <- withLedgerTables l <$> forkerReadTables fo (getBlockKeySets blk)
    f vs

-- | If applying a block on top of the ledger state at the tip is succesful,
-- push the resulting ledger state to the forker.
applyThenPush ::
  (ApplyBlock l blk, MonadSTM m) =>
  ComputeLedgerEvents ->
  LedgerCfg l ->
  Ap m l blk ->
  Forker m l ->
  ResolveBlock m blk ->
  m (Either (AnnLedgerError l blk) ())
applyThenPush :: forall (l :: LedgerStateKind) blk (m :: * -> *).
(ApplyBlock l blk, MonadSTM m) =>
ComputeLedgerEvents
-> LedgerCfg l
-> Ap m l blk
-> Forker m l
-> ResolveBlock m blk
-> m (Either (AnnLedgerError l blk) ())
applyThenPush ComputeLedgerEvents
evs LedgerCfg l
cfg Ap m l blk
ap Forker m l
fo ResolveBlock m blk
doResolve = do
  eLerr <- ComputeLedgerEvents
-> LedgerCfg l
-> Ap m l blk
-> Forker m l
-> ResolveBlock m blk
-> m (Either (AnnLedgerError l blk) (l DiffMK))
forall (m :: * -> *) (l :: LedgerStateKind) blk.
(ApplyBlock l blk, MonadSTM m) =>
ComputeLedgerEvents
-> LedgerCfg l
-> Ap m l blk
-> Forker m l
-> ResolveBlock m blk
-> m (Either (AnnLedgerError l blk) (l DiffMK))
applyBlock ComputeLedgerEvents
evs LedgerCfg l
cfg Ap m l blk
ap Forker m l
fo ResolveBlock m blk
doResolve
  case eLerr of
    Left AnnLedgerError l blk
err -> Either (AnnLedgerError l blk) ()
-> m (Either (AnnLedgerError l blk) ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnLedgerError l blk -> Either (AnnLedgerError l blk) ()
forall a b. a -> Either a b
Left AnnLedgerError l blk
err)
    Right l DiffMK
st -> () -> Either (AnnLedgerError l blk) ()
forall a b. b -> Either a b
Right (() -> Either (AnnLedgerError l blk) ())
-> m () -> m (Either (AnnLedgerError l blk) ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Forker m l -> l DiffMK -> m ()
forall (m :: * -> *) (l :: LedgerStateKind).
Forker m l -> l DiffMK -> m ()
forkerPush Forker m l
fo l DiffMK
st

-- | Apply and push a sequence of blocks (oldest first).
applyThenPushMany ::
  (ApplyBlock l blk, MonadSTM m) =>
  (Pushing blk -> m ()) ->
  ComputeLedgerEvents ->
  LedgerCfg l ->
  [Ap m l blk] ->
  Forker m l ->
  ResolveBlock m blk ->
  m (Either (AnnLedgerError l blk) ())
applyThenPushMany :: forall (l :: LedgerStateKind) blk (m :: * -> *).
(ApplyBlock l blk, MonadSTM m) =>
(Pushing blk -> m ())
-> ComputeLedgerEvents
-> LedgerCfg l
-> [Ap m l blk]
-> Forker m l
-> ResolveBlock m blk
-> m (Either (AnnLedgerError l blk) ())
applyThenPushMany Pushing blk -> m ()
trace ComputeLedgerEvents
evs LedgerCfg l
cfg [Ap m l blk]
aps Forker m l
fo ResolveBlock m blk
doResolveBlock = [Ap m l blk] -> m (Either (AnnLedgerError l blk) ())
pushAndTrace [Ap m l blk]
aps
 where
  pushAndTrace :: [Ap m l blk] -> m (Either (AnnLedgerError l blk) ())
pushAndTrace [] = Either (AnnLedgerError l blk) ()
-> m (Either (AnnLedgerError l blk) ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (AnnLedgerError l blk) ()
 -> m (Either (AnnLedgerError l blk) ()))
-> Either (AnnLedgerError l blk) ()
-> m (Either (AnnLedgerError l blk) ())
forall a b. (a -> b) -> a -> b
$ () -> Either (AnnLedgerError l blk) ()
forall a b. b -> Either a b
Right ()
  pushAndTrace (Ap m l blk
ap : [Ap m l blk]
aps') = do
    Pushing blk -> m ()
trace (Pushing blk -> m ()) -> Pushing blk -> m ()
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> Pushing blk
forall blk. RealPoint blk -> Pushing blk
Pushing (RealPoint blk -> Pushing blk)
-> (Ap m l blk -> RealPoint blk) -> Ap m l blk -> Pushing blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ap m l blk -> RealPoint blk
forall blk (m :: * -> *) (l :: LedgerStateKind).
HasHeader blk =>
Ap m l blk -> RealPoint blk
toRealPoint (Ap m l blk -> Pushing blk) -> Ap m l blk -> Pushing blk
forall a b. (a -> b) -> a -> b
$ Ap m l blk
ap
    res <- ComputeLedgerEvents
-> LedgerCfg l
-> Ap m l blk
-> Forker m l
-> ResolveBlock m blk
-> m (Either (AnnLedgerError l blk) ())
forall (l :: LedgerStateKind) blk (m :: * -> *).
(ApplyBlock l blk, MonadSTM m) =>
ComputeLedgerEvents
-> LedgerCfg l
-> Ap m l blk
-> Forker m l
-> ResolveBlock m blk
-> m (Either (AnnLedgerError l blk) ())
applyThenPush ComputeLedgerEvents
evs LedgerCfg l
cfg Ap m l blk
ap Forker m l
fo ResolveBlock m blk
doResolveBlock
    case res of
      Left AnnLedgerError l blk
err -> Either (AnnLedgerError l blk) ()
-> m (Either (AnnLedgerError l blk) ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnLedgerError l blk -> Either (AnnLedgerError l blk) ()
forall a b. a -> Either a b
Left AnnLedgerError l blk
err)
      Right () -> [Ap m l blk] -> m (Either (AnnLedgerError l blk) ())
pushAndTrace [Ap m l blk]
aps'

{-------------------------------------------------------------------------------
  Finding blocks
-------------------------------------------------------------------------------}

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

{-------------------------------------------------------------------------------
  Validation
-------------------------------------------------------------------------------}

-- | When validating a sequence of blocks, these are the possible outcomes.
data ValidateResult m l blk
  = ValidateSuccessful (Forker m l)
  | ValidateLedgerError (AnnLedgerError l blk)
  | ValidateExceededRollBack ExceededRollback

{-------------------------------------------------------------------------------
  An annotated ledger error
-------------------------------------------------------------------------------}

-- | Annotated ledger errors
data AnnLedgerError l blk = AnnLedgerError
  { forall (l :: LedgerStateKind) blk.
AnnLedgerError l blk -> Point blk
annLedgerBaseRef :: Point blk
  -- ^ The last block that was valid
  , forall (l :: LedgerStateKind) blk.
AnnLedgerError l blk -> RealPoint blk
annLedgerErrRef :: RealPoint blk
  -- ^ Reference to the block that had the error
  , forall (l :: LedgerStateKind) blk.
AnnLedgerError l blk -> LedgerErr l
annLedgerErr :: LedgerErr l
  -- ^ The ledger error itself
  }

type AnnLedgerError' blk = AnnLedgerError (ExtLedgerState blk) blk

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

{-------------------------------------------------------------------------------
  Forker events
-------------------------------------------------------------------------------}

data TraceForkerEventWithKey
  = TraceForkerEventWithKey ForkerKey TraceForkerEvent
  deriving (Int -> TraceForkerEventWithKey -> ShowS
[TraceForkerEventWithKey] -> ShowS
TraceForkerEventWithKey -> String
(Int -> TraceForkerEventWithKey -> ShowS)
-> (TraceForkerEventWithKey -> String)
-> ([TraceForkerEventWithKey] -> ShowS)
-> Show TraceForkerEventWithKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TraceForkerEventWithKey -> ShowS
showsPrec :: Int -> TraceForkerEventWithKey -> ShowS
$cshow :: TraceForkerEventWithKey -> String
show :: TraceForkerEventWithKey -> String
$cshowList :: [TraceForkerEventWithKey] -> ShowS
showList :: [TraceForkerEventWithKey] -> ShowS
Show, TraceForkerEventWithKey -> TraceForkerEventWithKey -> Bool
(TraceForkerEventWithKey -> TraceForkerEventWithKey -> Bool)
-> (TraceForkerEventWithKey -> TraceForkerEventWithKey -> Bool)
-> Eq TraceForkerEventWithKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TraceForkerEventWithKey -> TraceForkerEventWithKey -> Bool
== :: TraceForkerEventWithKey -> TraceForkerEventWithKey -> Bool
$c/= :: TraceForkerEventWithKey -> TraceForkerEventWithKey -> Bool
/= :: TraceForkerEventWithKey -> TraceForkerEventWithKey -> Bool
Eq)

data TraceForkerEvent
  = ForkerOpen
  | ForkerReadTables EnclosingTimed
  | ForkerRangeReadTables EnclosingTimed
  | ForkerReadStatistics
  | ForkerPush EnclosingTimed
  | ForkerClose ForkerWasCommitted
  deriving (Int -> TraceForkerEvent -> ShowS
[TraceForkerEvent] -> ShowS
TraceForkerEvent -> String
(Int -> TraceForkerEvent -> ShowS)
-> (TraceForkerEvent -> String)
-> ([TraceForkerEvent] -> ShowS)
-> Show TraceForkerEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TraceForkerEvent -> ShowS
showsPrec :: Int -> TraceForkerEvent -> ShowS
$cshow :: TraceForkerEvent -> String
show :: TraceForkerEvent -> String
$cshowList :: [TraceForkerEvent] -> ShowS
showList :: [TraceForkerEvent] -> ShowS
Show, TraceForkerEvent -> TraceForkerEvent -> Bool
(TraceForkerEvent -> TraceForkerEvent -> Bool)
-> (TraceForkerEvent -> TraceForkerEvent -> Bool)
-> Eq TraceForkerEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TraceForkerEvent -> TraceForkerEvent -> Bool
== :: TraceForkerEvent -> TraceForkerEvent -> Bool
$c/= :: TraceForkerEvent -> TraceForkerEvent -> Bool
/= :: TraceForkerEvent -> TraceForkerEvent -> Bool
Eq)

data ForkerWasCommitted
  = ForkerWasCommitted
  | ForkerWasUncommitted
  deriving (ForkerWasCommitted -> ForkerWasCommitted -> Bool
(ForkerWasCommitted -> ForkerWasCommitted -> Bool)
-> (ForkerWasCommitted -> ForkerWasCommitted -> Bool)
-> Eq ForkerWasCommitted
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ForkerWasCommitted -> ForkerWasCommitted -> Bool
== :: ForkerWasCommitted -> ForkerWasCommitted -> Bool
$c/= :: ForkerWasCommitted -> ForkerWasCommitted -> Bool
/= :: ForkerWasCommitted -> ForkerWasCommitted -> Bool
Eq, Int -> ForkerWasCommitted -> ShowS
[ForkerWasCommitted] -> ShowS
ForkerWasCommitted -> String
(Int -> ForkerWasCommitted -> ShowS)
-> (ForkerWasCommitted -> String)
-> ([ForkerWasCommitted] -> ShowS)
-> Show ForkerWasCommitted
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ForkerWasCommitted -> ShowS
showsPrec :: Int -> ForkerWasCommitted -> ShowS
$cshow :: ForkerWasCommitted -> String
show :: ForkerWasCommitted -> String
$cshowList :: [ForkerWasCommitted] -> ShowS
showList :: [ForkerWasCommitted] -> ShowS
Show)