{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Run one leadership check and, if we are leader, forge and adopt a block.
--
-- This is spawned once per forge-credentials thread by
-- 'Ouroboros.Consensus.NodeKernel.forkBlockForging'.
module Ouroboros.Consensus.NodeKernel.Forge
  ( forge
  ) where

import Control.Monad
import Control.Monad.Except
import Control.Tracer
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust)
import Data.Proxy
import Ouroboros.Consensus.Block hiding (blockMatchesHeader)
import qualified Ouroboros.Consensus.Block as Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Forecast
import Ouroboros.Consensus.HeaderValidation
  ( BasicEnvelopeValidation (..)
  , HeaderState (..)
  , headerStateChainDep
  )
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.Ledger.SupportsProtocol
import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables)
import Ouroboros.Consensus.Mempool
import Ouroboros.Consensus.Mempool.API (TxMeasureWithDiffTime)
import Ouroboros.Consensus.Node.Run
import Ouroboros.Consensus.Node.Tracers
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Storage.ChainDB.API
  ( AddBlockResult (..)
  , ChainDB
  )
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment
import Ouroboros.Consensus.Storage.LedgerDB
import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
import Ouroboros.Consensus.Util (whenJust)
import Ouroboros.Consensus.Util.EarlyExit
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.Orphans ()
import Ouroboros.Consensus.Util.STM
import Ouroboros.Network.AnchoredFragment
  ( AnchoredFragment
  , AnchoredSeq (..)
  )
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Protocol.LocalStateQuery.Type (Target (..))

forge ::
  forall m blk.
  (IOLike m, RunNode blk) =>
  Tracer m (TraceLabelCreds (TraceForgeEvent blk)) ->
  Tracer m (TraceLabelCreds (ForgeStateInfo blk)) ->
  TopLevelConfig blk ->
  ChainDB m blk ->
  Mempool m blk ->
  BlockForging m blk ->
  SlotNo ->
  WithEarlyExit m ()
forge :: forall (m :: * -> *) blk.
(IOLike m, RunNode blk) =>
Tracer m (TraceLabelCreds (TraceForgeEvent blk))
-> Tracer m (TraceLabelCreds (ForgeStateInfo blk))
-> TopLevelConfig blk
-> ChainDB m blk
-> Mempool m blk
-> BlockForging m blk
-> SlotNo
-> WithEarlyExit m ()
forge Tracer m (TraceLabelCreds (TraceForgeEvent blk))
forgeEventTracer Tracer m (TraceLabelCreds (ForgeStateInfo blk))
forgeStateInfoTracer TopLevelConfig blk
cfg ChainDB m blk
chainDB Mempool m blk
mempool BlockForging m blk
blockForging SlotNo
currentSlot = do
  let trace :: TraceForgeEvent blk -> WithEarlyExit m ()
      trace :: TraceForgeEvent blk -> WithEarlyExit m ()
trace =
        m () -> WithEarlyExit m ()
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
          (m () -> WithEarlyExit m ())
-> (TraceForgeEvent blk -> m ())
-> TraceForgeEvent blk
-> WithEarlyExit m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracer m (TraceLabelCreds (TraceForgeEvent blk))
-> TraceLabelCreds (TraceForgeEvent blk) -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer m (TraceLabelCreds (TraceForgeEvent blk))
forgeEventTracer
          (TraceLabelCreds (TraceForgeEvent blk) -> m ())
-> (TraceForgeEvent blk -> TraceLabelCreds (TraceForgeEvent blk))
-> TraceForgeEvent blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> TraceForgeEvent blk -> TraceLabelCreds (TraceForgeEvent blk)
forall a. Text -> a -> TraceLabelCreds a
TraceLabelCreds (BlockForging m blk -> Text
forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel BlockForging m blk
blockForging)

  TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> TraceForgeEvent blk
forall blk. SlotNo -> TraceForgeEvent blk
TraceStartLeadershipCheck SlotNo
currentSlot

  BlockContext{bcBlockNo, bcPrevPoint} <- (TraceForgeEvent blk -> WithEarlyExit m ())
-> ChainDB m blk -> SlotNo -> WithEarlyExit m (BlockContext blk)
forall (m :: * -> *) blk.
(IOLike m, RunNode blk) =>
(TraceForgeEvent blk -> WithEarlyExit m ())
-> ChainDB m blk -> SlotNo -> WithEarlyExit m (BlockContext blk)
getBlockContext TraceForgeEvent blk -> WithEarlyExit m ()
trace ChainDB m blk
chainDB SlotNo
currentSlot
  trace $ TraceBlockContext currentSlot bcBlockNo bcPrevPoint

  -- Get forker corresponding to bcPrevPoint
  --
  -- This might fail if, in between choosing 'bcPrevPoint' and this call to
  -- 'ChainDB.withReadOnlyForkerAtPoint', we switched to a fork where 'bcPrevPoint'
  -- is no longer on our chain. When that happens, we simply give up on the
  -- chance to produce a block.
  (fbArgs, txssz, snapSize, forgingOnTopOf) <-
    ChainDB.withReadOnlyForkerAtPoint chainDB (SpecificPoint bcPrevPoint) $ \case
      Left GetForkerError
_ -> do
        TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> Point blk -> TraceForgeEvent blk
forall blk. SlotNo -> Point blk -> TraceForgeEvent blk
TraceNoLedgerState SlotNo
currentSlot Point blk
bcPrevPoint
        WithEarlyExit
  m
  (ForgeBlockArgs blk, TxMeasureWithDiffTime blk, MempoolSize,
   Point blk)
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
      Right ReadOnlyForker' m blk
forker -> do
        unticked <- m (ExtLedgerState blk EmptyMK)
-> WithEarlyExit m (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ExtLedgerState blk EmptyMK)
 -> WithEarlyExit m (ExtLedgerState blk EmptyMK))
-> m (ExtLedgerState blk EmptyMK)
-> WithEarlyExit m (ExtLedgerState blk EmptyMK)
forall a b. (a -> b) -> a -> b
$ 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
$ ReadOnlyForker' m blk -> STM m (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) (l :: StateKind) blk.
ReadOnlyForker m l blk -> STM m (l blk EmptyMK)
LedgerDB.roforkerGetLedgerState ReadOnlyForker' m blk
forker

        trace $ TraceLedgerState currentSlot bcPrevPoint

        ledgerView <- getLedgerView trace cfg currentSlot unticked

        let tickedChainDepState = TopLevelConfig blk
-> SlotNo
-> ExtLedgerState blk EmptyMK
-> LedgerView (BlockProtocol blk)
-> Ticked (ChainDepState (BlockProtocol blk))
forall blk.
RunNode blk =>
TopLevelConfig blk
-> SlotNo
-> ExtLedgerState blk EmptyMK
-> LedgerView (BlockProtocol blk)
-> Ticked (ChainDepState (BlockProtocol blk))
getTickedChainDepState TopLevelConfig blk
cfg SlotNo
currentSlot ExtLedgerState blk EmptyMK
unticked LedgerView (BlockProtocol blk)
ledgerView

        proof <-
          getIsLeaderProof
            trace
            forgeStateInfoTracer
            blockForging
            cfg
            currentSlot
            tickedChainDepState

        tickedLedgerState <- getTickedLedgerState trace cfg currentSlot bcPrevPoint unticked

        traceForgingMempoolSnapshot trace mempool currentSlot bcPrevPoint

        (txs, txssz, snapSize) <- getTransactionsToForge cfg mempool currentSlot tickedLedgerState forker

        let fbArgs =
              Block.ForgeBlockArgs
                { fbConfig :: TopLevelConfig blk
Block.fbConfig = TopLevelConfig blk
cfg
                , fbCurrentBlockNo :: BlockNo
Block.fbCurrentBlockNo = BlockNo
bcBlockNo
                , fbCurrentSlotNo :: SlotNo
Block.fbCurrentSlotNo = SlotNo
currentSlot
                , fbPerasCert :: Maybe (PerasCert blk)
Block.fbPerasCert = Maybe (PerasCert blk)
forall a. Maybe a
Nothing -- No PerasCert for now
                , fbCurrentTickedLedgerState :: TickedLedgerState blk EmptyMK
Block.fbCurrentTickedLedgerState = Ticked LedgerState blk DiffMK -> TickedLedgerState blk EmptyMK
forall (l :: StateKind) blk (mk :: MapKind).
HasLedgerTables l blk =>
l blk mk -> l blk EmptyMK
forgetLedgerTables Ticked LedgerState blk DiffMK
tickedLedgerState
                , fbTxs :: [Validated (GenTx blk)]
Block.fbTxs = [Validated (GenTx blk)]
txs
                , fbIsLeader :: IsLeader (BlockProtocol blk)
Block.fbIsLeader = IsLeader (BlockProtocol blk)
proof
                }
        pure
          ( fbArgs
          , txssz
          , snapSize
          , ledgerTipPoint (ledgerState unticked)
          )

  -- Actually produce the block
  newBlock <- lift $ Block.forgeBlock blockForging fbArgs

  trace $
    TraceForgedBlock
      currentSlot
      forgingOnTopOf
      newBlock
      snapSize
      txssz

  addBlockToChainDB trace chainDB mempool currentSlot (fbTxs fbArgs) newBlock

-- | Context required to forge a block
data BlockContext blk = BlockContext
  { forall blk. BlockContext blk -> BlockNo
bcBlockNo :: !BlockNo
  -- ^ the block number of the block to be forged
  , forall blk. BlockContext blk -> Point blk
bcPrevPoint :: !(Point blk)
  -- ^ the point of /the predecessor of/ the block
  --
  -- Note that a block/header stores the hash of its predecessor but not the
  -- slot.
  }

-- | Figure out which block to connect to
--
-- Normally this will be the current block at the tip, but it may be the
-- /previous/ block, if there were multiple slot leaders
getBlockContext ::
  (IOLike m, RunNode blk) =>
  (TraceForgeEvent blk -> WithEarlyExit m ()) ->
  ChainDB m blk ->
  SlotNo ->
  WithEarlyExit m (BlockContext blk)
getBlockContext :: forall (m :: * -> *) blk.
(IOLike m, RunNode blk) =>
(TraceForgeEvent blk -> WithEarlyExit m ())
-> ChainDB m blk -> SlotNo -> WithEarlyExit m (BlockContext blk)
getBlockContext TraceForgeEvent blk -> WithEarlyExit m ()
trace ChainDB m blk
chainDB SlotNo
currentSlot = do
  eBlkCtx <-
    m (Either (TraceForgeEvent blk) (BlockContext blk))
-> WithEarlyExit
     m (Either (TraceForgeEvent blk) (BlockContext blk))
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either (TraceForgeEvent blk) (BlockContext blk))
 -> WithEarlyExit
      m (Either (TraceForgeEvent blk) (BlockContext blk)))
-> m (Either (TraceForgeEvent blk) (BlockContext blk))
-> WithEarlyExit
     m (Either (TraceForgeEvent blk) (BlockContext blk))
forall a b. (a -> b) -> a -> b
$
      STM m (Either (TraceForgeEvent blk) (BlockContext blk))
-> m (Either (TraceForgeEvent blk) (BlockContext blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Either (TraceForgeEvent blk) (BlockContext blk))
 -> m (Either (TraceForgeEvent blk) (BlockContext blk)))
-> STM m (Either (TraceForgeEvent blk) (BlockContext blk))
-> m (Either (TraceForgeEvent blk) (BlockContext blk))
forall a b. (a -> b) -> a -> b
$
        SlotNo
-> AnchoredFragment (Header blk)
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall blk.
RunNode blk =>
SlotNo
-> AnchoredFragment (Header blk)
-> Either (TraceForgeEvent blk) (BlockContext blk)
mkCurrentBlockContext SlotNo
currentSlot
          (AnchoredFragment (Header blk)
 -> Either (TraceForgeEvent blk) (BlockContext blk))
-> STM m (AnchoredFragment (Header blk))
-> STM m (Either (TraceForgeEvent blk) (BlockContext blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (Header blk))
ChainDB.getCurrentChain ChainDB m blk
chainDB
  case eBlkCtx of
    Right BlockContext blk
blkCtx -> BlockContext blk -> WithEarlyExit m (BlockContext blk)
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockContext blk
blkCtx
    Left TraceForgeEvent blk
failure -> do
      TraceForgeEvent blk -> WithEarlyExit m ()
trace TraceForgeEvent blk
failure
      WithEarlyExit m (BlockContext blk)
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly

-- | Create the 'BlockContext' from the header of the previous block
blockContextFromPrevHeader ::
  HasHeader (Header blk) =>
  Header blk -> BlockContext blk
blockContextFromPrevHeader :: forall blk.
HasHeader (Header blk) =>
Header blk -> BlockContext blk
blockContextFromPrevHeader Header blk
hdr =
  -- Recall that an EBB has the same block number as its predecessor, so this
  -- @succ@ is even correct when @hdr@ is an EBB.
  BlockNo -> Point blk -> BlockContext blk
forall blk. BlockNo -> Point blk -> BlockContext blk
BlockContext (BlockNo -> BlockNo
forall a. Enum a => a -> a
succ (Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr)) (Header blk -> Point blk
forall blk. HasHeader (Header blk) => Header blk -> Point blk
headerPoint Header blk
hdr)

-- | Determine the 'BlockContext' for a block about to be forged from the
-- current slot, ChainDB chain fragment, and ChainDB tip block number
--
-- The 'bcPrevPoint' will either refer to the header at the tip of the current
-- chain or, in case there is already a block in this slot (e.g. another node
-- was also elected leader and managed to produce a block before us), the tip's
-- predecessor. If the chain is empty, then it will refer to the chain's anchor
-- point, which may be genesis.
mkCurrentBlockContext ::
  forall blk.
  RunNode blk =>
  -- | the current slot, i.e. the slot of the block about to be forged
  SlotNo ->
  -- | the current chain fragment
  --
  -- Recall that the anchor point is the tip of the ImmutableDB.
  AnchoredFragment (Header blk) ->
  -- | the event records the cause of the failure
  Either (TraceForgeEvent blk) (BlockContext blk)
mkCurrentBlockContext :: forall blk.
RunNode blk =>
SlotNo
-> AnchoredFragment (Header blk)
-> Either (TraceForgeEvent blk) (BlockContext blk)
mkCurrentBlockContext SlotNo
currentSlot AnchoredFragment (Header blk)
c = case AnchoredFragment (Header blk)
c of
  Empty Anchor (Header blk)
AF.AnchorGenesis ->
    -- The chain is entirely empty.
    BlockContext blk -> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. b -> Either a b
Right (BlockContext blk
 -> Either (TraceForgeEvent blk) (BlockContext blk))
-> BlockContext blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ BlockNo -> Point blk -> BlockContext blk
forall blk. BlockNo -> Point blk -> BlockContext blk
BlockContext (Proxy blk -> BlockNo
forall blk (proxy :: * -> *).
BasicEnvelopeValidation blk =>
proxy blk -> BlockNo
forall (proxy :: * -> *). proxy blk -> BlockNo
expectedFirstBlockNo (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)) Point blk
forall {k} (block :: k). Point block
GenesisPoint
  Empty (AF.Anchor SlotNo
anchorSlot HeaderHash (Header blk)
anchorHash BlockNo
anchorBlockNo) ->
    let Point blk
p :: Point blk = SlotNo -> HeaderHash blk -> Point blk
forall {k} (block :: k). SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
anchorSlot HeaderHash blk
HeaderHash (Header blk)
anchorHash
     in if SlotNo
anchorSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
currentSlot
          then BlockContext blk -> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. b -> Either a b
Right (BlockContext blk
 -> Either (TraceForgeEvent blk) (BlockContext blk))
-> BlockContext blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ BlockNo -> Point blk -> BlockContext blk
forall blk. BlockNo -> Point blk -> BlockContext blk
BlockContext (BlockNo -> BlockNo
forall a. Enum a => a -> a
succ BlockNo
anchorBlockNo) Point blk
p
          else TraceForgeEvent blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. a -> Either a b
Left (TraceForgeEvent blk
 -> Either (TraceForgeEvent blk) (BlockContext blk))
-> TraceForgeEvent blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ SlotNo -> Point blk -> BlockNo -> TraceForgeEvent blk
forall blk. SlotNo -> Point blk -> BlockNo -> TraceForgeEvent blk
TraceSlotIsImmutable SlotNo
currentSlot Point blk
p BlockNo
anchorBlockNo
  AnchoredFragment (Header blk)
c' :> Header blk
hdr -> case Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr SlotNo -> SlotNo -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` SlotNo
currentSlot of
    -- The block at the tip of our chain has a slot number /before/ the
    -- current slot number. This is the common case, and we just want to
    -- connect our new block to the block at the tip.
    Ordering
LT -> BlockContext blk -> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. b -> Either a b
Right (BlockContext blk
 -> Either (TraceForgeEvent blk) (BlockContext blk))
-> BlockContext blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ Header blk -> BlockContext blk
forall blk.
HasHeader (Header blk) =>
Header blk -> BlockContext blk
blockContextFromPrevHeader Header blk
hdr
    -- The block at the tip of our chain has a slot that lies in the
    -- future. Although the chain DB should not contain blocks from the
    -- future, if the volatile DB contained such blocks on startup
    -- (due to a node clock misconfiguration) this invariant may be
    -- violated. See: https://github.com/IntersectMBO/ouroboros-consensus/blob/main/docs/website/contents/for-developers/HandlingBlocksFromTheFuture.md#handling-blocks-from-the-future
    -- Also note that if the
    -- system is under heavy load, it is possible (though unlikely) that
    -- one or more slots have passed after @currentSlot@ that we got from
    -- @onSlotChange@ and before we queried the chain DB for the block
    -- at its tip. At the moment, we simply don't produce a block if this
    -- happens.

    -- TODO: We may wish to produce a block here anyway, treating this
    -- as similar to the @EQ@ case below, but we should be careful:
    --
    -- 1. We should think about what slot number to use.
    -- 2. We should be careful to distinguish between the case where we
    --    need to drop a block from the chain and where we don't.
    -- 3. We should be careful about slot numbers and EBBs.
    -- 4. We should probably not produce a block if the system is under
    --    very heavy load (e.g., if a lot of blocks have been produced
    --    after @currentTime@).
    --
    -- See <https://github.com/IntersectMBO/ouroboros-network/issues/1462>
    Ordering
GT -> TraceForgeEvent blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. a -> Either a b
Left (TraceForgeEvent blk
 -> Either (TraceForgeEvent blk) (BlockContext blk))
-> TraceForgeEvent blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ SlotNo -> SlotNo -> TraceForgeEvent blk
forall blk. SlotNo -> SlotNo -> TraceForgeEvent blk
TraceBlockFromFuture SlotNo
currentSlot (Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr)
    -- The block at the tip has the same slot as the block we're going to
    -- produce (@currentSlot@).
    Ordering
EQ ->
      BlockContext blk -> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. b -> Either a b
Right (BlockContext blk
 -> Either (TraceForgeEvent blk) (BlockContext blk))
-> BlockContext blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. (a -> b) -> a -> b
$
        if Maybe EpochNo -> Bool
forall a. Maybe a -> Bool
isJust (Header blk -> Maybe EpochNo
forall blk. GetHeader blk => Header blk -> Maybe EpochNo
headerIsEBB Header blk
hdr)
          -- We allow forging a block that is the successor of an EBB in the
          -- same slot.
          then Header blk -> BlockContext blk
forall blk.
HasHeader (Header blk) =>
Header blk -> BlockContext blk
blockContextFromPrevHeader Header blk
hdr
          -- If @hdr@ is not an EBB, then forge an alternative to @hdr@: same
          -- block no and same predecessor.
          else BlockNo -> Point blk -> BlockContext blk
forall blk. BlockNo -> Point blk -> BlockContext blk
BlockContext (Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr) (Point blk -> BlockContext blk) -> Point blk -> BlockContext blk
forall a b. (a -> b) -> a -> b
$ Point (Header blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> Point (Header blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
c'

-- | Add a forged block to the ChainDB, tracing whether it was adopted, and
-- removing its transactions from the mempool if it turned out to be invalid.
addBlockToChainDB ::
  (IOLike m, RunNode blk) =>
  (TraceForgeEvent blk -> WithEarlyExit m ()) ->
  ChainDB m blk ->
  Mempool m blk ->
  SlotNo ->
  [Validated (GenTx blk)] ->
  blk ->
  WithEarlyExit m ()
addBlockToChainDB :: forall (m :: * -> *) blk.
(IOLike m, RunNode blk) =>
(TraceForgeEvent blk -> WithEarlyExit m ())
-> ChainDB m blk
-> Mempool m blk
-> SlotNo
-> [Validated (GenTx blk)]
-> blk
-> WithEarlyExit m ()
addBlockToChainDB TraceForgeEvent blk -> WithEarlyExit m ()
trace ChainDB m blk
chainDB Mempool m blk
mempool SlotNo
currentSlot [Validated (GenTx blk)]
txs blk
newBlock = do
  let noPunish :: InvalidBlockPunishment m
noPunish = InvalidBlockPunishment m
forall (m :: * -> *). Applicative m => InvalidBlockPunishment m
InvalidBlockPunishment.noPunishment -- no way to punish yourself
  -- Make sure that if an async exception is thrown while a block is
  -- added to the chain db, we will remove txs from the mempool.

  -- 'addBlockAsync' is a non-blocking action, so `mask_` would suffice,
  -- but the finalizer is a blocking operation, hence we need to use
  -- 'uninterruptibleMask_' to make sure that async exceptions do not
  -- interrupt it.
  WithEarlyExit m () -> WithEarlyExit m ()
forall a. WithEarlyExit m a -> WithEarlyExit m a
forall (m :: * -> *) a. MonadMask m => m a -> m a
uninterruptibleMask_ (WithEarlyExit m () -> WithEarlyExit m ())
-> WithEarlyExit m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ do
    result <- m (AddBlockPromise m blk)
-> WithEarlyExit m (AddBlockPromise m blk)
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (AddBlockPromise m blk)
 -> WithEarlyExit m (AddBlockPromise m blk))
-> m (AddBlockPromise m blk)
-> WithEarlyExit m (AddBlockPromise m blk)
forall a b. (a -> b) -> a -> b
$ ChainDB m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
forall (m :: * -> *) blk.
ChainDB m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
ChainDB.addBlockAsync ChainDB m blk
chainDB InvalidBlockPunishment m
noPunish blk
newBlock
    -- Block until we have processed the block
    mbCurTip <- lift $ atomically $ ChainDB.blockProcessed result

    -- Check whether we adopted our block
    when (mbCurTip /= SuccesfullyAddedBlock (blockPoint newBlock)) $ do
      isInvalid <-
        lift $
          atomically $
            ($ blockHash newBlock) . forgetFingerprint
              <$> ChainDB.getIsInvalidBlock chainDB
      case isInvalid of
        Maybe (ExtValidationError blk)
Nothing ->
          TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> blk -> TraceForgeEvent blk
forall blk. SlotNo -> blk -> TraceForgeEvent blk
TraceDidntAdoptBlock SlotNo
currentSlot blk
newBlock
        Just ExtValidationError blk
reason -> do
          TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> blk -> ExtValidationError blk -> TraceForgeEvent blk
forall blk.
SlotNo -> blk -> ExtValidationError blk -> TraceForgeEvent blk
TraceForgedInvalidBlock SlotNo
currentSlot blk
newBlock ExtValidationError blk
reason
          -- We just produced a block that is invalid according to the
          -- ledger in the ChainDB, while the mempool said it is valid.
          -- There is an inconsistency between the two!
          --
          -- Remove all the transactions in that block, otherwise we'll
          -- run the risk of forging the same invalid block again. This
          -- means that we'll throw away some good transactions in the
          -- process.
          Maybe (NonEmpty (TxId (GenTx blk)))
-> (NonEmpty (TxId (GenTx blk)) -> WithEarlyExit m ())
-> WithEarlyExit m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust
            ([TxId (GenTx blk)] -> Maybe (NonEmpty (TxId (GenTx blk)))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ((Validated (GenTx blk) -> TxId (GenTx blk))
-> [Validated (GenTx blk)] -> [TxId (GenTx blk)]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx blk -> TxId (GenTx blk)
forall tx. HasTxId tx => tx -> TxId tx
txId (GenTx blk -> TxId (GenTx blk))
-> (Validated (GenTx blk) -> GenTx blk)
-> Validated (GenTx blk)
-> TxId (GenTx blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx blk) -> GenTx blk
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated) [Validated (GenTx blk)]
txs))
            (m () -> WithEarlyExit m ()
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithEarlyExit m ())
-> (NonEmpty (TxId (GenTx blk)) -> m ())
-> NonEmpty (TxId (GenTx blk))
-> WithEarlyExit m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mempool m blk -> NonEmpty (TxId (GenTx blk)) -> m ()
forall (m :: * -> *) blk.
Mempool m blk -> NonEmpty (GenTxId blk) -> m ()
removeTxsEvenIfValid Mempool m blk
mempool)
      exitEarly

    -- We successfully produced /and/ adopted a block
    --
    -- NOTE: we are tracing the transactions we retrieved from the Mempool,
    -- not the transactions actually /in the block/.
    -- The transactions in the block should be a prefix of the transactions
    -- in the mempool. If this is not the case, this is a bug.
    -- Unfortunately, we can't
    -- assert this here because the ability to extract transactions from a
    -- block, i.e., the @HasTxs@ class, is not implementable by all blocks,
    -- e.g., @DualBlock@.
    trace $ TraceAdoptedBlock currentSlot newBlock txs

-- | Obtain the ticked ledger view for 'currentSlot', required in order to
-- construct the ticked 'ChainDepState'.
getLedgerView ::
  (IOLike m, RunNode blk) =>
  (TraceForgeEvent blk -> WithEarlyExit m ()) ->
  TopLevelConfig blk ->
  SlotNo ->
  ExtLedgerState blk EmptyMK ->
  WithEarlyExit m (LedgerView (BlockProtocol blk))
getLedgerView :: forall (m :: * -> *) blk.
(IOLike m, RunNode blk) =>
(TraceForgeEvent blk -> WithEarlyExit m ())
-> TopLevelConfig blk
-> SlotNo
-> ExtLedgerState blk EmptyMK
-> WithEarlyExit m (LedgerView (BlockProtocol blk))
getLedgerView TraceForgeEvent blk -> WithEarlyExit m ()
trace TopLevelConfig blk
cfg SlotNo
currentSlot ExtLedgerState blk EmptyMK
unticked = do
  ledgerView <-
    case Except OutsideForecastRange (LedgerView (BlockProtocol blk))
-> Either OutsideForecastRange (LedgerView (BlockProtocol blk))
forall e a. Except e a -> Either e a
runExcept (Except OutsideForecastRange (LedgerView (BlockProtocol blk))
 -> Either OutsideForecastRange (LedgerView (BlockProtocol blk)))
-> Except OutsideForecastRange (LedgerView (BlockProtocol blk))
-> Either OutsideForecastRange (LedgerView (BlockProtocol blk))
forall a b. (a -> b) -> a -> b
$
      Forecast (LedgerView (BlockProtocol blk))
-> SlotNo
-> Except OutsideForecastRange (LedgerView (BlockProtocol blk))
forall a. Forecast a -> SlotNo -> Except OutsideForecastRange a
forecastFor
        ( LedgerConfig blk
-> LedgerState blk EmptyMK
-> Forecast (LedgerView (BlockProtocol blk))
forall blk (mk :: MapKind).
(LedgerSupportsProtocol blk, HasCallStack) =>
LedgerConfig blk
-> LedgerState blk mk -> Forecast (LedgerView (BlockProtocol blk))
forall (mk :: MapKind).
HasCallStack =>
LedgerConfig blk
-> LedgerState blk mk -> Forecast (LedgerView (BlockProtocol blk))
ledgerViewForecastAt
            (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg)
            (ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState ExtLedgerState blk EmptyMK
unticked)
        )
        SlotNo
currentSlot of
      Left OutsideForecastRange
err -> do
        -- There are so many empty slots between the tip of our chain and the
        -- current slot that we cannot get a ledger view anymore. In
        -- principle, this is no problem; we can still produce a block (we use
        -- the ticked ledger state). However, we probably don't /want/ to
        -- produce a block in this case; we are most likely missing blocks
        -- on our chain.
        TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> OutsideForecastRange -> TraceForgeEvent blk
forall blk. SlotNo -> OutsideForecastRange -> TraceForgeEvent blk
TraceNoLedgerView SlotNo
currentSlot OutsideForecastRange
err
        WithEarlyExit m (LedgerView (BlockProtocol blk))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
      Right LedgerView (BlockProtocol blk)
lv ->
        LedgerView (BlockProtocol blk)
-> WithEarlyExit m (LedgerView (BlockProtocol blk))
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. Monad m => a -> m a
return LedgerView (BlockProtocol blk)
lv

  trace $ TraceLedgerView currentSlot
  pure ledgerView

-- | Tick the 'ChainDepState' for the 'SlotNo' we're producing a block for. We
-- only need the ticked 'ChainDepState' to check whether we're a leader.
-- This is much cheaper than ticking the entire 'ExtLedgerState'.
getTickedChainDepState ::
  RunNode blk =>
  TopLevelConfig blk ->
  SlotNo ->
  ExtLedgerState blk EmptyMK ->
  LedgerView (BlockProtocol blk) ->
  Ticked (ChainDepState (BlockProtocol blk))
getTickedChainDepState :: forall blk.
RunNode blk =>
TopLevelConfig blk
-> SlotNo
-> ExtLedgerState blk EmptyMK
-> LedgerView (BlockProtocol blk)
-> Ticked (ChainDepState (BlockProtocol blk))
getTickedChainDepState TopLevelConfig blk
cfg SlotNo
currentSlot ExtLedgerState blk EmptyMK
unticked LedgerView (BlockProtocol blk)
ledgerView =
  ConsensusConfig (BlockProtocol blk)
-> LedgerView (BlockProtocol blk)
-> SlotNo
-> ChainDepState (BlockProtocol blk)
-> Ticked (ChainDepState (BlockProtocol blk))
forall p.
ConsensusProtocol p =>
ConsensusConfig p
-> LedgerView p
-> SlotNo
-> ChainDepState p
-> Ticked (ChainDepState p)
tickChainDepState
    (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig blk
cfg)
    LedgerView (BlockProtocol blk)
ledgerView
    SlotNo
currentSlot
    (HeaderState blk -> ChainDepState (BlockProtocol blk)
forall blk. HeaderState blk -> ChainDepState (BlockProtocol blk)
headerStateChainDep (ExtLedgerState blk EmptyMK -> HeaderState blk
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> HeaderState blk
headerState ExtLedgerState blk EmptyMK
unticked))

-- | Check whether we are leader for 'currentSlot', given the ticked
-- 'ChainDepState', and obtain the leadership proof if so.
getIsLeaderProof ::
  (IOLike m, RunNode blk) =>
  (TraceForgeEvent blk -> WithEarlyExit m ()) ->
  Tracer m (TraceLabelCreds (ForgeStateInfo blk)) ->
  BlockForging m blk ->
  TopLevelConfig blk ->
  SlotNo ->
  Ticked (ChainDepState (BlockProtocol blk)) ->
  WithEarlyExit m (IsLeader (BlockProtocol blk))
getIsLeaderProof :: forall (m :: * -> *) blk.
(IOLike m, RunNode blk) =>
(TraceForgeEvent blk -> WithEarlyExit m ())
-> Tracer m (TraceLabelCreds (ForgeStateInfo blk))
-> BlockForging m blk
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> WithEarlyExit m (IsLeader (BlockProtocol blk))
getIsLeaderProof TraceForgeEvent blk -> WithEarlyExit m ()
trace Tracer m (TraceLabelCreds (ForgeStateInfo blk))
forgeStateInfoTracer BlockForging m blk
blockForging TopLevelConfig blk
cfg SlotNo
currentSlot Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState = do
  proof <- do
    shouldForge <-
      m (ShouldForge blk) -> WithEarlyExit m (ShouldForge blk)
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ShouldForge blk) -> WithEarlyExit m (ShouldForge blk))
-> m (ShouldForge blk) -> WithEarlyExit m (ShouldForge blk)
forall a b. (a -> b) -> a -> b
$
        BlockForging m blk
-> Tracer m (ForgeStateInfo blk)
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ShouldForge blk)
forall (m :: * -> *) blk.
(Monad m, ConsensusProtocol (BlockProtocol blk), HasCallStack) =>
BlockForging m blk
-> Tracer m (ForgeStateInfo blk)
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ShouldForge blk)
checkShouldForge
          BlockForging m blk
blockForging
          ( (ForgeStateInfo blk -> TraceLabelCreds (ForgeStateInfo blk))
-> Tracer m (TraceLabelCreds (ForgeStateInfo blk))
-> Tracer m (ForgeStateInfo blk)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap
              (Text -> ForgeStateInfo blk -> TraceLabelCreds (ForgeStateInfo blk)
forall a. Text -> a -> TraceLabelCreds a
TraceLabelCreds (BlockForging m blk -> Text
forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel BlockForging m blk
blockForging))
              Tracer m (TraceLabelCreds (ForgeStateInfo blk))
forgeStateInfoTracer
          )
          TopLevelConfig blk
cfg
          SlotNo
currentSlot
          Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState
    case shouldForge of
      ForgeStateUpdateError ForgeStateUpdateError blk
err -> do
        TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> ForgeStateUpdateError blk -> TraceForgeEvent blk
forall blk.
SlotNo -> ForgeStateUpdateError blk -> TraceForgeEvent blk
TraceForgeStateUpdateError SlotNo
currentSlot ForgeStateUpdateError blk
err
        WithEarlyExit m (IsLeader (BlockProtocol blk))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
      CannotForge CannotForge blk
cannotForge -> do
        TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> CannotForge blk -> TraceForgeEvent blk
forall blk. SlotNo -> CannotForge blk -> TraceForgeEvent blk
TraceNodeCannotForge SlotNo
currentSlot CannotForge blk
cannotForge
        WithEarlyExit m (IsLeader (BlockProtocol blk))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
      ShouldForge blk
NotLeader -> do
        TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> TraceForgeEvent blk
forall blk. SlotNo -> TraceForgeEvent blk
TraceNodeNotLeader SlotNo
currentSlot
        WithEarlyExit m (IsLeader (BlockProtocol blk))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
      ShouldForge IsLeader (BlockProtocol blk)
p -> IsLeader (BlockProtocol blk)
-> WithEarlyExit m (IsLeader (BlockProtocol blk))
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. Monad m => a -> m a
return IsLeader (BlockProtocol blk)
p

  -- At this point we have established that we are indeed slot leader
  trace $ TraceNodeIsLeader currentSlot
  pure proof

-- | Tick the ledger state for the 'SlotNo' we're producing a block for
getTickedLedgerState ::
  (IOLike m, RunNode blk) =>
  (TraceForgeEvent blk -> WithEarlyExit m ()) ->
  TopLevelConfig blk ->
  SlotNo ->
  Point blk ->
  ExtLedgerState blk EmptyMK ->
  WithEarlyExit m (Ticked LedgerState blk DiffMK)
getTickedLedgerState :: forall (m :: * -> *) blk.
(IOLike m, RunNode blk) =>
(TraceForgeEvent blk -> WithEarlyExit m ())
-> TopLevelConfig blk
-> SlotNo
-> Point blk
-> ExtLedgerState blk EmptyMK
-> WithEarlyExit m (Ticked LedgerState blk DiffMK)
getTickedLedgerState TraceForgeEvent blk -> WithEarlyExit m ()
trace TopLevelConfig blk
cfg SlotNo
currentSlot Point blk
bcPrevPoint ExtLedgerState blk EmptyMK
unticked = do
  let tickedLedgerState :: Ticked LedgerState blk DiffMK
tickedLedgerState =
        ComputeLedgerEvents
-> LedgerCfg LedgerState blk
-> SlotNo
-> LedgerState blk EmptyMK
-> Ticked LedgerState blk DiffMK
forall (l :: StateKind) blk.
IsLedger l blk =>
ComputeLedgerEvents
-> LedgerCfg l blk
-> SlotNo
-> l blk EmptyMK
-> Ticked l blk DiffMK
applyChainTick
          ComputeLedgerEvents
OmitLedgerEvents
          (TopLevelConfig blk -> LedgerCfg LedgerState blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg)
          SlotNo
currentSlot
          (ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState ExtLedgerState blk EmptyMK
unticked)

  _ <- Ticked LedgerState blk DiffMK
-> WithEarlyExit m (Ticked LedgerState blk DiffMK)
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate Ticked LedgerState blk DiffMK
tickedLedgerState
  trace $ TraceForgeTickedLedgerState currentSlot bcPrevPoint
  pure tickedLedgerState

-- | Get a snapshot of the mempool that is consistent with the ledger, and
-- trace it.
--
-- NOTE: It is possible that due to adoption of new blocks the /current/
-- ledger will have changed. This doesn't matter: we will produce a block
-- that fits onto the ledger we got above; if the ledger in the meantime
-- changes, the block we produce here may or may not be adopted, but it
-- won't be invalid.
traceForgingMempoolSnapshot ::
  IOLike m =>
  (TraceForgeEvent blk -> WithEarlyExit m ()) ->
  Mempool m blk ->
  SlotNo ->
  Point blk ->
  WithEarlyExit m ()
traceForgingMempoolSnapshot :: forall (m :: * -> *) blk.
IOLike m =>
(TraceForgeEvent blk -> WithEarlyExit m ())
-> Mempool m blk -> SlotNo -> Point blk -> WithEarlyExit m ()
traceForgingMempoolSnapshot TraceForgeEvent blk -> WithEarlyExit m ()
trace Mempool m blk
mempool SlotNo
currentSlot Point blk
bcPrevPoint = do
  (mempoolHash, mempoolSlotNo) <- m (ChainHash blk, SlotNo)
-> WithEarlyExit m (ChainHash blk, SlotNo)
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ChainHash blk, SlotNo)
 -> WithEarlyExit m (ChainHash blk, SlotNo))
-> m (ChainHash blk, SlotNo)
-> WithEarlyExit m (ChainHash blk, SlotNo)
forall a b. (a -> b) -> a -> b
$ STM m (ChainHash blk, SlotNo) -> m (ChainHash blk, SlotNo)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ChainHash blk, SlotNo) -> m (ChainHash blk, SlotNo))
-> STM m (ChainHash blk, SlotNo) -> m (ChainHash blk, SlotNo)
forall a b. (a -> b) -> a -> b
$ do
    snap <- Mempool m blk -> STM m (MempoolSnapshot blk)
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool m blk
mempool -- only used for its tip-like information
    pure (castHash $ snapshotStateHash snap, snapshotSlotNo snap)

  _ <- evaluate mempoolHash

  trace $ TraceForgingMempoolSnapshot currentSlot bcPrevPoint mempoolHash mempoolSlotNo

-- | Get a consistent snapshot of the mempool for the given ticked ledger state
-- and select transactions up to block capacity.
getTransactionsToForge ::
  (IOLike m, RunNode blk) =>
  TopLevelConfig blk ->
  Mempool m blk ->
  SlotNo ->
  Ticked LedgerState blk DiffMK ->
  ReadOnlyForker m l blk ->
  WithEarlyExit m ([Validated (GenTx blk)], TxMeasureWithDiffTime blk, MempoolSize)
getTransactionsToForge :: forall (m :: * -> *) blk (l :: StateKind).
(IOLike m, RunNode blk) =>
TopLevelConfig blk
-> Mempool m blk
-> SlotNo
-> Ticked LedgerState blk DiffMK
-> ReadOnlyForker m l blk
-> WithEarlyExit
     m ([Validated (GenTx blk)], TxMeasureWithDiffTime blk, MempoolSize)
getTransactionsToForge TopLevelConfig blk
cfg Mempool m blk
mempool SlotNo
currentSlot Ticked LedgerState blk DiffMK
tickedLedgerState ReadOnlyForker m l blk
forker = m ([Validated (GenTx blk)], TxMeasureWithDiffTime blk, MempoolSize)
-> WithEarlyExit
     m ([Validated (GenTx blk)], TxMeasureWithDiffTime blk, MempoolSize)
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ([Validated (GenTx blk)], TxMeasureWithDiffTime blk,
    MempoolSize)
 -> WithEarlyExit
      m
      ([Validated (GenTx blk)], TxMeasureWithDiffTime blk, MempoolSize))
-> m ([Validated (GenTx blk)], TxMeasureWithDiffTime blk,
      MempoolSize)
-> WithEarlyExit
     m ([Validated (GenTx blk)], TxMeasureWithDiffTime blk, MempoolSize)
forall a b. (a -> b) -> a -> b
$ do
  mempoolSnapshot <-
    Mempool m blk
-> SlotNo
-> Ticked LedgerState blk DiffMK
-> (LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK))
-> m (MempoolSnapshot blk)
forall (m :: * -> *) blk.
Mempool m blk
-> SlotNo
-> TickedLedgerState blk DiffMK
-> (LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK))
-> m (MempoolSnapshot blk)
getSnapshotFor
      Mempool m blk
mempool
      SlotNo
currentSlot
      Ticked LedgerState blk DiffMK
tickedLedgerState
      (ReadOnlyForker m l blk
-> LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)
forall (m :: * -> *) (l :: StateKind) blk.
ReadOnlyForker m l blk
-> LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)
roforkerReadTables ReadOnlyForker m l blk
forker)

  let (txs, txssz) =
        snapshotTake mempoolSnapshot $
          blockCapacityTxMeasure (configLedger cfg) tickedLedgerState
  -- NB respect the capacity of the ledger state we're extending,
  -- which is /not/ 'snapshotLedgerState'

  _ <- evaluate (length txs)

  pure (txs, txssz, snapshotMempoolSize mempoolSnapshot)