{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# 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

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

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

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

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

import Control.Monad (void)
import Control.Monad.Base
import Control.Monad.Except
  ( ExceptT (..)
  , MonadError (..)
  , runExcept
  , runExceptT
  )
import Control.Monad.Reader (ReaderT (..))
import Control.Monad.Trans (MonadTrans (..))
import Control.ResourceRegistry
import Data.Kind
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.Config
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.SupportsProtocol
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.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 -> Type
data Forker m l blk = Forker
  { forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> 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) blk.
Forker m l blk
-> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
forkerReadTables :: !(LedgerTables l KeysMK -> m (LedgerTables l ValuesMK))
  -- ^ Read ledger tables from disk.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk
-> RangeQueryPrevious l -> m (LedgerTables l ValuesMK)
forkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK))
  -- ^ Range-read ledger tables from disk.
  --
  -- This range read will return as many values as the 'QueryBatchSize' that
  -- was passed when opening the LedgerDB.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> 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) blk.
Forker m l blk -> m (Maybe Statistics)
forkerReadStatistics :: !(m (Maybe 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) blk.
Forker m l blk -> 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) blk.
Forker m l blk -> STM m ()
forkerCommit :: !(STM m ())
  -- ^ Commit the fork, which was constructed using 'forkerPush', as the
  -- current version of the LedgerDB.
  }

-- | 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 blk) = HeaderHash l

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

instance
  (GetTip l, HeaderHash l ~ HeaderHash blk, MonadSTM m) =>
  GetTipSTM m (Forker m l blk)
  where
  getTipSTM :: Forker m l blk -> STM m (Point (Forker m l blk))
getTipSTM Forker m l blk
forker = Point l -> Point (Forker m l blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point l -> Point (Forker m l blk))
-> (l EmptyMK -> Point l) -> l EmptyMK -> Point (Forker m l 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 (Forker m l blk))
-> STM m (l EmptyMK) -> STM m (Point (Forker m l blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Forker m l blk -> STM m (l EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> STM m (l EmptyMK)
forkerGetLedgerState Forker m l blk
forker

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

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)) =>
  Forker m l blk ->
  STM m (Point blk)
forkerCurrentPoint :: forall (l :: LedgerStateKind) blk (m :: * -> *).
(GetTip l, HeaderHash l ~ HeaderHash blk, Functor (STM m)) =>
Forker m l blk -> STM m (Point blk)
forkerCurrentPoint Forker m l blk
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 blk -> STM m (l EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> STM m (l EmptyMK)
forkerGetLedgerState Forker m l blk
forker

{-------------------------------------------------------------------------------
  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 -> Type
data ReadOnlyForker m l blk = ReadOnlyForker
  { forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> m ()
roforkerClose :: !(m ())
  -- ^ See 'forkerClose'
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk
-> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
roforkerReadTables :: !(LedgerTables l KeysMK -> m (LedgerTables l ValuesMK))
  -- ^ See 'forkerReadTables'
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk
-> RangeQueryPrevious l -> m (LedgerTables l ValuesMK)
roforkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK))
  -- ^ See 'forkerRangeReadTables'.
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> STM m (l EmptyMK)
roforkerGetLedgerState :: !(STM m (l EmptyMK))
  -- ^ See 'forkerGetLedgerState'
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> m (Maybe Statistics)
roforkerReadStatistics :: !(m (Maybe Statistics))
  -- ^ See 'forkerReadStatistics'
  }

type instance HeaderHash (ReadOnlyForker m l blk) = HeaderHash l

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

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

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

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

validate ::
  forall m blk.
  ( IOLike m
  , LedgerSupportsProtocol blk
  , HasCallStack
  ) =>
  ComputeLedgerEvents ->
  ValidateArgs m blk ->
  m (ValidateResult' m blk)
validate :: forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, HasCallStack) =>
ComputeLedgerEvents
-> ValidateArgs m blk -> m (ValidateResult' m blk)
validate ComputeLedgerEvents
evs ValidateArgs m blk
args = do
  aps <- Set (RealPoint blk)
-> [Ap
      m
      (ExceptT
         (AnnLedgerError m (ExtLedgerState blk) blk)
         (ReaderT (ResolveBlock m blk) m))
      (ExtLedgerState blk)
      blk
      (ResolvesBlocks
         (ExceptT
            (AnnLedgerError m (ExtLedgerState blk) blk)
            (ReaderT (ResolveBlock m blk) m))
         blk,
       ThrowsLedgerError
         m
         (ExceptT
            (AnnLedgerError m (ExtLedgerState blk) blk)
            (ReaderT (ResolveBlock m blk) m))
         (ExtLedgerState blk)
         blk)]
forall (bn :: * -> *) (n :: * -> *) (l :: LedgerStateKind).
(l ~ ExtLedgerState blk) =>
Set (RealPoint blk)
-> [Ap
      bn n l blk (ResolvesBlocks n blk, ThrowsLedgerError bn n l blk)]
mkAps (Set (RealPoint blk)
 -> [Ap
       m
       (ExceptT
          (AnnLedgerError m (ExtLedgerState blk) blk)
          (ReaderT (ResolveBlock m blk) m))
       (ExtLedgerState blk)
       blk
       (ResolvesBlocks
          (ExceptT
             (AnnLedgerError m (ExtLedgerState blk) blk)
             (ReaderT (ResolveBlock m blk) m))
          blk,
        ThrowsLedgerError
          m
          (ExceptT
             (AnnLedgerError m (ExtLedgerState blk) blk)
             (ReaderT (ResolveBlock m blk) m))
          (ExtLedgerState blk)
          blk)])
-> m (Set (RealPoint blk))
-> m [Ap
        m
        (ExceptT
           (AnnLedgerError m (ExtLedgerState blk) blk)
           (ReaderT (ResolveBlock m blk) m))
        (ExtLedgerState blk)
        blk
        (ResolvesBlocks
           (ExceptT
              (AnnLedgerError m (ExtLedgerState blk) blk)
              (ReaderT (ResolveBlock m blk) m))
           blk,
         ThrowsLedgerError
           m
           (ExceptT
              (AnnLedgerError m (ExtLedgerState blk) blk)
              (ReaderT (ResolveBlock m blk) m))
           (ExtLedgerState blk)
           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 $
      defaultResolveWithErrors resolve $
        switch
          forkerAtFromTip
          resourceReg
          evs
          (ExtLedgerCfg validateConfig)
          numRollbacks
          (lift . lift . trace)
          aps
  liftBase $ atomically $ addPrevApplied (validBlockPoints res (map headerRealPoint hdrs))
  return res
 where
  ValidateArgs
    { ResolveBlock m blk
resolve :: forall (m :: * -> *) blk. ValidateArgs m blk -> ResolveBlock m blk
resolve :: ResolveBlock m blk
resolve
    , TopLevelConfig blk
validateConfig :: forall (m :: * -> *) blk. ValidateArgs m blk -> TopLevelConfig blk
validateConfig :: TopLevelConfig blk
validateConfig
    , [RealPoint blk] -> STM m ()
addPrevApplied :: forall (m :: * -> *) blk.
ValidateArgs m blk -> [RealPoint blk] -> STM m ()
addPrevApplied :: [RealPoint blk] -> STM m ()
addPrevApplied
    , STM m (Set (RealPoint blk))
prevApplied :: forall (m :: * -> *) blk.
ValidateArgs m blk -> STM m (Set (RealPoint blk))
prevApplied :: STM m (Set (RealPoint blk))
prevApplied
    , ResourceRegistry m
-> Word64 -> m (Either GetForkerError (Forker' m blk))
forkerAtFromTip :: forall (m :: * -> *) blk.
ValidateArgs m blk
-> ResourceRegistry m
-> Word64
-> m (Either GetForkerError (Forker' m blk))
forkerAtFromTip :: ResourceRegistry m
-> Word64 -> m (Either GetForkerError (Forker' m blk))
forkerAtFromTip
    , ResourceRegistry m
resourceReg :: forall (m :: * -> *) blk. ValidateArgs m blk -> ResourceRegistry m
resourceReg :: ResourceRegistry m
resourceReg
    , TraceValidateEvent blk -> m ()
trace :: forall (m :: * -> *) blk.
ValidateArgs m blk -> TraceValidateEvent blk -> m ()
trace :: TraceValidateEvent blk -> m ()
trace
    , BlockCache blk
blockCache :: forall (m :: * -> *) blk. ValidateArgs m blk -> BlockCache blk
blockCache :: BlockCache blk
blockCache
    , Word64
numRollbacks :: forall (m :: * -> *) blk. ValidateArgs m blk -> Word64
numRollbacks :: Word64
numRollbacks
    , [Header blk]
hdrs :: forall (m :: * -> *) blk. ValidateArgs m blk -> [Header blk]
hdrs :: [Header blk]
hdrs
    } = ValidateArgs m blk
args

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

  mkAps ::
    forall bn n l.
    l ~ ExtLedgerState blk =>
    Set (RealPoint blk) ->
    [ Ap
        bn
        n
        l
        blk
        ( ResolvesBlocks n blk
        , ThrowsLedgerError bn n l blk
        )
    ]
  mkAps :: forall (bn :: * -> *) (n :: * -> *) (l :: LedgerStateKind).
(l ~ ExtLedgerState blk) =>
Set (RealPoint blk)
-> [Ap
      bn n l blk (ResolvesBlocks n blk, ThrowsLedgerError bn n l blk)]
mkAps Set (RealPoint blk)
prev =
    [ 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
     bn n l blk (ResolvesBlocks n blk, ThrowsLedgerError bn n l blk)
forall blk (bm :: * -> *) (m :: * -> *) (l :: LedgerStateKind).
RealPoint blk
-> Ap
     bm m l blk (ResolvesBlocks m blk, ThrowsLedgerError bm 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) -> Ap bn n l blk (ResolvesBlocks n blk)
-> Ap
     bn n l blk (ResolvesBlocks n blk, ThrowsLedgerError bn n l blk)
forall (c' :: Constraint) (c :: Constraint) (bm :: * -> *)
       (m :: * -> *) (l :: LedgerStateKind) blk.
(c' => c) =>
Ap bm m l blk c -> Ap bm m l blk c'
Weaken (Ap bn n l blk (ResolvesBlocks n blk)
 -> Ap
      bn n l blk (ResolvesBlocks n blk, ThrowsLedgerError bn n l blk))
-> Ap bn n l blk (ResolvesBlocks n blk)
-> Ap
     bn n l blk (ResolvesBlocks n blk, ThrowsLedgerError bn n l blk)
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> Ap bn n l blk (ResolvesBlocks n blk)
forall blk (bm :: * -> *) (m :: * -> *) (l :: LedgerStateKind).
RealPoint blk -> Ap bm m l blk (ResolvesBlocks m blk)
ReapplyRef (Header blk -> RealPoint blk
forall blk. HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint Header blk
hdr)
        (Bool
False, Just blk
blk) -> Ap bn n l blk (ThrowsLedgerError bn n l blk)
-> Ap
     bn n l blk (ResolvesBlocks n blk, ThrowsLedgerError bn n l blk)
forall (c' :: Constraint) (c :: Constraint) (bm :: * -> *)
       (m :: * -> *) (l :: LedgerStateKind) blk.
(c' => c) =>
Ap bm m l blk c -> Ap bm m l blk c'
Weaken (Ap bn n l blk (ThrowsLedgerError bn n l blk)
 -> Ap
      bn n l blk (ResolvesBlocks n blk, ThrowsLedgerError bn n l blk))
-> Ap bn n l blk (ThrowsLedgerError bn n l blk)
-> Ap
     bn n l blk (ResolvesBlocks n blk, ThrowsLedgerError bn n l blk)
forall a b. (a -> b) -> a -> b
$ blk -> Ap bn n l blk (ThrowsLedgerError bn n l blk)
forall blk (bm :: * -> *) (m :: * -> *) (l :: LedgerStateKind).
blk -> Ap bm m l blk (ThrowsLedgerError bm m l blk)
ApplyVal blk
blk
        (Bool
True, Just blk
blk) -> Ap bn n l blk (() :: Constraint)
-> Ap
     bn n l blk (ResolvesBlocks n blk, ThrowsLedgerError bn n l blk)
forall (c' :: Constraint) (c :: Constraint) (bm :: * -> *)
       (m :: * -> *) (l :: LedgerStateKind) blk.
(c' => c) =>
Ap bm m l blk c -> Ap bm m l blk c'
Weaken (Ap bn n l blk (() :: Constraint)
 -> Ap
      bn n l blk (ResolvesBlocks n blk, ThrowsLedgerError bn n l blk))
-> Ap bn n l blk (() :: Constraint)
-> Ap
     bn n l blk (ResolvesBlocks n blk, ThrowsLedgerError bn n l blk)
forall a b. (a -> b) -> a -> b
$ blk -> Ap bn n l blk (() :: Constraint)
forall blk (bm :: * -> *) (m :: * -> *) (l :: LedgerStateKind).
blk -> Ap bm m l blk (() :: Constraint)
ReapplyVal blk
blk
    | Header blk
hdr <- [Header blk]
hdrs
    ]

  -- \| Based on the 'ValidateResult', return the hashes corresponding to
  -- valid blocks.
  validBlockPoints :: forall n. ValidateResult' n blk -> [RealPoint blk] -> [RealPoint blk]
  validBlockPoints :: forall (n :: * -> *).
ValidateResult' n blk -> [RealPoint blk] -> [RealPoint blk]
validBlockPoints = \case
    ValidateExceededRollBack ExceededRollback
_ -> [RealPoint blk] -> [RealPoint blk] -> [RealPoint blk]
forall a b. a -> b -> a
const []
    ValidateSuccessful Forker n (ExtLedgerState blk) blk
_ -> [RealPoint blk] -> [RealPoint blk]
forall a. a -> a
id
    ValidateLedgerError AnnLedgerError n (ExtLedgerState blk) 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 n (ExtLedgerState blk) blk -> RealPoint blk
forall (m :: * -> *) (l :: LedgerStateKind) blk.
AnnLedgerError m l blk -> RealPoint blk
annLedgerErrRef AnnLedgerError n (ExtLedgerState blk) blk
e)

-- | Switch to a fork by rolling back a number of blocks and then pushing the
-- new blocks.
switch ::
  (ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) =>
  (ResourceRegistry bm -> Word64 -> bm (Either GetForkerError (Forker bm l blk))) ->
  ResourceRegistry bm ->
  ComputeLedgerEvents ->
  LedgerCfg l ->
  -- | How many blocks to roll back
  Word64 ->
  (TraceValidateEvent blk -> m ()) ->
  -- | New blocks to apply
  [Ap bm m l blk c] ->
  m (Either GetForkerError (Forker bm l blk))
switch :: forall (l :: LedgerStateKind) blk (bm :: * -> *) (m :: * -> *)
       (c :: Constraint).
(ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) =>
(ResourceRegistry bm
 -> Word64 -> bm (Either GetForkerError (Forker bm l blk)))
-> ResourceRegistry bm
-> ComputeLedgerEvents
-> LedgerCfg l
-> Word64
-> (TraceValidateEvent blk -> m ())
-> [Ap bm m l blk c]
-> m (Either GetForkerError (Forker bm l blk))
switch ResourceRegistry bm
-> Word64 -> bm (Either GetForkerError (Forker bm l blk))
forkerAtFromTip ResourceRegistry bm
rr ComputeLedgerEvents
evs LedgerCfg l
cfg Word64
numRollbacks TraceValidateEvent blk -> m ()
trace [Ap bm m l blk c]
newBlocks = do
  foEith <- bm (Either GetForkerError (Forker bm l blk))
-> m (Either GetForkerError (Forker bm l blk))
forall α. bm α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (bm (Either GetForkerError (Forker bm l blk))
 -> m (Either GetForkerError (Forker bm l blk)))
-> bm (Either GetForkerError (Forker bm l blk))
-> m (Either GetForkerError (Forker bm l blk))
forall a b. (a -> b) -> a -> b
$ ResourceRegistry bm
-> Word64 -> bm (Either GetForkerError (Forker bm l blk))
forkerAtFromTip ResourceRegistry bm
rr Word64
numRollbacks
  case foEith of
    Left GetForkerError
rbExceeded -> Either GetForkerError (Forker bm l blk)
-> m (Either GetForkerError (Forker bm l blk))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either GetForkerError (Forker bm l blk)
 -> m (Either GetForkerError (Forker bm l blk)))
-> Either GetForkerError (Forker bm l blk)
-> m (Either GetForkerError (Forker bm l blk))
forall a b. (a -> b) -> a -> b
$ GetForkerError -> Either GetForkerError (Forker bm l blk)
forall a b. a -> Either a b
Left GetForkerError
rbExceeded
    Right Forker bm l blk
fo -> do
      case [Ap bm m l blk c]
newBlocks of
        [] -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        -- no blocks to apply to ledger state, return the forker
        (Ap bm m l blk c
firstBlock : [Ap bm 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 bm m l blk c -> RealPoint blk)
-> Ap bm m l blk c
-> PushStart blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ap bm m l blk c -> RealPoint blk
forall blk (bm :: * -> *) (m :: * -> *) (l :: LedgerStateKind)
       (c :: Constraint).
HasHeader blk =>
Ap bm m l blk c -> RealPoint blk
toRealPoint (Ap bm m l blk c -> PushStart blk)
-> Ap bm m l blk c -> PushStart blk
forall a b. (a -> b) -> a -> b
$ Ap bm 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 bm m l blk c] -> RealPoint blk)
-> [Ap bm m l blk c]
-> PushGoal blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ap bm m l blk c -> RealPoint blk
forall blk (bm :: * -> *) (m :: * -> *) (l :: LedgerStateKind)
       (c :: Constraint).
HasHeader blk =>
Ap bm m l blk c -> RealPoint blk
toRealPoint (Ap bm m l blk c -> RealPoint blk)
-> ([Ap bm m l blk c] -> Ap bm m l blk c)
-> [Ap bm m l blk c]
-> RealPoint blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ap bm m l blk c] -> Ap bm m l blk c
forall a. HasCallStack => [a] -> a
last ([Ap bm m l blk c] -> PushGoal blk)
-> [Ap bm m l blk c] -> PushGoal blk
forall a b. (a -> b) -> a -> b
$ [Ap bm m l blk c]
newBlocks
          m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            (Pushing blk -> m ())
-> ComputeLedgerEvents
-> LedgerCfg l
-> [Ap bm m l blk c]
-> Forker bm l blk
-> m ()
forall (l :: LedgerStateKind) blk (bm :: * -> *) (m :: * -> *)
       (c :: Constraint).
(ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) =>
(Pushing blk -> m ())
-> ComputeLedgerEvents
-> LedgerCfg l
-> [Ap bm m l blk c]
-> Forker bm l blk
-> m ()
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
              [Ap bm m l blk c]
newBlocks
              Forker bm l blk
fo
      Either GetForkerError (Forker bm l blk)
-> m (Either GetForkerError (Forker bm l blk))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either GetForkerError (Forker bm l blk)
 -> m (Either GetForkerError (Forker bm l blk)))
-> Either GetForkerError (Forker bm l blk)
-> m (Either GetForkerError (Forker bm l blk))
forall a b. (a -> b) -> a -> b
$ Forker bm l blk -> Either GetForkerError (Forker bm l blk)
forall a b. b -> Either a b
Right Forker bm l blk
fo

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

newtype ValidLedgerState l = ValidLedgerState {forall l. ValidLedgerState l -> l
getValidLedgerState :: l}

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

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

-- | Apply blocks to the given forker
applyBlock ::
  forall m bm c l blk.
  (ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) =>
  ComputeLedgerEvents ->
  LedgerCfg l ->
  Ap bm m l blk c ->
  Forker bm l blk ->
  m (ValidLedgerState (l DiffMK))
applyBlock :: forall (m :: * -> *) (bm :: * -> *) (c :: Constraint)
       (l :: LedgerStateKind) blk.
(ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) =>
ComputeLedgerEvents
-> LedgerCfg l
-> Ap bm m l blk c
-> Forker bm l blk
-> m (ValidLedgerState (l DiffMK))
applyBlock ComputeLedgerEvents
evs LedgerCfg l
cfg Ap bm m l blk c
ap Forker bm l blk
fo = case Ap bm m l blk c
ap of
  ReapplyVal blk
b ->
    l DiffMK -> ValidLedgerState (l DiffMK)
forall l. l -> ValidLedgerState l
ValidLedgerState
      (l DiffMK -> ValidLedgerState (l DiffMK))
-> m (l DiffMK) -> m (ValidLedgerState (l DiffMK))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> blk -> (l ValuesMK -> m (l DiffMK)) -> m (l DiffMK)
withValues blk
b (l DiffMK -> m (l DiffMK)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (l DiffMK -> m (l DiffMK))
-> (l ValuesMK -> l DiffMK) -> l ValuesMK -> m (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 ->
    l DiffMK -> ValidLedgerState (l DiffMK)
forall l. l -> ValidLedgerState l
ValidLedgerState
      (l DiffMK -> ValidLedgerState (l DiffMK))
-> m (l DiffMK) -> m (ValidLedgerState (l DiffMK))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> blk -> (l ValuesMK -> m (l DiffMK)) -> m (l DiffMK)
withValues
        blk
b
        ( (LedgerErr l -> m (l DiffMK))
-> (l DiffMK -> m (l DiffMK))
-> Either (LedgerErr l) (l DiffMK)
-> m (l DiffMK)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Forker bm l blk -> RealPoint blk -> LedgerErr l -> m (l DiffMK)
forall a. Forker bm l blk -> RealPoint blk -> LedgerErr l -> m a
forall (bm :: * -> *) (m :: * -> *) (l :: LedgerStateKind) blk a.
ThrowsLedgerError bm m l blk =>
Forker bm l blk -> RealPoint blk -> LedgerErr l -> m a
throwLedgerError Forker bm l blk
fo (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
b)) l DiffMK -> m (l DiffMK)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Either (LedgerErr l) (l DiffMK) -> m (l DiffMK))
-> (l ValuesMK -> Either (LedgerErr l) (l DiffMK))
-> l ValuesMK
-> m (l DiffMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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))
-> (l ValuesMK -> Except (LedgerErr l) (l DiffMK))
-> l ValuesMK
-> Either (LedgerErr l) (l DiffMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
        )
  ReapplyRef RealPoint blk
r -> do
    b <- ResolveBlock m blk
forall (m :: * -> *) blk.
ResolvesBlocks m blk =>
ResolveBlock m blk
doResolveBlock RealPoint blk
r
    applyBlock evs cfg (ReapplyVal b) fo
  ApplyRef RealPoint blk
r -> do
    b <- ResolveBlock m blk
forall (m :: * -> *) blk.
ResolvesBlocks m blk =>
ResolveBlock m blk
doResolveBlock RealPoint blk
r
    applyBlock evs cfg (ApplyVal b) fo
  Weaken Ap bm m l blk c
ap' ->
    ComputeLedgerEvents
-> LedgerCfg l
-> Ap bm m l blk c
-> Forker bm l blk
-> m (ValidLedgerState (l DiffMK))
forall (m :: * -> *) (bm :: * -> *) (c :: Constraint)
       (l :: LedgerStateKind) blk.
(ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) =>
ComputeLedgerEvents
-> LedgerCfg l
-> Ap bm m l blk c
-> Forker bm l blk
-> m (ValidLedgerState (l DiffMK))
applyBlock ComputeLedgerEvents
evs LedgerCfg l
cfg Ap bm m l blk c
ap' Forker bm l blk
fo
 where
  withValues :: blk -> (l ValuesMK -> m (l DiffMK)) -> m (l DiffMK)
  withValues :: blk -> (l ValuesMK -> m (l DiffMK)) -> m (l DiffMK)
withValues blk
blk l ValuesMK -> m (l DiffMK)
f = do
    l <- bm (l EmptyMK) -> m (l EmptyMK)
forall α. bm α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (bm (l EmptyMK) -> m (l EmptyMK))
-> bm (l EmptyMK) -> m (l EmptyMK)
forall a b. (a -> b) -> a -> b
$ STM bm (l EmptyMK) -> bm (l EmptyMK)
forall a. HasCallStack => STM bm a -> bm a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM bm (l EmptyMK) -> bm (l EmptyMK))
-> STM bm (l EmptyMK) -> bm (l EmptyMK)
forall a b. (a -> b) -> a -> b
$ Forker bm l blk -> STM bm (l EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> STM m (l EmptyMK)
forkerGetLedgerState Forker bm l blk
fo
    vs <-
      withLedgerTables l
        <$> liftBase (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.
--
-- Note that we require @c@ (from the particular choice of @Ap m l blk c@) so
-- this sometimes can throw ledger errors.
applyThenPush ::
  (ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) =>
  ComputeLedgerEvents ->
  LedgerCfg l ->
  Ap bm m l blk c ->
  Forker bm l blk ->
  m ()
applyThenPush :: forall (l :: LedgerStateKind) blk (bm :: * -> *) (m :: * -> *)
       (c :: Constraint).
(ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) =>
ComputeLedgerEvents
-> LedgerCfg l -> Ap bm m l blk c -> Forker bm l blk -> m ()
applyThenPush ComputeLedgerEvents
evs LedgerCfg l
cfg Ap bm m l blk c
ap Forker bm l blk
fo =
  bm () -> m ()
forall α. bm α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (bm () -> m ())
-> (ValidLedgerState (l DiffMK) -> bm ())
-> ValidLedgerState (l DiffMK)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forker bm l blk -> l DiffMK -> bm ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
Forker m l blk -> l DiffMK -> m ()
forkerPush Forker bm l blk
fo (l DiffMK -> bm ())
-> (ValidLedgerState (l DiffMK) -> l DiffMK)
-> ValidLedgerState (l DiffMK)
-> bm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidLedgerState (l DiffMK) -> l DiffMK
forall l. ValidLedgerState l -> l
getValidLedgerState
    (ValidLedgerState (l DiffMK) -> m ())
-> m (ValidLedgerState (l DiffMK)) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ComputeLedgerEvents
-> LedgerCfg l
-> Ap bm m l blk c
-> Forker bm l blk
-> m (ValidLedgerState (l DiffMK))
forall (m :: * -> *) (bm :: * -> *) (c :: Constraint)
       (l :: LedgerStateKind) blk.
(ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) =>
ComputeLedgerEvents
-> LedgerCfg l
-> Ap bm m l blk c
-> Forker bm l blk
-> m (ValidLedgerState (l DiffMK))
applyBlock ComputeLedgerEvents
evs LedgerCfg l
cfg Ap bm m l blk c
ap Forker bm l blk
fo

-- | Apply and push a sequence of blocks (oldest first).
applyThenPushMany ::
  (ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) =>
  (Pushing blk -> m ()) ->
  ComputeLedgerEvents ->
  LedgerCfg l ->
  [Ap bm m l blk c] ->
  Forker bm l blk ->
  m ()
applyThenPushMany :: forall (l :: LedgerStateKind) blk (bm :: * -> *) (m :: * -> *)
       (c :: Constraint).
(ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) =>
(Pushing blk -> m ())
-> ComputeLedgerEvents
-> LedgerCfg l
-> [Ap bm m l blk c]
-> Forker bm l blk
-> m ()
applyThenPushMany Pushing blk -> m ()
trace ComputeLedgerEvents
evs LedgerCfg l
cfg [Ap bm m l blk c]
aps Forker bm l blk
fo = (Ap bm m l blk c -> m ()) -> [Ap bm m l blk c] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Ap bm m l blk c -> m ()
pushAndTrace [Ap bm m l blk c]
aps
 where
  pushAndTrace :: Ap bm m l blk c -> m ()
pushAndTrace Ap bm m l blk c
ap = 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 bm m l blk c -> RealPoint blk)
-> Ap bm m l blk c
-> Pushing blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ap bm m l blk c -> RealPoint blk
forall blk (bm :: * -> *) (m :: * -> *) (l :: LedgerStateKind)
       (c :: Constraint).
HasHeader blk =>
Ap bm m l blk c -> RealPoint blk
toRealPoint (Ap bm m l blk c -> Pushing blk) -> Ap bm m l blk c -> Pushing blk
forall a b. (a -> b) -> a -> b
$ Ap bm m l blk c
ap
    ComputeLedgerEvents
-> LedgerCfg l -> Ap bm m l blk c -> Forker bm l blk -> m ()
forall (l :: LedgerStateKind) blk (bm :: * -> *) (m :: * -> *)
       (c :: Constraint).
(ApplyBlock l blk, MonadBase bm m, c, MonadSTM bm) =>
ComputeLedgerEvents
-> LedgerCfg l -> Ap bm m l blk c -> Forker bm l blk -> m ()
applyThenPush ComputeLedgerEvents
evs LedgerCfg l
cfg Ap bm m l blk c
ap Forker bm l blk
fo

{-------------------------------------------------------------------------------
  Annotated ledger errors
-------------------------------------------------------------------------------}

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

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

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

defaultResolveWithErrors ::
  ResolveBlock m blk ->
  ExceptT
    (AnnLedgerError bm l blk)
    (ReaderT (ResolveBlock m blk) m)
    a ->
  m (Either (AnnLedgerError bm l blk) a)
defaultResolveWithErrors :: forall (m :: * -> *) blk (bm :: * -> *) (l :: LedgerStateKind) a.
ResolveBlock m blk
-> ExceptT
     (AnnLedgerError bm l blk) (ReaderT (ResolveBlock m blk) m) a
-> m (Either (AnnLedgerError bm l blk) a)
defaultResolveWithErrors ResolveBlock m blk
resolve =
  ResolveBlock m blk
-> ReaderT
     (ResolveBlock m blk) m (Either (AnnLedgerError bm l blk) a)
-> m (Either (AnnLedgerError bm 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 bm l blk) a)
 -> m (Either (AnnLedgerError bm l blk) a))
-> (ExceptT
      (AnnLedgerError bm l blk) (ReaderT (ResolveBlock m blk) m) a
    -> ReaderT
         (ResolveBlock m blk) m (Either (AnnLedgerError bm l blk) a))
-> ExceptT
     (AnnLedgerError bm l blk) (ReaderT (ResolveBlock m blk) m) a
-> m (Either (AnnLedgerError bm l blk) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT
  (AnnLedgerError bm l blk) (ReaderT (ResolveBlock m blk) m) a
-> ReaderT
     (ResolveBlock m blk) m (Either (AnnLedgerError bm l blk) a)
forall (bm :: * -> *) (l :: LedgerStateKind) blk (m :: * -> *) a.
ExceptT (AnnLedgerError bm l blk) m a
-> m (Either (AnnLedgerError bm l blk) a)
defaultThrowLedgerErrors

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

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

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

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

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

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

-- | Annotated ledger errors
data AnnLedgerError m l blk = AnnLedgerError
  { forall (m :: * -> *) (l :: LedgerStateKind) blk.
AnnLedgerError m l blk -> Forker m l blk
annLedgerState :: Forker m l blk
  -- ^ The ledger DB just /before/ this block was applied
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
AnnLedgerError m l blk -> RealPoint blk
annLedgerErrRef :: RealPoint blk
  -- ^ Reference to the block that had the error
  , forall (m :: * -> *) (l :: LedgerStateKind) blk.
AnnLedgerError m l blk -> LedgerErr l
annLedgerErr :: LedgerErr l
  -- ^ The ledger error itself
  }

type AnnLedgerError' m blk = AnnLedgerError m (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
  | ForkerCloseUncommitted
  | ForkerCloseCommitted
  | ForkerReadTablesStart
  | ForkerReadTablesEnd
  | ForkerRangeReadTablesStart
  | ForkerRangeReadTablesEnd
  | ForkerReadStatistics
  | ForkerPushStart
  | ForkerPushEnd
  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)