{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# 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
  , ledgerStateReadOnlyForker

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

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

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

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

import Control.Monad.Except
  ( runExcept
  )
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.Config (configLedger)
import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (hardForkSummary))
import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry
import Ouroboros.Consensus.HeaderValidation
  ( AnnTip (..)
  , HeaderState (..)
  , HeaderWithTime (..)
  , annTipHash
  )
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.SupportsProtocol
  ( LedgerSupportsProtocol
  , leiosLedgerViewAtTip
  )
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
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF

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

-- | An independent handle to a point in the LedgerDB, which can be advanced to
-- evaluate forks in the chain.
-- TODO @js split l in l blk
type Forker :: (Type -> Type) -> StateKind -> Type -> Type
data Forker m l blk = Forker
  { forall (m :: * -> *) (l :: StateKind) 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 :: StateKind) blk.
Forker m l blk
-> LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)
forkerReadTables :: !(LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK))
  -- ^ Read ledger tables from disk.
  , forall (m :: * -> *) (l :: StateKind) blk.
Forker m l blk
-> RangeQueryPrevious blk
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forkerRangeReadTables ::
      !(RangeQueryPrevious blk -> m (LedgerTables blk ValuesMK, Maybe (TxIn blk)))
  -- ^ 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 :: StateKind) blk.
Forker m l blk -> STM m (l blk EmptyMK)
forkerGetLedgerState :: !(STM m (l blk 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 :: StateKind) blk.
Forker m l blk -> 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 :: StateKind) blk.
Forker m l blk -> l blk DiffMK -> m ()
forkerPush :: !(l blk DiffMK -> m ())
  -- ^ Advance the fork handle by pushing a new ledger state to the tip of the
  -- current fork.
  , forall (m :: * -> *) (l :: StateKind) blk.
Forker m l blk -> STM m (m ())
forkerCommit :: !(STM m (m ()))
  -- ^ Commit the fork, which was constructed using 'forkerPush', as the
  -- current version of the LedgerDB.
  --
  -- Returns an IO action that has to be run on cleanup. It closes the orphaned
  -- resources from the LedgerDB.
  }
  deriving (forall x. Forker m l blk -> Rep (Forker m l blk) x)
-> (forall x. Rep (Forker m l blk) x -> Forker m l blk)
-> Generic (Forker m l blk)
forall x. Rep (Forker m l blk) x -> Forker m l blk
forall x. Forker m l blk -> Rep (Forker m l blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) (l :: StateKind) blk x.
Rep (Forker m l blk) x -> Forker m l blk
forall (m :: * -> *) (l :: StateKind) blk x.
Forker m l blk -> Rep (Forker m l blk) x
$cfrom :: forall (m :: * -> *) (l :: StateKind) blk x.
Forker m l blk -> Rep (Forker m l blk) x
from :: forall x. Forker m l blk -> Rep (Forker m l blk) x
$cto :: forall (m :: * -> *) (l :: StateKind) blk x.
Rep (Forker m l blk) x -> Forker m l blk
to :: forall x. Rep (Forker m l blk) x -> Forker m l blk
Generic
  deriving Context -> Forker m l blk -> IO (Maybe ThunkInfo)
Proxy (Forker m l blk) -> String
(Context -> Forker m l blk -> IO (Maybe ThunkInfo))
-> (Context -> Forker m l blk -> IO (Maybe ThunkInfo))
-> (Proxy (Forker m l blk) -> String)
-> NoThunks (Forker m l blk)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) (l :: StateKind) blk.
(Typeable l, Typeable m, Typeable blk) =>
Context -> Forker m l blk -> IO (Maybe ThunkInfo)
forall (m :: * -> *) (l :: StateKind) blk.
(Typeable l, Typeable m, Typeable blk) =>
Proxy (Forker m l blk) -> String
$cnoThunks :: forall (m :: * -> *) (l :: StateKind) blk.
(Typeable l, Typeable m, Typeable blk) =>
Context -> Forker m l blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> Forker m l blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) (l :: StateKind) blk.
(Typeable l, Typeable m, Typeable blk) =>
Context -> Forker m l blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Forker m l blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *) (l :: StateKind) blk.
(Typeable l, Typeable m, Typeable blk) =>
Proxy (Forker m l blk) -> String
showTypeOf :: Proxy (Forker m l blk) -> String
NoThunks via OnlyCheckWhnf (Forker m l blk)

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

type Forker' m blk = Forker m ExtLedgerState blk

instance
  (GetTip (l 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 blk) -> Point (Forker m l blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (l blk) -> Point (Forker m l blk))
-> (l blk EmptyMK -> Point (l blk))
-> l blk EmptyMK
-> Point (Forker m l blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l blk EmptyMK -> Point (l blk)
forall (mk :: MapKind). l blk mk -> Point (l blk)
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip (l blk EmptyMK -> Point (Forker m l blk))
-> STM m (l blk 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 blk EmptyMK)
forall (m :: * -> *) (l :: StateKind) blk.
Forker m l blk -> STM m (l blk EmptyMK)
forkerGetLedgerState Forker m l blk
forker

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

data RangeQuery l = RangeQuery
  { forall l. RangeQuery l -> RangeQueryPrevious l
rqPrev :: !(RangeQueryPrevious l)
  , forall l. 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 blk), HeaderHash (l blk) ~ HeaderHash blk, Functor (STM m)) =>
  Proxy blk ->
  Forker m l blk ->
  STM m (Point blk)
forkerCurrentPoint :: forall (l :: StateKind) blk (m :: * -> *).
(GetTip (l blk), HeaderHash (l blk) ~ HeaderHash blk,
 Functor (STM m)) =>
Proxy blk -> Forker m l blk -> STM m (Point blk)
forkerCurrentPoint Proxy blk
_ Forker m l blk
forker =
  Point (l blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint
    (Point (l blk) -> Point blk)
-> (l blk EmptyMK -> Point (l blk)) -> l blk EmptyMK -> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l blk EmptyMK -> Point (l blk)
forall (mk :: MapKind). l blk mk -> Point (l blk)
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip
    (l blk EmptyMK -> Point blk)
-> STM m (l blk EmptyMK) -> STM m (Point blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Forker m l blk -> STM m (l blk EmptyMK)
forall (m :: * -> *) (l :: StateKind) blk.
Forker m l blk -> STM m (l blk EmptyMK)
forkerGetLedgerState Forker m l blk
forker

ledgerStateReadOnlyForker ::
  IOLike m => ReadOnlyForker' m blk -> ReadOnlyForker m LedgerState blk
ledgerStateReadOnlyForker :: forall (m :: * -> *) blk.
IOLike m =>
ReadOnlyForker' m blk -> ReadOnlyForker m LedgerState blk
ledgerStateReadOnlyForker ReadOnlyForker' m blk
frk =
  ReadOnlyForker
    { roforkerClose :: m ()
roforkerClose = m ()
roforkerClose
    , roforkerReadTables :: LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)
roforkerReadTables = LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)
roforkerReadTables
    , roforkerRangeReadTables :: RangeQueryPrevious blk
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
roforkerRangeReadTables = RangeQueryPrevious blk
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
roforkerRangeReadTables
    , 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 :: StateKind) blk.
ReadOnlyForker m l blk -> m ()
roforkerClose :: m ()
roforkerClose
    , LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)
roforkerReadTables :: forall (m :: * -> *) (l :: StateKind) blk.
ReadOnlyForker m l blk
-> LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)
roforkerReadTables :: LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)
roforkerReadTables
    , RangeQueryPrevious blk
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
roforkerRangeReadTables :: forall (m :: * -> *) (l :: StateKind) blk.
ReadOnlyForker m l blk
-> RangeQueryPrevious blk
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
roforkerRangeReadTables :: RangeQueryPrevious blk
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
roforkerRangeReadTables
    , STM m (ExtLedgerState blk EmptyMK)
roforkerGetLedgerState :: forall (m :: * -> *) (l :: StateKind) blk.
ReadOnlyForker m l blk -> STM m (l blk EmptyMK)
roforkerGetLedgerState :: STM m (ExtLedgerState blk EmptyMK)
roforkerGetLedgerState
    , m Statistics
roforkerReadStatistics :: forall (m :: * -> *) (l :: StateKind) blk.
ReadOnlyForker m l blk -> m Statistics
roforkerReadStatistics :: m Statistics
roforkerReadStatistics
    } = ReadOnlyForker' m 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) -> StateKind -> Type -> Type
data ReadOnlyForker m l blk = ReadOnlyForker
  { forall (m :: * -> *) (l :: StateKind) blk.
ReadOnlyForker m l blk -> m ()
roforkerClose :: !(m ())
  -- ^ See 'forkerClose'
  , forall (m :: * -> *) (l :: StateKind) blk.
ReadOnlyForker m l blk
-> LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)
roforkerReadTables :: !(LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK))
  -- ^ See 'forkerReadTables'
  , forall (m :: * -> *) (l :: StateKind) blk.
ReadOnlyForker m l blk
-> RangeQueryPrevious blk
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
roforkerRangeReadTables ::
      !(RangeQueryPrevious blk -> m (LedgerTables blk ValuesMK, Maybe (TxIn blk)))
  -- ^ See 'forkerRangeReadTables'.
  , forall (m :: * -> *) (l :: StateKind) blk.
ReadOnlyForker m l blk -> STM m (l blk EmptyMK)
roforkerGetLedgerState :: !(STM m (l blk EmptyMK))
  -- ^ See 'forkerGetLedgerState'
  , forall (m :: * -> *) (l :: StateKind) blk.
ReadOnlyForker m l blk -> m Statistics
roforkerReadStatistics :: !(m Statistics)
  -- ^ See 'forkerReadStatistics'
  }
  deriving (forall x.
 ReadOnlyForker m l blk -> Rep (ReadOnlyForker m l blk) x)
-> (forall x.
    Rep (ReadOnlyForker m l blk) x -> ReadOnlyForker m l blk)
-> Generic (ReadOnlyForker m l blk)
forall x. Rep (ReadOnlyForker m l blk) x -> ReadOnlyForker m l blk
forall x. ReadOnlyForker m l blk -> Rep (ReadOnlyForker m l blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) (l :: StateKind) blk x.
Rep (ReadOnlyForker m l blk) x -> ReadOnlyForker m l blk
forall (m :: * -> *) (l :: StateKind) blk x.
ReadOnlyForker m l blk -> Rep (ReadOnlyForker m l blk) x
$cfrom :: forall (m :: * -> *) (l :: StateKind) blk x.
ReadOnlyForker m l blk -> Rep (ReadOnlyForker m l blk) x
from :: forall x. ReadOnlyForker m l blk -> Rep (ReadOnlyForker m l blk) x
$cto :: forall (m :: * -> *) (l :: StateKind) blk x.
Rep (ReadOnlyForker m l blk) x -> ReadOnlyForker m l blk
to :: forall x. Rep (ReadOnlyForker m l blk) x -> ReadOnlyForker m l blk
Generic

instance NoThunks (ReadOnlyForker m l blk) where
  wNoThunks :: Context -> ReadOnlyForker m l blk -> IO (Maybe ThunkInfo)
wNoThunks Context
_ ReadOnlyForker m l blk
_ = 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 blk) -> String
showTypeOf Proxy (ReadOnlyForker m l blk)
_ = String
"ReadOnlyForker"

type instance HeaderHash (ReadOnlyForker m l) = HeaderHash l

type ReadOnlyForker' m blk = ReadOnlyForker m ExtLedgerState blk

readOnlyForker :: Forker m l blk -> ReadOnlyForker m l blk
readOnlyForker :: forall (m :: * -> *) (l :: StateKind) 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 :: StateKind) blk. Forker m l blk -> m ()
forkerClose Forker m l blk
forker
    , roforkerReadTables :: LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)
roforkerReadTables = Forker m l blk
-> LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)
forall (m :: * -> *) (l :: StateKind) blk.
Forker m l blk
-> LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)
forkerReadTables Forker m l blk
forker
    , roforkerRangeReadTables :: RangeQueryPrevious blk
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
roforkerRangeReadTables = Forker m l blk
-> RangeQueryPrevious blk
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forall (m :: * -> *) (l :: StateKind) blk.
Forker m l blk
-> RangeQueryPrevious blk
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forkerRangeReadTables Forker m l blk
forker
    , roforkerGetLedgerState :: STM m (l blk EmptyMK)
roforkerGetLedgerState = Forker m l blk -> STM m (l blk EmptyMK)
forall (m :: * -> *) (l :: StateKind) blk.
Forker m l blk -> STM m (l blk EmptyMK)
forkerGetLedgerState Forker m l blk
forker
    , roforkerReadStatistics :: m Statistics
roforkerReadStatistics = Forker m l blk -> m Statistics
forall (m :: * -> *) (l :: StateKind) blk.
Forker m l blk -> m Statistics
forkerReadStatistics Forker m l blk
forker
    }

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

data ValidateArgs m l blk = ValidateArgs
  { forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk -> ResolveBlock m blk
resolve :: !(ResolveBlock m blk)
  -- ^ How to retrieve blocks from headers
  , forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk -> LedgerCfg l blk
validateConfig :: !(LedgerCfg l blk)
  -- ^ The config
  , forall (m :: * -> *) (l :: StateKind) 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 :: StateKind) 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 :: StateKind) blk.
ValidateArgs m l blk
-> forall r.
   Word64 -> (Forker m l blk -> m r) -> m (Either GetForkerError r)
withForkerAtFromTip ::
      !(forall r. Word64 -> (Forker m l blk -> m r) -> m (Either GetForkerError r))
  -- ^ Create a forker from the tip
  , forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk -> SuccessForkerAction m l blk
onSuccess :: !(SuccessForkerAction m l blk)
  -- ^ Continuation to run when the validation was successful
  , forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk -> TraceValidateEvent blk -> m ()
trace :: !(TraceValidateEvent blk -> m ())
  -- ^ A tracer for validate events
  , forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk -> BlockCache blk
blockCache :: BlockCache blk
  -- ^ The block cache
  , forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk -> Word64
numRollbacks :: Word64
  -- ^ How many blocks to roll back before applying the blocks
  , forall (m :: * -> *) (l :: StateKind) 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
  , l ~ ExtLedgerState
  , LedgerSupportsProtocol blk
  , HasHardForkHistory blk
  ) =>
  ComputeLedgerEvents ->
  ValidateArgs m l blk ->
  m (ValidateResult l blk)
validate :: forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, HasCallStack, ApplyBlock l blk, l ~ ExtLedgerState,
 LedgerSupportsProtocol blk, HasHardForkHistory blk) =>
ComputeLedgerEvents
-> ValidateArgs m l blk -> m (ValidateResult l blk)
validate ComputeLedgerEvents
evs ValidateArgs m l blk
args = do
  aps <- Set (RealPoint blk) -> NonEmpty (Header blk, Ap m l blk)
mkAps (Set (RealPoint blk) -> NonEmpty (Header blk, Ap m l blk))
-> m (Set (RealPoint blk)) -> m (NonEmpty (Header blk, 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 <-
    rewrap
      <$> switch
        withForkerAtFromTip
        evs
        validateConfig
        numRollbacks
        trace
        aps
        resolve
        onSuccess
  atomically $ addPrevApplied (validBlockPoints res (map headerRealPoint $ NE.toList hdrs))
  pure res
 where
  ValidateArgs
    { ResolveBlock m blk
resolve :: forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk -> ResolveBlock m blk
resolve :: ResolveBlock m blk
resolve
    , LedgerCfg l blk
validateConfig :: forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk -> LedgerCfg l blk
validateConfig :: LedgerCfg l blk
validateConfig
    , [RealPoint blk] -> STM m ()
addPrevApplied :: forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk -> [RealPoint blk] -> STM m ()
addPrevApplied :: [RealPoint blk] -> STM m ()
addPrevApplied
    , STM m (Set (RealPoint blk))
prevApplied :: forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk -> STM m (Set (RealPoint blk))
prevApplied :: STM m (Set (RealPoint blk))
prevApplied
    , forall r.
Word64 -> (Forker m l blk -> m r) -> m (Either GetForkerError r)
withForkerAtFromTip :: forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk
-> forall r.
   Word64 -> (Forker m l blk -> m r) -> m (Either GetForkerError r)
withForkerAtFromTip :: forall r.
Word64 -> (Forker m l blk -> m r) -> m (Either GetForkerError r)
withForkerAtFromTip
    , TraceValidateEvent blk -> m ()
trace :: forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk -> TraceValidateEvent blk -> m ()
trace :: TraceValidateEvent blk -> m ()
trace
    , BlockCache blk
blockCache :: forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk -> BlockCache blk
blockCache :: BlockCache blk
blockCache
    , Word64
numRollbacks :: forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk -> Word64
numRollbacks :: Word64
numRollbacks
    , NonEmpty (Header blk)
hdrs :: forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk -> NonEmpty (Header blk)
hdrs :: NonEmpty (Header blk)
hdrs
    , SuccessForkerAction m l blk
onSuccess :: forall (m :: * -> *) (l :: StateKind) blk.
ValidateArgs m l blk -> SuccessForkerAction m l blk
onSuccess :: SuccessForkerAction m l blk
onSuccess
    } = ValidateArgs m l blk
args

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

  mkAps ::
    Set (RealPoint blk) ->
    NonEmpty (Header blk, Ap m l blk)
  mkAps :: Set (RealPoint blk) -> NonEmpty (Header blk, Ap m l blk)
mkAps Set (RealPoint blk)
prev =
    (Header blk -> (Header blk, Ap m l blk))
-> NonEmpty (Header blk) -> NonEmpty (Header blk, Ap m l blk)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map
      ( \Header blk
hdr ->
          (,) Header blk
hdr (Ap m l blk -> (Header blk, Ap m l blk))
-> Ap m l blk -> (Header blk, Ap m l blk)
forall a b. (a -> b) -> a -> b
$ 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 :: StateKind).
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 :: StateKind).
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 :: StateKind). blk -> Ap m l blk
ApplyVal blk
blk
            (Bool
True, Just blk
blk) -> blk -> Ap m l blk
forall blk (m :: * -> *) (l :: StateKind). 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 l blk -> [RealPoint blk] -> [RealPoint blk]
  validBlockPoints :: ValidateResult l blk -> [RealPoint blk] -> [RealPoint blk]
validBlockPoints = \case
    ValidateExceededRollBack ExceededRollback
_ -> [RealPoint blk] -> [RealPoint blk] -> [RealPoint blk]
forall a b. a -> b -> a
const []
    ValidateSuccessful AnchoredFragment (HeaderWithTime blk)
_ -> [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 :: StateKind) 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
  , l ~ ExtLedgerState
  , LedgerSupportsProtocol blk
  , HasHardForkHistory blk
  ) =>
  (forall r. Word64 -> (Forker m l blk -> m r) -> m (Either GetForkerError r)) ->
  ComputeLedgerEvents ->
  LedgerCfg l blk ->
  -- | How many blocks to roll back
  Word64 ->
  (TraceValidateEvent blk -> m ()) ->
  -- | New blocks to apply, with their headers
  NonEmpty (Header blk, Ap m l blk) ->
  ResolveBlock m blk ->
  SuccessForkerAction m l blk ->
  m
    ( Either
        GetForkerError
        (Either (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk)))
    )
switch :: forall (l :: StateKind) blk (m :: * -> *).
(ApplyBlock l blk, MonadSTM m, l ~ ExtLedgerState,
 LedgerSupportsProtocol blk, HasHardForkHistory blk) =>
(forall r.
 Word64 -> (Forker m l blk -> m r) -> m (Either GetForkerError r))
-> ComputeLedgerEvents
-> LedgerCfg l blk
-> Word64
-> (TraceValidateEvent blk -> m ())
-> NonEmpty (Header blk, Ap m l blk)
-> ResolveBlock m blk
-> SuccessForkerAction m l blk
-> m (Either
        GetForkerError
        (Either
           (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk))))
switch forall r.
Word64 -> (Forker m l blk -> m r) -> m (Either GetForkerError r)
withForkerAtFromTip ComputeLedgerEvents
evs LedgerCfg l blk
cfg Word64
numRollbacks TraceValidateEvent blk -> m ()
trace NonEmpty (Header blk, Ap m l blk)
newBlocks ResolveBlock m blk
doResolve SuccessForkerAction m l blk
onSuccess = do
  Word64
-> (Forker m l blk
    -> m (Either
            (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk))))
-> m (Either
        GetForkerError
        (Either
           (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk))))
forall r.
Word64 -> (Forker m l blk -> m r) -> m (Either GetForkerError r)
withForkerAtFromTip Word64
numRollbacks ((Forker m l blk
  -> m (Either
          (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk))))
 -> m (Either
         GetForkerError
         (Either
            (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk)))))
-> (Forker m l blk
    -> m (Either
            (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk))))
-> m (Either
        GetForkerError
        (Either
           (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk))))
forall a b. (a -> b) -> a -> b
$ \Forker m l blk
fo -> do
    let start :: PushStart blk
start = RealPoint blk -> PushStart blk
forall blk. RealPoint blk -> PushStart blk
PushStart (RealPoint blk -> PushStart blk)
-> (NonEmpty (Header blk, Ap m l blk) -> RealPoint blk)
-> NonEmpty (Header blk, 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 :: StateKind).
HasHeader blk =>
Ap m l blk -> RealPoint blk
toRealPoint (Ap m l blk -> RealPoint blk)
-> (NonEmpty (Header blk, Ap m l blk) -> Ap m l blk)
-> NonEmpty (Header blk, Ap m l blk)
-> RealPoint blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header blk, Ap m l blk) -> Ap m l blk
forall a b. (a, b) -> b
snd ((Header blk, Ap m l blk) -> Ap m l blk)
-> (NonEmpty (Header blk, Ap m l blk) -> (Header blk, Ap m l blk))
-> NonEmpty (Header blk, Ap m l blk)
-> Ap m l blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Header blk, Ap m l blk) -> (Header blk, Ap m l blk)
forall a. NonEmpty a -> a
NE.head (NonEmpty (Header blk, Ap m l blk) -> PushStart blk)
-> NonEmpty (Header blk, Ap m l blk) -> PushStart blk
forall a b. (a -> b) -> a -> b
$ NonEmpty (Header blk, 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 (Header blk, Ap m l blk) -> RealPoint blk)
-> NonEmpty (Header blk, 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 :: StateKind).
HasHeader blk =>
Ap m l blk -> RealPoint blk
toRealPoint (Ap m l blk -> RealPoint blk)
-> (NonEmpty (Header blk, Ap m l blk) -> Ap m l blk)
-> NonEmpty (Header blk, Ap m l blk)
-> RealPoint blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header blk, Ap m l blk) -> Ap m l blk
forall a b. (a, b) -> b
snd ((Header blk, Ap m l blk) -> Ap m l blk)
-> (NonEmpty (Header blk, Ap m l blk) -> (Header blk, Ap m l blk))
-> NonEmpty (Header blk, Ap m l blk)
-> Ap m l blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Header blk, Ap m l blk) -> (Header blk, Ap m l blk)
forall a. NonEmpty a -> a
NE.last (NonEmpty (Header blk, Ap m l blk) -> PushGoal blk)
-> NonEmpty (Header blk, Ap m l blk) -> PushGoal blk
forall a b. (a -> b) -> a -> b
$ NonEmpty (Header blk, Ap m l blk)
newBlocks
    ePush <-
      (Pushing blk -> m ())
-> ComputeLedgerEvents
-> LedgerCfg l blk
-> [(Header blk, Ap m l blk)]
-> Forker m l blk
-> ResolveBlock m blk
-> m (Either
        (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk)))
forall (l :: StateKind) blk (m :: * -> *).
(ApplyBlock l blk, MonadSTM m, l ~ ExtLedgerState,
 LedgerSupportsProtocol blk, HasHardForkHistory blk) =>
(Pushing blk -> m ())
-> ComputeLedgerEvents
-> LedgerCfg l blk
-> [(Header blk, Ap m l blk)]
-> Forker m l blk
-> ResolveBlock m blk
-> m (Either
        (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime 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 blk
cfg
        (NonEmpty (Header blk, Ap m l blk) -> [(Header blk, Ap m l blk)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Header blk, Ap m l blk)
newBlocks)
        Forker m l blk
fo
        ResolveBlock m blk
doResolve
    case ePush of
      Left AnnLedgerError l blk
err -> Either
  (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk))
-> m (Either
        (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnLedgerError l blk
-> Either
     (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk))
forall a b. a -> Either a b
Left AnnLedgerError l blk
err)
      Right AnchoredFragment (HeaderWithTime blk)
validated -> do
        SuccessForkerAction m l blk
-> AnchoredFragment (HeaderWithTime blk) -> Forker m l blk -> m ()
forall (m :: * -> *) (l :: StateKind) blk.
SuccessForkerAction m l blk
-> AnchoredFragment (HeaderWithTime blk) -> Forker m l blk -> m ()
applySuccessForkerAction SuccessForkerAction m l blk
onSuccess AnchoredFragment (HeaderWithTime blk)
validated Forker m l blk
fo
        Either
  (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk))
-> m (Either
        (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnchoredFragment (HeaderWithTime blk)
-> Either
     (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk))
forall a b. b -> Either a b
Right AnchoredFragment (HeaderWithTime blk)
validated)

{-------------------------------------------------------------------------------
  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) -> StateKind -> 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 :: StateKind).
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 blk ->
  Ap m l blk ->
  Forker m l blk ->
  ResolveBlock m blk ->
  m (Either (AnnLedgerError l blk) (l blk DiffMK))
applyBlock :: forall (m :: * -> *) (l :: StateKind) blk.
(ApplyBlock l blk, MonadSTM m) =>
ComputeLedgerEvents
-> LedgerCfg l blk
-> Ap m l blk
-> Forker m l blk
-> ResolveBlock m blk
-> m (Either (AnnLedgerError l blk) (l blk DiffMK))
applyBlock ComputeLedgerEvents
evs LedgerCfg l blk
cfg Ap m l blk
ap Forker m l blk
fo ResolveBlock m blk
doResolveBlock = case Ap m l blk
ap of
  ReapplyVal blk
b ->
    blk
-> (l blk ValuesMK
    -> m (Either (AnnLedgerError l blk) (l blk DiffMK)))
-> m (Either (AnnLedgerError l blk) (l blk DiffMK))
withValues blk
b (Either (AnnLedgerError l blk) (l blk DiffMK)
-> m (Either (AnnLedgerError l blk) (l blk DiffMK))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (AnnLedgerError l blk) (l blk DiffMK)
 -> m (Either (AnnLedgerError l blk) (l blk DiffMK)))
-> (l blk ValuesMK -> Either (AnnLedgerError l blk) (l blk DiffMK))
-> l blk ValuesMK
-> m (Either (AnnLedgerError l blk) (l blk DiffMK))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l blk DiffMK -> Either (AnnLedgerError l blk) (l blk DiffMK)
forall a b. b -> Either a b
Right (l blk DiffMK -> Either (AnnLedgerError l blk) (l blk DiffMK))
-> (l blk ValuesMK -> l blk DiffMK)
-> l blk ValuesMK
-> Either (AnnLedgerError l blk) (l blk DiffMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComputeLedgerEvents
-> LedgerCfg l blk -> blk -> l blk ValuesMK -> l blk DiffMK
forall (l :: StateKind) blk.
ApplyBlock l blk =>
ComputeLedgerEvents
-> LedgerCfg l blk -> blk -> l blk ValuesMK -> l blk DiffMK
tickThenReapply ComputeLedgerEvents
evs LedgerCfg l blk
cfg blk
b)
  ApplyVal blk
b ->
    blk
-> (l blk ValuesMK
    -> m (Either (AnnLedgerError l blk) (l blk DiffMK)))
-> m (Either (AnnLedgerError l blk) (l blk DiffMK))
withValues
      blk
b
      ( \l blk ValuesMK
v ->
          case Except (LedgerErr l blk) (l blk DiffMK)
-> Either (LedgerErr l blk) (l blk DiffMK)
forall e a. Except e a -> Either e a
runExcept (Except (LedgerErr l blk) (l blk DiffMK)
 -> Either (LedgerErr l blk) (l blk DiffMK))
-> Except (LedgerErr l blk) (l blk DiffMK)
-> Either (LedgerErr l blk) (l blk DiffMK)
forall a b. (a -> b) -> a -> b
$ ComputeLedgerEvents
-> LedgerCfg l blk
-> blk
-> l blk ValuesMK
-> Except (LedgerErr l blk) (l blk DiffMK)
forall (l :: StateKind) blk.
ApplyBlock l blk =>
ComputeLedgerEvents
-> LedgerCfg l blk
-> blk
-> l blk ValuesMK
-> Except (LedgerErr l blk) (l blk DiffMK)
tickThenApply ComputeLedgerEvents
evs LedgerCfg l blk
cfg blk
b l blk ValuesMK
v of
            Left LedgerErr l blk
lerr -> Either (AnnLedgerError l blk) (l blk DiffMK)
-> m (Either (AnnLedgerError l blk) (l blk DiffMK))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnLedgerError l blk
-> Either (AnnLedgerError l blk) (l blk DiffMK)
forall a b. a -> Either a b
Left (Point blk
-> RealPoint blk -> LedgerErr l blk -> AnnLedgerError l blk
forall (l :: StateKind) blk.
Point blk
-> RealPoint blk -> LedgerErr l blk -> AnnLedgerError l blk
AnnLedgerError (Point (l blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (l blk) -> Point blk) -> Point (l blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ l blk ValuesMK -> Point (l blk)
forall (mk :: MapKind). l blk mk -> Point (l blk)
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip l blk ValuesMK
v) (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
b) LedgerErr l blk
lerr))
            Right l blk DiffMK
st -> Either (AnnLedgerError l blk) (l blk DiffMK)
-> m (Either (AnnLedgerError l blk) (l blk DiffMK))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (l blk DiffMK -> Either (AnnLedgerError l blk) (l blk DiffMK)
forall a b. b -> Either a b
Right l blk 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 blk ValuesMK -> m (Either (AnnLedgerError l blk) (l blk DiffMK))) ->
    m (Either (AnnLedgerError l blk) (l blk DiffMK))
  withValues :: blk
-> (l blk ValuesMK
    -> m (Either (AnnLedgerError l blk) (l blk DiffMK)))
-> m (Either (AnnLedgerError l blk) (l blk DiffMK))
withValues blk
blk l blk ValuesMK -> m (Either (AnnLedgerError l blk) (l blk DiffMK))
f = do
    l <- STM m (l blk EmptyMK) -> m (l blk EmptyMK)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (l blk EmptyMK) -> m (l blk EmptyMK))
-> STM m (l blk EmptyMK) -> m (l blk EmptyMK)
forall a b. (a -> b) -> a -> b
$ Forker m l blk -> STM m (l blk EmptyMK)
forall (m :: * -> *) (l :: StateKind) blk.
Forker m l blk -> STM m (l blk EmptyMK)
forkerGetLedgerState Forker m l blk
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, and return it.
applyThenPush ::
  (ApplyBlock l blk, MonadSTM m) =>
  ComputeLedgerEvents ->
  LedgerCfg l blk ->
  Ap m l blk ->
  Forker m l blk ->
  ResolveBlock m blk ->
  m (Either (AnnLedgerError l blk) (l blk DiffMK))
applyThenPush :: forall (l :: StateKind) blk (m :: * -> *).
(ApplyBlock l blk, MonadSTM m) =>
ComputeLedgerEvents
-> LedgerCfg l blk
-> Ap m l blk
-> Forker m l blk
-> ResolveBlock m blk
-> m (Either (AnnLedgerError l blk) (l blk DiffMK))
applyThenPush ComputeLedgerEvents
evs LedgerCfg l blk
cfg Ap m l blk
ap Forker m l blk
fo ResolveBlock m blk
doResolve = do
  eLerr <- ComputeLedgerEvents
-> LedgerCfg l blk
-> Ap m l blk
-> Forker m l blk
-> ResolveBlock m blk
-> m (Either (AnnLedgerError l blk) (l blk DiffMK))
forall (m :: * -> *) (l :: StateKind) blk.
(ApplyBlock l blk, MonadSTM m) =>
ComputeLedgerEvents
-> LedgerCfg l blk
-> Ap m l blk
-> Forker m l blk
-> ResolveBlock m blk
-> m (Either (AnnLedgerError l blk) (l blk DiffMK))
applyBlock ComputeLedgerEvents
evs LedgerCfg l blk
cfg Ap m l blk
ap Forker m l blk
fo ResolveBlock m blk
doResolve
  case eLerr of
    Left AnnLedgerError l blk
err -> Either (AnnLedgerError l blk) (l blk DiffMK)
-> m (Either (AnnLedgerError l blk) (l blk DiffMK))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnLedgerError l blk
-> Either (AnnLedgerError l blk) (l blk DiffMK)
forall a b. a -> Either a b
Left AnnLedgerError l blk
err)
    Right l blk DiffMK
st -> l blk DiffMK -> Either (AnnLedgerError l blk) (l blk DiffMK)
forall a b. b -> Either a b
Right l blk DiffMK
st Either (AnnLedgerError l blk) (l blk DiffMK)
-> m () -> m (Either (AnnLedgerError l blk) (l blk DiffMK))
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Forker m l blk -> l blk DiffMK -> m ()
forall (m :: * -> *) (l :: StateKind) blk.
Forker m l blk -> l blk DiffMK -> m ()
forkerPush Forker m l blk
fo l blk DiffMK
st

-- | Apply and push a sequence of blocks (oldest first), and return their
-- headers, anchored where the forker started.
applyThenPushMany ::
  ( ApplyBlock l blk
  , MonadSTM m
  , l ~ ExtLedgerState
  , LedgerSupportsProtocol blk
  , HasHardForkHistory blk
  ) =>
  (Pushing blk -> m ()) ->
  ComputeLedgerEvents ->
  LedgerCfg l blk ->
  [(Header blk, Ap m l blk)] ->
  Forker m l blk ->
  ResolveBlock m blk ->
  m (Either (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk)))
applyThenPushMany :: forall (l :: StateKind) blk (m :: * -> *).
(ApplyBlock l blk, MonadSTM m, l ~ ExtLedgerState,
 LedgerSupportsProtocol blk, HasHardForkHistory blk) =>
(Pushing blk -> m ())
-> ComputeLedgerEvents
-> LedgerCfg l blk
-> [(Header blk, Ap m l blk)]
-> Forker m l blk
-> ResolveBlock m blk
-> m (Either
        (AnnLedgerError l blk) (AnchoredFragment (HeaderWithTime blk)))
applyThenPushMany Pushing blk -> m ()
trace ComputeLedgerEvents
evs LedgerCfg l blk
cfg [(Header blk, Ap m l blk)]
aps Forker m l blk
fo ResolveBlock m blk
doResolveBlock = do
  start <- STM m (ExtLedgerState blk EmptyMK)
-> m (ExtLedgerState blk EmptyMK)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ExtLedgerState blk EmptyMK)
 -> m (ExtLedgerState blk EmptyMK))
-> STM m (ExtLedgerState blk EmptyMK)
-> m (ExtLedgerState blk EmptyMK)
forall a b. (a -> b) -> a -> b
$ Forker m l blk -> STM m (l blk EmptyMK)
forall (m :: * -> *) (l :: StateKind) blk.
Forker m l blk -> STM m (l blk EmptyMK)
forkerGetLedgerState Forker m l blk
fo
  pushAndTrace (AF.Empty (anchorOf start)) aps
 where
  lcfg :: LedgerConfig blk
lcfg = TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger (ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg LedgerCfg l blk
ExtLedgerCfg blk
cfg)

  anchorOf :: ExtLedgerState blk mk -> Anchor block
anchorOf ExtLedgerState blk mk
st = case HeaderState blk -> WithOrigin (AnnTip blk)
forall blk. HeaderState blk -> WithOrigin (AnnTip blk)
headerStateTip (ExtLedgerState blk mk -> HeaderState blk
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> HeaderState blk
headerState ExtLedgerState blk mk
st) of
    WithOrigin (AnnTip blk)
Origin -> Anchor block
forall block. Anchor block
AF.AnchorGenesis
    NotOrigin AnnTip blk
annTip ->
      SlotNo -> HeaderHash block -> BlockNo -> Anchor block
forall block. SlotNo -> HeaderHash block -> BlockNo -> Anchor block
AF.Anchor (AnnTip blk -> SlotNo
forall blk. AnnTip blk -> SlotNo
annTipSlotNo AnnTip blk
annTip) (AnnTip blk -> HeaderHash blk
forall blk. HasAnnTip blk => AnnTip blk -> HeaderHash blk
annTipHash AnnTip blk
annTip) (AnnTip blk -> BlockNo
forall blk. AnnTip blk -> BlockNo
annTipBlockNo AnnTip blk
annTip)

  pushAndTrace :: AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
-> [(Header blk, Ap m l blk)]
-> m (Either
        (AnnLedgerError l blk)
        (AnchoredSeq
           (WithOrigin SlotNo)
           (Anchor (HeaderWithTime blk))
           (HeaderWithTime blk)))
pushAndTrace AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
acc [] = Either
  (AnnLedgerError l blk)
  (AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk))
-> m (Either
        (AnnLedgerError l blk)
        (AnchoredSeq
           (WithOrigin SlotNo)
           (Anchor (HeaderWithTime blk))
           (HeaderWithTime blk)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (AnnLedgerError l blk)
   (AnchoredSeq
      (WithOrigin SlotNo)
      (Anchor (HeaderWithTime blk))
      (HeaderWithTime blk))
 -> m (Either
         (AnnLedgerError l blk)
         (AnchoredSeq
            (WithOrigin SlotNo)
            (Anchor (HeaderWithTime blk))
            (HeaderWithTime blk))))
-> Either
     (AnnLedgerError l blk)
     (AnchoredSeq
        (WithOrigin SlotNo)
        (Anchor (HeaderWithTime blk))
        (HeaderWithTime blk))
-> m (Either
        (AnnLedgerError l blk)
        (AnchoredSeq
           (WithOrigin SlotNo)
           (Anchor (HeaderWithTime blk))
           (HeaderWithTime blk)))
forall a b. (a -> b) -> a -> b
$ AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
-> Either
     (AnnLedgerError l blk)
     (AnchoredSeq
        (WithOrigin SlotNo)
        (Anchor (HeaderWithTime blk))
        (HeaderWithTime blk))
forall a b. b -> Either a b
Right AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
acc
  pushAndTrace AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
acc ((Header blk
hdr, Ap m l blk
ap) : [(Header blk, 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 :: StateKind).
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 blk
-> Ap m l blk
-> Forker m l blk
-> ResolveBlock m blk
-> m (Either (AnnLedgerError l blk) (l blk DiffMK))
forall (l :: StateKind) blk (m :: * -> *).
(ApplyBlock l blk, MonadSTM m) =>
ComputeLedgerEvents
-> LedgerCfg l blk
-> Ap m l blk
-> Forker m l blk
-> ResolveBlock m blk
-> m (Either (AnnLedgerError l blk) (l blk DiffMK))
applyThenPush ComputeLedgerEvents
evs LedgerCfg l blk
cfg Ap m l blk
ap Forker m l blk
fo ResolveBlock m blk
doResolveBlock
    case res of
      Left AnnLedgerError l blk
err -> Either
  (AnnLedgerError l blk)
  (AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk))
-> m (Either
        (AnnLedgerError l blk)
        (AnchoredSeq
           (WithOrigin SlotNo)
           (Anchor (HeaderWithTime blk))
           (HeaderWithTime blk)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnLedgerError l blk
-> Either
     (AnnLedgerError l blk)
     (AnchoredSeq
        (WithOrigin SlotNo)
        (Anchor (HeaderWithTime blk))
        (HeaderWithTime blk))
forall a b. a -> Either a b
Left AnnLedgerError l blk
err)
      Right l blk DiffMK
st -> do
        -- The state the block produced can translate the block's slot, which
        -- is that state's tip slot, and gives the ledger view at that slot; see
        -- 'hwtLeiosLedgerView'.
        let !hwt :: HeaderWithTime blk
hwt =
              HeaderWithTime
                { hwtHeader :: Header blk
hwtHeader = Header blk
hdr
                , hwtSlotRelativeTime :: RelativeTime
hwtSlotRelativeTime =
                    (RelativeTime, SlotLength) -> RelativeTime
forall a b. (a, b) -> a
fst ((RelativeTime, SlotLength) -> RelativeTime)
-> (RelativeTime, SlotLength) -> RelativeTime
forall a b. (a -> b) -> a -> b
$
                      Qry (RelativeTime, SlotLength)
-> Summary (HardForkIndices blk) -> (RelativeTime, SlotLength)
forall a (xs :: [*]). HasCallStack => Qry a -> Summary xs -> a
Qry.runQueryPure
                        (SlotNo -> Qry (RelativeTime, SlotLength)
Qry.slotToWallclock (Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr))
                        (LedgerConfig blk
-> LedgerState blk DiffMK -> Summary (HardForkIndices blk)
forall blk (mk :: MapKind).
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
forall (mk :: MapKind).
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
hardForkSummary LedgerConfig blk
lcfg (ExtLedgerState blk DiffMK -> LedgerState blk DiffMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState l blk DiffMK
ExtLedgerState blk DiffMK
st))
                , hwtPredecessorSlot :: WithOrigin SlotNo
hwtPredecessorSlot = AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
-> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
acc
                , hwtLeiosLedgerView :: StrictMaybe LeiosLedgerView
hwtLeiosLedgerView = LedgerConfig blk
-> LedgerState blk DiffMK -> StrictMaybe LeiosLedgerView
forall blk (mk :: MapKind).
LedgerSupportsProtocol blk =>
LedgerConfig blk
-> LedgerState blk mk -> StrictMaybe LeiosLedgerView
leiosLedgerViewAtTip LedgerConfig blk
lcfg (ExtLedgerState blk DiffMK -> LedgerState blk DiffMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState l blk DiffMK
ExtLedgerState blk DiffMK
st)
                }
        AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
-> [(Header blk, Ap m l blk)]
-> m (Either
        (AnnLedgerError l blk)
        (AnchoredSeq
           (WithOrigin SlotNo)
           (Anchor (HeaderWithTime blk))
           (HeaderWithTime blk)))
pushAndTrace (AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
acc AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
-> HeaderWithTime blk
-> AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk)
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
AF.:> HeaderWithTime blk
hwt) [(Header blk, 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
-------------------------------------------------------------------------------}

-- | A helpful type for a callback of the validation logic
--
-- The latest iteration of the maintenance of backend resources held
-- by 'Forker's relies heavily on 'bracket'. For that reason, we end
-- up passing a "success continuation" through several layers of
-- interface, which runs inside of those brackets.
--
-- This type makes that continuation easier to recognize. In
-- particular, any continuation that ends with @res -> m ()@ is
-- commonly used as "how to close a @res@", which is *NOT* the case
-- here. So it's preferable to use this more perspicious type in
-- signatures.
--
-- Its argument holds the headers of the blocks that validation pushed onto the
-- forker, anchored where the forker started.
newtype SuccessForkerAction m l blk = MkSuccessForkerAction
  { forall (m :: * -> *) (l :: StateKind) blk.
SuccessForkerAction m l blk
-> AnchoredFragment (HeaderWithTime blk) -> Forker m l blk -> m ()
applySuccessForkerAction :: AnchoredFragment (HeaderWithTime blk) -> Forker m l blk -> m ()
  }

-- | When validating a sequence of blocks, these are the possible outcomes.
data ValidateResult l blk
  = -- | The headers of the validated blocks, as for 'SuccessForkerAction'
    ValidateSuccessful (AnchoredFragment (HeaderWithTime blk))
  | ValidateLedgerError (AnnLedgerError l blk)
  | ValidateExceededRollBack ExceededRollback

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

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

type AnnLedgerError' blk = AnnLedgerError ExtLedgerState 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)