{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DerivingVia           #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}

module Ouroboros.Consensus.NodeKernel (
    -- * Node kernel
    NodeKernel (..)
  , MaxTxCapacityOverride (..)
  , MempoolCapacityBytesOverride (..)
  , NodeArgs (..)
  , TraceForgeEvent (..)
  , initNodeKernel
  , getMempoolReader
  , getMempoolWriter
  ) where

import           Control.Monad
import           Control.Monad.Except
import           Data.Hashable (Hashable)
import           Data.Map.Strict (Map)
import           Data.Maybe (isJust)
import           Data.Proxy
import qualified Data.Text as Text
import           Data.Word (Word32)
import           System.Random (StdGen)

import           Control.Tracer

import           Ouroboros.Network.AnchoredFragment (AnchoredFragment (..))
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (MaxSlotNo)
import           Ouroboros.Network.BlockFetch
import           Ouroboros.Network.NodeToNode (MiniProtocolParameters (..))
import           Ouroboros.Network.TxSubmission.Inbound
                     (TxSubmissionMempoolWriter)
import qualified Ouroboros.Network.TxSubmission.Inbound as Inbound
import           Ouroboros.Network.TxSubmission.Mempool.Reader
                     (TxSubmissionMempoolReader)
import qualified Ouroboros.Network.TxSubmission.Mempool.Reader as MempoolReader

import           Ouroboros.Consensus.Block hiding (blockMatchesHeader)
import qualified Ouroboros.Consensus.Block as Block
import           Ouroboros.Consensus.BlockchainTime
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Forecast
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.Mempool
import           Ouroboros.Consensus.Node.Run
import           Ouroboros.Consensus.Node.Tracers
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Util.AnchoredFragment
import           Ouroboros.Consensus.Util.EarlyExit
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.Orphans ()
import           Ouroboros.Consensus.Util.ResourceRegistry
import           Ouroboros.Consensus.Util.STM

import           Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import           Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.Init as InitChainDB

{-------------------------------------------------------------------------------
  Relay node
-------------------------------------------------------------------------------}

-- | Interface against running relay node
data NodeKernel m remotePeer localPeer blk = NodeKernel {
      -- | The 'ChainDB' of the node
      NodeKernel m remotePeer localPeer blk -> ChainDB m blk
getChainDB             :: ChainDB m blk

      -- | The node's mempool
    , NodeKernel m remotePeer localPeer blk -> Mempool m blk TicketNo
getMempool             :: Mempool m blk TicketNo

      -- | The node's top-level static configuration
    , NodeKernel m remotePeer localPeer blk -> TopLevelConfig blk
getTopLevelConfig      :: TopLevelConfig blk

      -- | The fetch client registry, used for the block fetch clients.
    , NodeKernel m remotePeer localPeer blk
-> FetchClientRegistry remotePeer (Header blk) blk m
getFetchClientRegistry :: FetchClientRegistry remotePeer (Header blk) blk m

      -- | Read the current candidates
    , NodeKernel m remotePeer localPeer blk
-> StrictTVar
     m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
getNodeCandidates      :: StrictTVar m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))

      -- | The node's tracers
    , NodeKernel m remotePeer localPeer blk
-> Tracers m remotePeer localPeer blk
getTracers             :: Tracers m remotePeer localPeer blk
    }

-- | The maximum transaction capacity of a block is computed by taking the max
-- block size from the protocol parameters in the current ledger state and
-- subtracting the size of the header.
--
-- It is possible to override this maximum transaction capacity with a lower
-- value. We ignore higher values than the ledger state's max block size. Such
-- blocks would be rejected by the ledger anyway.
data MaxTxCapacityOverride
  = NoMaxTxCapacityOverride
    -- ^ Don't override the maximum transaction capacity as computed from the
    -- current ledger state.
  | MaxTxCapacityOverride !Word32
    -- ^ Use the following maximum size in bytes for the transaction capacity
    -- of a block.

-- | Arguments required when initializing a node
data NodeArgs m remotePeer localPeer blk = NodeArgs {
      NodeArgs m remotePeer localPeer blk
-> Tracers m remotePeer localPeer blk
tracers                 :: Tracers m remotePeer localPeer blk
    , NodeArgs m remotePeer localPeer blk -> ResourceRegistry m
registry                :: ResourceRegistry m
    , NodeArgs m remotePeer localPeer blk -> TopLevelConfig blk
cfg                     :: TopLevelConfig blk
    , NodeArgs m remotePeer localPeer blk -> BlockchainTime m
btime                   :: BlockchainTime m
    , NodeArgs m remotePeer localPeer blk -> ChainDB m blk
chainDB                 :: ChainDB m blk
    , NodeArgs m remotePeer localPeer blk
-> StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB             :: StorageConfig blk -> InitChainDB m blk -> m ()
    , NodeArgs m remotePeer localPeer blk -> Header blk -> SizeInBytes
blockFetchSize          :: Header blk -> SizeInBytes
    , NodeArgs m remotePeer localPeer blk -> [BlockForging m blk]
blockForging            :: [BlockForging m blk]
    , NodeArgs m remotePeer localPeer blk -> MaxTxCapacityOverride
maxTxCapacityOverride   :: MaxTxCapacityOverride
    , NodeArgs m remotePeer localPeer blk -> MempoolCapacityBytesOverride
mempoolCapacityOverride :: MempoolCapacityBytesOverride
    , NodeArgs m remotePeer localPeer blk -> MiniProtocolParameters
miniProtocolParameters  :: MiniProtocolParameters
    , NodeArgs m remotePeer localPeer blk -> BlockFetchConfiguration
blockFetchConfiguration :: BlockFetchConfiguration
    , NodeArgs m remotePeer localPeer blk -> StdGen
keepAliveRng            :: StdGen
    }

initNodeKernel
    :: forall m remotePeer localPeer blk.
       ( IOLike m
       , RunNode blk
       , NoThunks remotePeer
       , Ord remotePeer
       , Hashable remotePeer
       )
    => NodeArgs m remotePeer localPeer blk
    -> m (NodeKernel m remotePeer localPeer blk)
initNodeKernel :: NodeArgs m remotePeer localPeer blk
-> m (NodeKernel m remotePeer localPeer blk)
initNodeKernel args :: NodeArgs m remotePeer localPeer blk
args@NodeArgs { ResourceRegistry m
registry :: ResourceRegistry m
$sel:registry:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> ResourceRegistry m
registry, TopLevelConfig blk
cfg :: TopLevelConfig blk
$sel:cfg:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> TopLevelConfig blk
cfg, Tracers m remotePeer localPeer blk
tracers :: Tracers m remotePeer localPeer blk
$sel:tracers:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk
-> Tracers m remotePeer localPeer blk
tracers, MaxTxCapacityOverride
maxTxCapacityOverride :: MaxTxCapacityOverride
$sel:maxTxCapacityOverride:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> MaxTxCapacityOverride
maxTxCapacityOverride
                             , [BlockForging m blk]
blockForging :: [BlockForging m blk]
$sel:blockForging:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> [BlockForging m blk]
blockForging, ChainDB m blk
chainDB :: ChainDB m blk
$sel:chainDB:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> ChainDB m blk
chainDB, StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB :: StorageConfig blk -> InitChainDB m blk -> m ()
$sel:initChainDB:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk
-> StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB
                             , BlockFetchConfiguration
blockFetchConfiguration :: BlockFetchConfiguration
$sel:blockFetchConfiguration:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> BlockFetchConfiguration
blockFetchConfiguration } = do

    StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB (TopLevelConfig blk -> StorageConfig blk
forall blk. TopLevelConfig blk -> StorageConfig blk
configStorage TopLevelConfig blk
cfg) (ChainDB m blk -> InitChainDB m blk
forall (m :: * -> *) blk.
IOLike m =>
ChainDB m blk -> InitChainDB m blk
InitChainDB.fromFull ChainDB m blk
chainDB)

    InternalState m remotePeer localPeer blk
st <- NodeArgs m remotePeer localPeer blk
-> m (InternalState m remotePeer localPeer blk)
forall (m :: * -> *) remotePeer localPeer blk.
(IOLike m, LedgerSupportsProtocol blk, Ord remotePeer,
 NoThunks remotePeer, RunNode blk) =>
NodeArgs m remotePeer localPeer blk
-> m (InternalState m remotePeer localPeer blk)
initInternalState NodeArgs m remotePeer localPeer blk
args

    (BlockForging m blk -> m ()) -> [BlockForging m blk] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (MaxTxCapacityOverride
-> InternalState m remotePeer localPeer blk
-> BlockForging m blk
-> m ()
forall (m :: * -> *) remotePeer localPeer blk.
(IOLike m, RunNode blk) =>
MaxTxCapacityOverride
-> InternalState m remotePeer localPeer blk
-> BlockForging m blk
-> m ()
forkBlockForging MaxTxCapacityOverride
maxTxCapacityOverride InternalState m remotePeer localPeer blk
st) [BlockForging m blk]
blockForging

    let IS { BlockFetchConsensusInterface remotePeer (Header blk) blk m
$sel:blockFetchInterface:IS :: forall (m :: * -> *) remotePeer localPeer blk.
InternalState m remotePeer localPeer blk
-> BlockFetchConsensusInterface remotePeer (Header blk) blk m
blockFetchInterface :: BlockFetchConsensusInterface remotePeer (Header blk) blk m
blockFetchInterface, FetchClientRegistry remotePeer (Header blk) blk m
$sel:fetchClientRegistry:IS :: forall (m :: * -> *) remotePeer localPeer blk.
InternalState m remotePeer localPeer blk
-> FetchClientRegistry remotePeer (Header blk) blk m
fetchClientRegistry :: FetchClientRegistry remotePeer (Header blk) blk m
fetchClientRegistry, StrictTVar
  m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
$sel:varCandidates:IS :: forall (m :: * -> *) remotePeer localPeer blk.
InternalState m remotePeer localPeer blk
-> StrictTVar
     m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
varCandidates :: StrictTVar
  m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
varCandidates,
             Mempool m blk TicketNo
$sel:mempool:IS :: forall (m :: * -> *) remotePeer localPeer blk.
InternalState m remotePeer localPeer blk -> Mempool m blk TicketNo
mempool :: Mempool m blk TicketNo
mempool } = InternalState m remotePeer localPeer blk
st

    -- Run the block fetch logic in the background. This will call
    -- 'addFetchedBlock' whenever a new block is downloaded.
    m (Thread m Void) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m Void) -> m ()) -> m (Thread m Void) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m -> String -> m Void -> m (Thread m Void)
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
"NodeKernel.blockFetchLogic" (m Void -> m (Thread m Void)) -> m Void -> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$
      Tracer
  m [TraceLabelPeer remotePeer (FetchDecision [Point (Header blk)])]
-> Tracer
     m (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))
-> BlockFetchConsensusInterface remotePeer (Header blk) blk m
-> FetchClientRegistry remotePeer (Header blk) blk m
-> BlockFetchConfiguration
-> m Void
forall peer header block (m :: * -> *).
(HasHeader header, HasHeader block,
 HeaderHash header ~ HeaderHash block, MonadDelay m,
 MonadMonotonicTime m, MonadSTM m, Ord peer, Hashable peer) =>
Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
-> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> BlockFetchConsensusInterface peer header block m
-> FetchClientRegistry peer header block m
-> BlockFetchConfiguration
-> m Void
blockFetchLogic
        (Tracers m remotePeer localPeer blk
-> Tracer
     m [TraceLabelPeer remotePeer (FetchDecision [Point (Header blk)])]
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f [TraceLabelPeer
        remotePeer (FetchDecision [Point (Header blk)])]
blockFetchDecisionTracer Tracers m remotePeer localPeer blk
tracers)
        (Tracers m remotePeer localPeer blk
-> Tracer
     m (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceLabelPeer
        remotePeer (TraceFetchClientState (Header blk)))
blockFetchClientTracer   Tracers m remotePeer localPeer blk
tracers)
        BlockFetchConsensusInterface remotePeer (Header blk) blk m
blockFetchInterface
        FetchClientRegistry remotePeer (Header blk) blk m
fetchClientRegistry
        BlockFetchConfiguration
blockFetchConfiguration

    NodeKernel m remotePeer localPeer blk
-> m (NodeKernel m remotePeer localPeer blk)
forall (m :: * -> *) a. Monad m => a -> m a
return NodeKernel :: forall (m :: * -> *) remotePeer localPeer blk.
ChainDB m blk
-> Mempool m blk TicketNo
-> TopLevelConfig blk
-> FetchClientRegistry remotePeer (Header blk) blk m
-> StrictTVar
     m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
-> Tracers m remotePeer localPeer blk
-> NodeKernel m remotePeer localPeer blk
NodeKernel
      { $sel:getChainDB:NodeKernel :: ChainDB m blk
getChainDB             = ChainDB m blk
chainDB
      , $sel:getMempool:NodeKernel :: Mempool m blk TicketNo
getMempool             = Mempool m blk TicketNo
mempool
      , $sel:getTopLevelConfig:NodeKernel :: TopLevelConfig blk
getTopLevelConfig      = TopLevelConfig blk
cfg
      , $sel:getFetchClientRegistry:NodeKernel :: FetchClientRegistry remotePeer (Header blk) blk m
getFetchClientRegistry = FetchClientRegistry remotePeer (Header blk) blk m
fetchClientRegistry
      , $sel:getNodeCandidates:NodeKernel :: StrictTVar
  m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
getNodeCandidates      = StrictTVar
  m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
varCandidates
      , $sel:getTracers:NodeKernel :: Tracers m remotePeer localPeer blk
getTracers             = Tracers m remotePeer localPeer blk
tracers
      }

{-------------------------------------------------------------------------------
  Internal node components
-------------------------------------------------------------------------------}

data InternalState m remotePeer localPeer blk = IS {
      InternalState m remotePeer localPeer blk
-> Tracers m remotePeer localPeer blk
tracers             :: Tracers m remotePeer localPeer blk
    , InternalState m remotePeer localPeer blk -> TopLevelConfig blk
cfg                 :: TopLevelConfig blk
    , InternalState m remotePeer localPeer blk -> ResourceRegistry m
registry            :: ResourceRegistry m
    , InternalState m remotePeer localPeer blk -> BlockchainTime m
btime               :: BlockchainTime m
    , InternalState m remotePeer localPeer blk -> ChainDB m blk
chainDB             :: ChainDB m blk
    , InternalState m remotePeer localPeer blk
-> BlockFetchConsensusInterface remotePeer (Header blk) blk m
blockFetchInterface :: BlockFetchConsensusInterface remotePeer (Header blk) blk m
    , InternalState m remotePeer localPeer blk
-> FetchClientRegistry remotePeer (Header blk) blk m
fetchClientRegistry :: FetchClientRegistry remotePeer (Header blk) blk m
    , InternalState m remotePeer localPeer blk
-> StrictTVar
     m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
varCandidates       :: StrictTVar m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
    , InternalState m remotePeer localPeer blk -> Mempool m blk TicketNo
mempool             :: Mempool m blk TicketNo
    }

initInternalState
    :: forall m remotePeer localPeer blk.
       ( IOLike m
       , LedgerSupportsProtocol blk
       , Ord remotePeer
       , NoThunks remotePeer
       , RunNode blk
       )
    => NodeArgs m remotePeer localPeer blk
    -> m (InternalState m remotePeer localPeer blk)
initInternalState :: NodeArgs m remotePeer localPeer blk
-> m (InternalState m remotePeer localPeer blk)
initInternalState NodeArgs { Tracers m remotePeer localPeer blk
tracers :: Tracers m remotePeer localPeer blk
$sel:tracers:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk
-> Tracers m remotePeer localPeer blk
tracers, ChainDB m blk
chainDB :: ChainDB m blk
$sel:chainDB:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> ChainDB m blk
chainDB, ResourceRegistry m
registry :: ResourceRegistry m
$sel:registry:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> ResourceRegistry m
registry, TopLevelConfig blk
cfg :: TopLevelConfig blk
$sel:cfg:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> TopLevelConfig blk
cfg,
                             Header blk -> SizeInBytes
blockFetchSize :: Header blk -> SizeInBytes
$sel:blockFetchSize:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> Header blk -> SizeInBytes
blockFetchSize, BlockchainTime m
btime :: BlockchainTime m
$sel:btime:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> BlockchainTime m
btime,
                             MempoolCapacityBytesOverride
mempoolCapacityOverride :: MempoolCapacityBytesOverride
$sel:mempoolCapacityOverride:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> MempoolCapacityBytesOverride
mempoolCapacityOverride } = do
    StrictTVar
  m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
varCandidates <- Map remotePeer (StrictTVar m (AnchoredFragment (Header blk)))
-> m (StrictTVar
        m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk)))))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Map remotePeer (StrictTVar m (AnchoredFragment (Header blk)))
forall a. Monoid a => a
mempty
    Mempool m blk TicketNo
mempool       <- ResourceRegistry m
-> LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> (GenTx blk -> SizeInBytes)
-> m (Mempool m blk TicketNo)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
ResourceRegistry m
-> LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> (GenTx blk -> SizeInBytes)
-> m (Mempool m blk TicketNo)
openMempool ResourceRegistry m
registry
                                 (ChainDB m blk -> LedgerInterface m blk
forall (m :: * -> *) blk.
IOLike m =>
ChainDB m blk -> LedgerInterface m blk
chainDBLedgerInterface ChainDB m blk
chainDB)
                                 (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg)
                                 MempoolCapacityBytesOverride
mempoolCapacityOverride
                                 (Tracers m remotePeer localPeer blk
-> Tracer m (TraceEventMempool blk)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f -> f (TraceEventMempool blk)
mempoolTracer Tracers m remotePeer localPeer blk
tracers)
                                 GenTx blk -> SizeInBytes
forall blk. LedgerSupportsMempool blk => GenTx blk -> SizeInBytes
txInBlockSize

    FetchClientRegistry remotePeer (Header blk) blk m
fetchClientRegistry <- m (FetchClientRegistry remotePeer (Header blk) blk m)
forall (m :: * -> *) peer header block.
MonadSTM m =>
m (FetchClientRegistry peer header block m)
newFetchClientRegistry

    let getCandidates :: STM m (Map remotePeer (AnchoredFragment (Header blk)))
        getCandidates :: STM m (Map remotePeer (AnchoredFragment (Header blk)))
getCandidates = StrictTVar
  m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
-> STM
     m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
varCandidates STM
  m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
-> (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk)))
    -> STM m (Map remotePeer (AnchoredFragment (Header blk))))
-> STM m (Map remotePeer (AnchoredFragment (Header blk)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (StrictTVar m (AnchoredFragment (Header blk))
 -> STM m (AnchoredFragment (Header blk)))
-> Map remotePeer (StrictTVar m (AnchoredFragment (Header blk)))
-> STM m (Map remotePeer (AnchoredFragment (Header blk)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse StrictTVar m (AnchoredFragment (Header blk))
-> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar

        blockFetchInterface :: BlockFetchConsensusInterface remotePeer (Header blk) blk m
        blockFetchInterface :: BlockFetchConsensusInterface remotePeer (Header blk) blk m
blockFetchInterface = TopLevelConfig blk
-> ChainDB m blk
-> STM m (Map remotePeer (AnchoredFragment (Header blk)))
-> (Header blk -> SizeInBytes)
-> BlockchainTime m
-> BlockFetchConsensusInterface remotePeer (Header blk) blk m
forall (m :: * -> *) peer blk.
(IOLike m, BlockSupportsProtocol blk) =>
TopLevelConfig blk
-> ChainDB m blk
-> STM m (Map peer (AnchoredFragment (Header blk)))
-> (Header blk -> SizeInBytes)
-> BlockchainTime m
-> BlockFetchConsensusInterface peer (Header blk) blk m
initBlockFetchConsensusInterface
          TopLevelConfig blk
cfg ChainDB m blk
chainDB STM m (Map remotePeer (AnchoredFragment (Header blk)))
getCandidates Header blk -> SizeInBytes
blockFetchSize BlockchainTime m
btime

    InternalState m remotePeer localPeer blk
-> m (InternalState m remotePeer localPeer blk)
forall (m :: * -> *) a. Monad m => a -> m a
return IS :: forall (m :: * -> *) remotePeer localPeer blk.
Tracers m remotePeer localPeer blk
-> TopLevelConfig blk
-> ResourceRegistry m
-> BlockchainTime m
-> ChainDB m blk
-> BlockFetchConsensusInterface remotePeer (Header blk) blk m
-> FetchClientRegistry remotePeer (Header blk) blk m
-> StrictTVar
     m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
-> Mempool m blk TicketNo
-> InternalState m remotePeer localPeer blk
IS {StrictTVar
  m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
TopLevelConfig blk
Mempool m blk TicketNo
BlockFetchConsensusInterface remotePeer (Header blk) blk m
FetchClientRegistry remotePeer (Header blk) blk m
ResourceRegistry m
ChainDB m blk
BlockchainTime m
Tracers m remotePeer localPeer blk
blockFetchInterface :: BlockFetchConsensusInterface remotePeer (Header blk) blk m
fetchClientRegistry :: FetchClientRegistry remotePeer (Header blk) blk m
mempool :: Mempool m blk TicketNo
varCandidates :: StrictTVar
  m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
btime :: BlockchainTime m
cfg :: TopLevelConfig blk
registry :: ResourceRegistry m
chainDB :: ChainDB m blk
tracers :: Tracers m remotePeer localPeer blk
$sel:chainDB:IS :: ChainDB m blk
$sel:btime:IS :: BlockchainTime m
$sel:registry:IS :: ResourceRegistry m
$sel:cfg:IS :: TopLevelConfig blk
$sel:tracers:IS :: Tracers m remotePeer localPeer blk
$sel:mempool:IS :: Mempool m blk TicketNo
$sel:varCandidates:IS :: StrictTVar
  m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
$sel:fetchClientRegistry:IS :: FetchClientRegistry remotePeer (Header blk) blk m
$sel:blockFetchInterface:IS :: BlockFetchConsensusInterface remotePeer (Header blk) blk m
..}

initBlockFetchConsensusInterface
    :: forall m peer blk. (IOLike m, BlockSupportsProtocol blk)
    => TopLevelConfig blk
    -> ChainDB m blk
    -> STM m (Map peer (AnchoredFragment (Header blk)))
    -> (Header blk -> SizeInBytes)
    -> BlockchainTime m
    -> BlockFetchConsensusInterface peer (Header blk) blk m
initBlockFetchConsensusInterface :: TopLevelConfig blk
-> ChainDB m blk
-> STM m (Map peer (AnchoredFragment (Header blk)))
-> (Header blk -> SizeInBytes)
-> BlockchainTime m
-> BlockFetchConsensusInterface peer (Header blk) blk m
initBlockFetchConsensusInterface TopLevelConfig blk
cfg ChainDB m blk
chainDB STM m (Map peer (AnchoredFragment (Header blk)))
getCandidates Header blk -> SizeInBytes
blockFetchSize BlockchainTime m
btime =
    BlockFetchConsensusInterface :: forall peer header block (m :: * -> *).
STM m (Map peer (AnchoredFragment header))
-> STM m (AnchoredFragment header)
-> STM m FetchMode
-> STM m (Point block -> Bool)
-> (Point block -> block -> m ())
-> STM m MaxSlotNo
-> (HasCallStack =>
    AnchoredFragment header -> AnchoredFragment header -> Bool)
-> (HasCallStack =>
    AnchoredFragment header -> AnchoredFragment header -> Ordering)
-> (header -> SizeInBytes)
-> (header -> block -> Bool)
-> BlockFetchConsensusInterface peer header block m
BlockFetchConsensusInterface {STM m (Map peer (AnchoredFragment (Header blk)))
STM m (AnchoredFragment (Header blk))
STM m MaxSlotNo
STM m FetchMode
STM m (Point blk -> Bool)
HasCallStack =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Bool
HasCallStack =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Ordering
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Bool
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Ordering
Point blk -> blk -> m ()
Header blk -> SizeInBytes
Header blk -> blk -> Bool
readFetchedMaxSlotNo :: STM m MaxSlotNo
readFetchedBlocks :: STM m (Point blk -> Bool)
readFetchMode :: STM m FetchMode
readCurrentChain :: STM m (AnchoredFragment (Header blk))
readCandidateChains :: STM m (Map peer (AnchoredFragment (Header blk)))
plausibleCandidateChain :: HasCallStack =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Bool
compareCandidateChains :: HasCallStack =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Ordering
blockMatchesHeader :: Header blk -> blk -> Bool
blockFetchSize :: Header blk -> SizeInBytes
addFetchedBlock :: Point blk -> blk -> m ()
compareCandidateChains :: AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Ordering
plausibleCandidateChain :: AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Bool
readFetchedMaxSlotNo :: STM m MaxSlotNo
addFetchedBlock :: Point blk -> blk -> m ()
readFetchedBlocks :: STM m (Point blk -> Bool)
readFetchMode :: STM m FetchMode
readCurrentChain :: STM m (AnchoredFragment (Header blk))
readCandidateChains :: STM m (Map peer (AnchoredFragment (Header blk)))
blockMatchesHeader :: Header blk -> blk -> Bool
blockFetchSize :: Header blk -> SizeInBytes
..}
  where
    blockMatchesHeader :: Header blk -> blk -> Bool
    blockMatchesHeader :: Header blk -> blk -> Bool
blockMatchesHeader = Header blk -> blk -> Bool
forall blk. GetHeader blk => Header blk -> blk -> Bool
Block.blockMatchesHeader

    readCandidateChains :: STM m (Map peer (AnchoredFragment (Header blk)))
    readCandidateChains :: STM m (Map peer (AnchoredFragment (Header blk)))
readCandidateChains = STM m (Map peer (AnchoredFragment (Header blk)))
getCandidates

    readCurrentChain :: STM m (AnchoredFragment (Header blk))
    readCurrentChain :: STM m (AnchoredFragment (Header blk))
readCurrentChain = 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

    readFetchMode :: STM m FetchMode
    readFetchMode :: STM m FetchMode
readFetchMode = do
      CurrentSlot
mCurSlot <- BlockchainTime m -> STM m CurrentSlot
forall (m :: * -> *). BlockchainTime m -> STM m CurrentSlot
getCurrentSlot BlockchainTime m
btime
      case CurrentSlot
mCurSlot of
        -- The current chain's tip far away from "now", so use bulk sync mode.
        CurrentSlot
CurrentSlotUnknown  -> FetchMode -> STM m FetchMode
forall (m :: * -> *) a. Monad m => a -> m a
return FetchMode
FetchModeBulkSync
        CurrentSlot SlotNo
curSlot -> do
          WithOrigin SlotNo
curChainSlot <- AnchoredFragment (Header blk) -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot (AnchoredFragment (Header blk) -> WithOrigin SlotNo)
-> STM m (AnchoredFragment (Header blk))
-> STM m (WithOrigin SlotNo)
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
          let slotsBehind :: Word64
slotsBehind = case WithOrigin SlotNo
curChainSlot of
                -- There's nothing in the chain. If the current slot is 0, then
                -- we're 1 slot behind.
                WithOrigin SlotNo
Origin         -> SlotNo -> Word64
unSlotNo SlotNo
curSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
                NotOrigin SlotNo
slot -> SlotNo -> Word64
unSlotNo SlotNo
curSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- SlotNo -> Word64
unSlotNo SlotNo
slot
              maxSlotsBehind :: Word64
maxSlotsBehind = Word64
1000
          FetchMode -> STM m FetchMode
forall (m :: * -> *) a. Monad m => a -> m a
return (FetchMode -> STM m FetchMode) -> FetchMode -> STM m FetchMode
forall a b. (a -> b) -> a -> b
$ if Word64
slotsBehind Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
maxSlotsBehind
            -- When the current chain is near to "now", use deadline mode,
            -- when it is far away, use bulk sync mode.
            then FetchMode
FetchModeDeadline
            else FetchMode
FetchModeBulkSync

    readFetchedBlocks :: STM m (Point blk -> Bool)
    readFetchedBlocks :: STM m (Point blk -> Bool)
readFetchedBlocks = ChainDB m blk -> STM m (Point blk -> Bool)
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (Point blk -> Bool)
ChainDB.getIsFetched ChainDB m blk
chainDB

    -- Waits until the block has been written to disk, but not until chain
    -- selection has processed the block.
    addFetchedBlock :: Point blk -> blk -> m ()
    addFetchedBlock :: Point blk -> blk -> m ()
addFetchedBlock Point blk
_pt = m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> (blk -> m Bool) -> blk -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainDB m blk -> blk -> m Bool
forall (m :: * -> *) blk.
IOLike m =>
ChainDB m blk -> blk -> m Bool
ChainDB.addBlockWaitWrittenToDisk ChainDB m blk
chainDB

    readFetchedMaxSlotNo :: STM m MaxSlotNo
    readFetchedMaxSlotNo :: STM m MaxSlotNo
readFetchedMaxSlotNo = ChainDB m blk -> STM m MaxSlotNo
forall (m :: * -> *) blk. ChainDB m blk -> STM m MaxSlotNo
ChainDB.getMaxSlotNo ChainDB m blk
chainDB

    plausibleCandidateChain :: AnchoredFragment (Header blk)
                            -> AnchoredFragment (Header blk)
                            -> Bool
    plausibleCandidateChain :: AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Bool
plausibleCandidateChain = TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
forall blk.
BlockSupportsProtocol blk =>
TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate TopLevelConfig blk
cfg

    compareCandidateChains :: AnchoredFragment (Header blk)
                           -> AnchoredFragment (Header blk)
                           -> Ordering
    compareCandidateChains :: AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Ordering
compareCandidateChains = TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Ordering
forall blk.
(BlockSupportsProtocol blk, HasCallStack) =>
TopLevelConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Ordering
compareAnchoredCandidates TopLevelConfig blk
cfg

forkBlockForging
    :: forall m remotePeer localPeer blk.
       (IOLike m, RunNode blk)
    => MaxTxCapacityOverride
    -> InternalState m remotePeer localPeer blk
    -> BlockForging m blk
    -> m ()
forkBlockForging :: MaxTxCapacityOverride
-> InternalState m remotePeer localPeer blk
-> BlockForging m blk
-> m ()
forkBlockForging MaxTxCapacityOverride
maxTxCapacityOverride IS{StrictTVar
  m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
TopLevelConfig blk
Mempool m blk TicketNo
BlockFetchConsensusInterface remotePeer (Header blk) blk m
FetchClientRegistry remotePeer (Header blk) blk m
ResourceRegistry m
ChainDB m blk
BlockchainTime m
Tracers m remotePeer localPeer blk
mempool :: Mempool m blk TicketNo
varCandidates :: StrictTVar
  m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
fetchClientRegistry :: FetchClientRegistry remotePeer (Header blk) blk m
blockFetchInterface :: BlockFetchConsensusInterface remotePeer (Header blk) blk m
chainDB :: ChainDB m blk
btime :: BlockchainTime m
registry :: ResourceRegistry m
cfg :: TopLevelConfig blk
tracers :: Tracers m remotePeer localPeer blk
$sel:chainDB:IS :: forall (m :: * -> *) remotePeer localPeer blk.
InternalState m remotePeer localPeer blk -> ChainDB m blk
$sel:btime:IS :: forall (m :: * -> *) remotePeer localPeer blk.
InternalState m remotePeer localPeer blk -> BlockchainTime m
$sel:registry:IS :: forall (m :: * -> *) remotePeer localPeer blk.
InternalState m remotePeer localPeer blk -> ResourceRegistry m
$sel:cfg:IS :: forall (m :: * -> *) remotePeer localPeer blk.
InternalState m remotePeer localPeer blk -> TopLevelConfig blk
$sel:tracers:IS :: forall (m :: * -> *) remotePeer localPeer blk.
InternalState m remotePeer localPeer blk
-> Tracers m remotePeer localPeer blk
$sel:mempool:IS :: forall (m :: * -> *) remotePeer localPeer blk.
InternalState m remotePeer localPeer blk -> Mempool m blk TicketNo
$sel:varCandidates:IS :: forall (m :: * -> *) remotePeer localPeer blk.
InternalState m remotePeer localPeer blk
-> StrictTVar
     m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
$sel:fetchClientRegistry:IS :: forall (m :: * -> *) remotePeer localPeer blk.
InternalState m remotePeer localPeer blk
-> FetchClientRegistry remotePeer (Header blk) blk m
$sel:blockFetchInterface:IS :: forall (m :: * -> *) remotePeer localPeer blk.
InternalState m remotePeer localPeer blk
-> BlockFetchConsensusInterface remotePeer (Header blk) blk m
..} BlockForging m blk
blockForging =
    m (m ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (m ()) -> m ()) -> m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m
-> BlockchainTime m -> String -> (SlotNo -> m ()) -> m (m ())
forall (m :: * -> *).
(IOLike m, HasCallStack) =>
ResourceRegistry m
-> BlockchainTime m -> String -> (SlotNo -> m ()) -> m (m ())
onKnownSlotChange ResourceRegistry m
registry BlockchainTime m
btime String
threadLabel ((SlotNo -> m ()) -> m (m ())) -> (SlotNo -> m ()) -> m (m ())
forall a b. (a -> b) -> a -> b
$
        WithEarlyExit m () -> m ()
forall (m :: * -> *). Functor m => WithEarlyExit m () -> m ()
withEarlyExit_ (WithEarlyExit m () -> m ())
-> (SlotNo -> WithEarlyExit m ()) -> SlotNo -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> WithEarlyExit m ()
go
  where
    threadLabel :: String
    threadLabel :: String
threadLabel =
        String
"NodeKernel.blockForging." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (BlockForging m blk -> Text
forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel BlockForging m blk
blockForging)

    go :: SlotNo -> WithEarlyExit m ()
    go :: SlotNo -> WithEarlyExit m ()
go SlotNo
currentSlot = 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
TraceStartLeadershipCheck SlotNo
currentSlot

        -- 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
        BlockContext{BlockNo
$sel:bcBlockNo:BlockContext :: forall blk. BlockContext blk -> BlockNo
bcBlockNo :: BlockNo
bcBlockNo, Point blk
$sel:bcPrevPoint:BlockContext :: forall blk. BlockContext blk -> Point blk
bcPrevPoint :: Point blk
bcPrevPoint} <- do
          Either (TraceForgeEvent blk) (BlockContext blk)
eBlkCtx <- m (Either (TraceForgeEvent blk) (BlockContext blk))
-> WithEarlyExit
     m (Either (TraceForgeEvent blk) (BlockContext blk))
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 (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 Either (TraceForgeEvent blk) (BlockContext blk)
eBlkCtx of
            Right BlockContext blk
blkCtx -> BlockContext blk -> WithEarlyExit m (BlockContext blk)
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

        TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> BlockNo -> Point blk -> TraceForgeEvent blk
forall blk. SlotNo -> BlockNo -> Point blk -> TraceForgeEvent blk
TraceBlockContext SlotNo
currentSlot BlockNo
bcBlockNo Point blk
bcPrevPoint

        -- Get ledger state corresponding to bcPrevPoint
        --
        -- This might fail if, in between choosing 'bcPrevPoint' and this call to
        -- 'getPastLedger', 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.
        ExtLedgerState blk
unticked <- do
          Maybe (ExtLedgerState blk)
mExtLedger <- m (Maybe (ExtLedgerState blk))
-> WithEarlyExit m (Maybe (ExtLedgerState blk))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe (ExtLedgerState blk))
 -> WithEarlyExit m (Maybe (ExtLedgerState blk)))
-> m (Maybe (ExtLedgerState blk))
-> WithEarlyExit m (Maybe (ExtLedgerState blk))
forall a b. (a -> b) -> a -> b
$ STM m (Maybe (ExtLedgerState blk))
-> m (Maybe (ExtLedgerState blk))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (ExtLedgerState blk))
 -> m (Maybe (ExtLedgerState blk)))
-> STM m (Maybe (ExtLedgerState blk))
-> m (Maybe (ExtLedgerState blk))
forall a b. (a -> b) -> a -> b
$ ChainDB m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk))
forall (m :: * -> *) blk.
ChainDB m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk))
ChainDB.getPastLedger ChainDB m blk
chainDB Point blk
bcPrevPoint
          case Maybe (ExtLedgerState blk)
mExtLedger of
            Just ExtLedgerState blk
l  -> ExtLedgerState blk -> WithEarlyExit m (ExtLedgerState blk)
forall (m :: * -> *) a. Monad m => a -> m a
return ExtLedgerState blk
l
            Maybe (ExtLedgerState blk)
Nothing -> 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 (ExtLedgerState blk)
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly

        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
TraceLedgerState SlotNo
currentSlot Point blk
bcPrevPoint

        -- We require the ticked ledger view in order to construct the ticked
        -- 'ChainDepState'.
        Ticked (LedgerView (BlockProtocol blk))
ledgerView <-
          case Except
  OutsideForecastRange (Ticked (LedgerView (BlockProtocol blk)))
-> Either
     OutsideForecastRange (Ticked (LedgerView (BlockProtocol blk)))
forall e a. Except e a -> Either e a
runExcept (Except
   OutsideForecastRange (Ticked (LedgerView (BlockProtocol blk)))
 -> Either
      OutsideForecastRange (Ticked (LedgerView (BlockProtocol blk))))
-> Except
     OutsideForecastRange (Ticked (LedgerView (BlockProtocol blk)))
-> Either
     OutsideForecastRange (Ticked (LedgerView (BlockProtocol blk)))
forall a b. (a -> b) -> a -> b
$ Forecast (LedgerView (BlockProtocol blk))
-> SlotNo
-> Except
     OutsideForecastRange (Ticked (LedgerView (BlockProtocol blk)))
forall a.
Forecast a -> SlotNo -> Except OutsideForecastRange (Ticked a)
forecastFor
                           (LedgerConfig blk
-> LedgerState blk -> Forecast (LedgerView (BlockProtocol blk))
forall blk.
(LedgerSupportsProtocol blk, HasCallStack) =>
LedgerConfig blk
-> LedgerState blk -> Forecast (LedgerView (BlockProtocol blk))
ledgerViewForecastAt
                              (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg)
                              (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
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 an 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 a 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 (Ticked (LedgerView (BlockProtocol blk)))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
            Right Ticked (LedgerView (BlockProtocol blk))
lv ->
              Ticked (LedgerView (BlockProtocol blk))
-> WithEarlyExit m (Ticked (LedgerView (BlockProtocol blk)))
forall (m :: * -> *) a. Monad m => a -> m a
return Ticked (LedgerView (BlockProtocol blk))
lv

        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
TraceLedgerView SlotNo
currentSlot

        -- Tick the 'ChainDepState' for the 'SlotNo' we're producing a block
        -- for. We only need the ticked 'ChainDepState' to check the whether
        -- we're a leader. This is much cheaper than ticking the entire
        -- 'ExtLedgerState'.
        let tickedChainDepState :: Ticked (ChainDepState (BlockProtocol blk))
            tickedChainDepState :: Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState =
                ConsensusConfig (BlockProtocol blk)
-> Ticked (LedgerView (BlockProtocol blk))
-> SlotNo
-> ChainDepState (BlockProtocol blk)
-> Ticked (ChainDepState (BlockProtocol blk))
forall p.
ConsensusProtocol p =>
ConsensusConfig p
-> Ticked (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)
                  Ticked (LedgerView (BlockProtocol blk))
ledgerView
                  SlotNo
currentSlot
                  (HeaderState blk -> ChainDepState (BlockProtocol blk)
forall blk. HeaderState blk -> ChainDepState (BlockProtocol blk)
headerStateChainDep (ExtLedgerState blk -> HeaderState blk
forall blk. ExtLedgerState blk -> HeaderState blk
headerState ExtLedgerState blk
unticked))

        -- Check if we are the leader
        IsLeader (BlockProtocol blk)
proof <- do
          ShouldForge blk
shouldForge <- m (ShouldForge blk) -> WithEarlyExit m (ShouldForge blk)
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 (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> 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))
                (Tracers m remotePeer localPeer blk
-> Tracer m (TraceLabelCreds (ForgeStateInfo blk))
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceLabelCreds (ForgeStateInfo blk))
forgeStateInfoTracer Tracers m remotePeer localPeer blk
tracers))
              TopLevelConfig blk
cfg
              SlotNo
currentSlot
              Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState
          case ShouldForge blk
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 (m :: * -> *) a. Monad m => a -> m a
return IsLeader (BlockProtocol blk)
p

        -- At this point we have established that we are indeed slot leader
        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
TraceNodeIsLeader SlotNo
currentSlot

        -- Tick the ledger state for the 'SlotNo' we're producing a block for
        let tickedLedgerState :: Ticked (LedgerState blk)
            tickedLedgerState :: Ticked (LedgerState blk)
tickedLedgerState =
              LedgerConfig blk
-> SlotNo -> LedgerState blk -> Ticked (LedgerState blk)
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick
                (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg)
                SlotNo
currentSlot
                (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
unticked)

        -- Get a snapshot of the mempool that is consistent with the ledger
        --
        -- 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.
        MempoolSnapshot blk TicketNo
mempoolSnapshot <- m (MempoolSnapshot blk TicketNo)
-> WithEarlyExit m (MempoolSnapshot blk TicketNo)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (MempoolSnapshot blk TicketNo)
 -> WithEarlyExit m (MempoolSnapshot blk TicketNo))
-> m (MempoolSnapshot blk TicketNo)
-> WithEarlyExit m (MempoolSnapshot blk TicketNo)
forall a b. (a -> b) -> a -> b
$ STM m (MempoolSnapshot blk TicketNo)
-> m (MempoolSnapshot blk TicketNo)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (MempoolSnapshot blk TicketNo)
 -> m (MempoolSnapshot blk TicketNo))
-> STM m (MempoolSnapshot blk TicketNo)
-> m (MempoolSnapshot blk TicketNo)
forall a b. (a -> b) -> a -> b
$
                             Mempool m blk TicketNo
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk TicketNo)
forall (m :: * -> *) blk idx.
Mempool m blk idx
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk idx)
getSnapshotFor
                               Mempool m blk TicketNo
mempool
                               (SlotNo -> Ticked (LedgerState blk) -> ForgeLedgerState blk
forall blk. SlotNo -> TickedLedgerState blk -> ForgeLedgerState blk
ForgeInKnownSlot
                                  SlotNo
currentSlot
                                  Ticked (LedgerState blk)
tickedLedgerState)
        let txs :: [GenTx blk]
txs = ((GenTx blk, TicketNo) -> GenTx blk)
-> [(GenTx blk, TicketNo)] -> [GenTx blk]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx blk, TicketNo) -> GenTx blk
forall a b. (a, b) -> a
fst ([(GenTx blk, TicketNo)] -> [GenTx blk])
-> [(GenTx blk, TicketNo)] -> [GenTx blk]
forall a b. (a -> b) -> a -> b
$ MempoolSnapshot blk TicketNo
-> SizeInBytes -> [(GenTx blk, TicketNo)]
forall blk idx.
MempoolSnapshot blk idx -> SizeInBytes -> [(GenTx blk, idx)]
snapshotTxsForSize
                              MempoolSnapshot blk TicketNo
mempoolSnapshot
                              (Ticked (LedgerState blk) -> SizeInBytes
computeMaxTxCapacity Ticked (LedgerState blk)
tickedLedgerState)

        -- Actually produce the block
        blk
newBlock <- m blk -> WithEarlyExit m blk
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m blk -> WithEarlyExit m blk) -> m blk -> WithEarlyExit m blk
forall a b. (a -> b) -> a -> b
$
          BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> Ticked (LedgerState blk)
-> [GenTx blk]
-> IsLeader (BlockProtocol blk)
-> m blk
forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [GenTx blk]
-> IsLeader (BlockProtocol blk)
-> m blk
Block.forgeBlock BlockForging m blk
blockForging
            TopLevelConfig blk
cfg
            BlockNo
bcBlockNo
            SlotNo
currentSlot
            Ticked (LedgerState blk)
tickedLedgerState
            [GenTx blk]
txs
            IsLeader (BlockProtocol blk)
proof
        TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> Point blk -> blk -> MempoolSize -> TraceForgeEvent blk
forall blk.
SlotNo -> Point blk -> blk -> MempoolSize -> TraceForgeEvent blk
TraceForgedBlock
                  SlotNo
currentSlot
                  (Proxy blk -> LedgerState blk -> Point blk
forall blk.
UpdateLedger blk =>
Proxy blk -> LedgerState blk -> Point blk
ledgerTipPoint (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
unticked))
                  blk
newBlock
                  (MempoolSnapshot blk TicketNo -> MempoolSize
forall blk idx. MempoolSnapshot blk idx -> MempoolSize
snapshotMempoolSize MempoolSnapshot blk TicketNo
mempoolSnapshot)

        -- Add the block to the chain DB
        AddBlockPromise m blk
result <- m (AddBlockPromise m blk)
-> WithEarlyExit m (AddBlockPromise m blk)
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 -> blk -> m (AddBlockPromise m blk)
forall (m :: * -> *) blk.
ChainDB m blk -> blk -> m (AddBlockPromise m blk)
ChainDB.addBlockAsync ChainDB m blk
chainDB blk
newBlock
        -- Block until we have processed the block
        Point blk
curTip <- m (Point blk) -> WithEarlyExit m (Point blk)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Point blk) -> WithEarlyExit m (Point blk))
-> m (Point blk) -> WithEarlyExit m (Point blk)
forall a b. (a -> b) -> a -> b
$ STM m (Point blk) -> m (Point blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Point blk) -> m (Point blk))
-> STM m (Point blk) -> m (Point blk)
forall a b. (a -> b) -> a -> b
$ AddBlockPromise m blk -> STM m (Point blk)
forall (m :: * -> *) blk.
AddBlockPromise m blk -> STM m (Point blk)
ChainDB.blockProcessed AddBlockPromise m blk
result

        -- Check whether we adopted our block
        Bool -> WithEarlyExit m () -> WithEarlyExit m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Point blk
curTip Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
/= blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint blk
newBlock) (WithEarlyExit m () -> WithEarlyExit m ())
-> WithEarlyExit m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ do
          Maybe (InvalidBlockReason blk)
isInvalid <- m (Maybe (InvalidBlockReason blk))
-> WithEarlyExit m (Maybe (InvalidBlockReason blk))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe (InvalidBlockReason blk))
 -> WithEarlyExit m (Maybe (InvalidBlockReason blk)))
-> m (Maybe (InvalidBlockReason blk))
-> WithEarlyExit m (Maybe (InvalidBlockReason blk))
forall a b. (a -> b) -> a -> b
$ STM m (Maybe (InvalidBlockReason blk))
-> m (Maybe (InvalidBlockReason blk))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (InvalidBlockReason blk))
 -> m (Maybe (InvalidBlockReason blk)))
-> STM m (Maybe (InvalidBlockReason blk))
-> m (Maybe (InvalidBlockReason blk))
forall a b. (a -> b) -> a -> b
$
            ((HeaderHash blk -> Maybe (InvalidBlockReason blk))
-> HeaderHash blk -> Maybe (InvalidBlockReason blk)
forall a b. (a -> b) -> a -> b
$ blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
newBlock) ((HeaderHash blk -> Maybe (InvalidBlockReason blk))
 -> Maybe (InvalidBlockReason blk))
-> (WithFingerprint
      (HeaderHash blk -> Maybe (InvalidBlockReason blk))
    -> HeaderHash blk -> Maybe (InvalidBlockReason blk))
-> WithFingerprint
     (HeaderHash blk -> Maybe (InvalidBlockReason blk))
-> Maybe (InvalidBlockReason blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))
-> HeaderHash blk -> Maybe (InvalidBlockReason blk)
forall a. WithFingerprint a -> a
forgetFingerprint (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))
 -> Maybe (InvalidBlockReason blk))
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (InvalidBlockReason blk)))
-> STM m (Maybe (InvalidBlockReason blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            ChainDB m blk
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (InvalidBlockReason blk)))
forall (m :: * -> *) blk.
ChainDB m blk
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (InvalidBlockReason blk)))
ChainDB.getIsInvalidBlock ChainDB m blk
chainDB
          case Maybe (InvalidBlockReason blk)
isInvalid of
            Maybe (InvalidBlockReason 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 InvalidBlockReason 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 -> InvalidBlockReason blk -> TraceForgeEvent blk
forall blk.
SlotNo -> blk -> InvalidBlockReason blk -> TraceForgeEvent blk
TraceForgedInvalidBlock SlotNo
currentSlot blk
newBlock InvalidBlockReason 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.
              m () -> WithEarlyExit m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithEarlyExit m ()) -> m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ Mempool m blk TicketNo -> [GenTxId blk] -> m ()
forall (m :: * -> *) blk idx.
Mempool m blk idx -> [GenTxId blk] -> m ()
removeTxs Mempool m blk TicketNo
mempool ((GenTx blk -> GenTxId blk) -> [GenTx blk] -> [GenTxId blk]
forall a b. (a -> b) -> [a] -> [b]
map GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId [GenTx blk]
txs)
          WithEarlyExit m ()
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly

        -- We successfully produced /and/ adopted a block
        TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> blk -> [GenTx blk] -> TraceForgeEvent blk
forall blk. SlotNo -> blk -> [GenTx blk] -> TraceForgeEvent blk
TraceAdoptedBlock SlotNo
currentSlot blk
newBlock [GenTx blk]
txs

    trace :: TraceForgeEvent blk -> WithEarlyExit m ()
    trace :: TraceForgeEvent blk -> WithEarlyExit m ()
trace =
          m () -> WithEarlyExit m ()
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. Tracer m a -> a -> m ()
traceWith (Tracers m remotePeer localPeer blk
-> Tracer m (TraceLabelCreds (TraceForgeEvent blk))
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceLabelCreds (TraceForgeEvent blk))
forgeTracer Tracers m remotePeer localPeer blk
tracers)
        (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)

    -- Compute maximum block transaction capacity
    --
    -- We allow the override to /reduce/ the maximum size, but not increase
    -- it. This is important because any blocks exceeding the max block size
    -- are invalid according to the ledger and we want certainly don't want to
    -- forge invalid blocks.
    computeMaxTxCapacity :: TickedLedgerState blk -> Word32
    computeMaxTxCapacity :: Ticked (LedgerState blk) -> SizeInBytes
computeMaxTxCapacity Ticked (LedgerState blk)
ledger = case MaxTxCapacityOverride
maxTxCapacityOverride of
          MaxTxCapacityOverride
NoMaxTxCapacityOverride     -> SizeInBytes
noOverride
          MaxTxCapacityOverride SizeInBytes
txCap -> SizeInBytes
noOverride SizeInBytes -> SizeInBytes -> SizeInBytes
forall a. Ord a => a -> a -> a
`min` SizeInBytes
txCap
      where
        noOverride :: SizeInBytes
noOverride = Ticked (LedgerState blk) -> SizeInBytes
forall blk.
LedgerSupportsMempool blk =>
TickedLedgerState blk -> SizeInBytes
maxTxCapacity Ticked (LedgerState blk)
ledger

-- | Context required to forge a block
data BlockContext blk = BlockContext
  { BlockContext blk -> BlockNo
bcBlockNo   :: !BlockNo
    -- ^ the block number of the block to be forged
  , 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.
  }

-- | Create the 'BlockContext' from the header of the previous block
blockContextFromPrevHeader ::
     HasHeader (Header blk)
  => Header blk -> BlockContext blk
blockContextFromPrevHeader :: 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
  => SlotNo
     -- ^ the current slot, i.e. the slot of the block about to be forged
  -> AnchoredFragment (Header blk)
     -- ^ the current chain fragment
     --
     -- Recall that the anchor point is the tip of the ImmutableDB.
  -> Either (TraceForgeEvent blk) (BlockContext blk)
     -- ^ the event records the cause of the failure
mkCurrentBlockContext :: 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
expectedFirstBlockNo (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)) Point blk
forall block. 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 block. 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 does not adopt future blocks, 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 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/input-output-hk/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 b b'.
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'

{-------------------------------------------------------------------------------
  TxSubmission integration
-------------------------------------------------------------------------------}

getMempoolReader
  :: forall m blk. (IOLike m, HasTxId (GenTx blk))
  => Mempool m blk TicketNo
  -> TxSubmissionMempoolReader (GenTxId blk) (GenTx blk) TicketNo m
getMempoolReader :: Mempool m blk TicketNo
-> TxSubmissionMempoolReader (GenTxId blk) (GenTx blk) TicketNo m
getMempoolReader Mempool m blk TicketNo
mempool = TxSubmissionMempoolReader :: forall txid tx idx (m :: * -> *).
STM m (MempoolSnapshot txid tx idx)
-> idx -> TxSubmissionMempoolReader txid tx idx m
MempoolReader.TxSubmissionMempoolReader
    { mempoolZeroIdx :: TicketNo
mempoolZeroIdx     = Mempool m blk TicketNo -> TicketNo
forall (m :: * -> *) blk idx. Mempool m blk idx -> idx
zeroIdx Mempool m blk TicketNo
mempool
    , mempoolGetSnapshot :: STM m (MempoolSnapshot (GenTxId blk) (GenTx blk) TicketNo)
mempoolGetSnapshot = MempoolSnapshot blk TicketNo
-> MempoolSnapshot (GenTxId blk) (GenTx blk) TicketNo
convertSnapshot (MempoolSnapshot blk TicketNo
 -> MempoolSnapshot (GenTxId blk) (GenTx blk) TicketNo)
-> STM m (MempoolSnapshot blk TicketNo)
-> STM m (MempoolSnapshot (GenTxId blk) (GenTx blk) TicketNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mempool m blk TicketNo -> STM m (MempoolSnapshot blk TicketNo)
forall (m :: * -> *) blk idx.
Mempool m blk idx -> STM m (MempoolSnapshot blk idx)
getSnapshot Mempool m blk TicketNo
mempool
    }
  where
    convertSnapshot
      :: MempoolSnapshot               blk                       TicketNo
      -> MempoolReader.MempoolSnapshot (GenTxId blk) (GenTx blk) TicketNo
    convertSnapshot :: MempoolSnapshot blk TicketNo
-> MempoolSnapshot (GenTxId blk) (GenTx blk) TicketNo
convertSnapshot MempoolSnapshot { TicketNo -> [(GenTx blk, TicketNo)]
snapshotTxsAfter :: forall blk idx.
MempoolSnapshot blk idx -> idx -> [(GenTx blk, idx)]
snapshotTxsAfter :: TicketNo -> [(GenTx blk, TicketNo)]
snapshotTxsAfter, TicketNo -> Maybe (GenTx blk)
snapshotLookupTx :: forall blk idx. MempoolSnapshot blk idx -> idx -> Maybe (GenTx blk)
snapshotLookupTx :: TicketNo -> Maybe (GenTx blk)
snapshotLookupTx,
                                      GenTxId blk -> Bool
snapshotHasTx :: forall blk idx. MempoolSnapshot blk idx -> GenTxId blk -> Bool
snapshotHasTx :: GenTxId blk -> Bool
snapshotHasTx } =
      MempoolSnapshot :: forall txid tx idx.
(idx -> [(txid, idx, SizeInBytes)])
-> (idx -> Maybe tx)
-> (txid -> Bool)
-> MempoolSnapshot txid tx idx
MempoolReader.MempoolSnapshot
        { mempoolTxIdsAfter :: TicketNo -> [(GenTxId blk, TicketNo, SizeInBytes)]
mempoolTxIdsAfter = \TicketNo
idx ->
            [ (GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId GenTx blk
tx, TicketNo
idx', Mempool m blk TicketNo -> GenTx blk -> SizeInBytes
forall (m :: * -> *) blk idx.
Mempool m blk idx -> GenTx blk -> SizeInBytes
getTxSize Mempool m blk TicketNo
mempool GenTx blk
tx)
            | (GenTx blk
tx, TicketNo
idx') <- TicketNo -> [(GenTx blk, TicketNo)]
snapshotTxsAfter TicketNo
idx
            ]
        , mempoolLookupTx :: TicketNo -> Maybe (GenTx blk)
mempoolLookupTx   = TicketNo -> Maybe (GenTx blk)
snapshotLookupTx
        , mempoolHasTx :: GenTxId blk -> Bool
mempoolHasTx      = GenTxId blk -> Bool
snapshotHasTx
        }

getMempoolWriter
  :: (IOLike m, HasTxId (GenTx blk))
  => Mempool m blk TicketNo
  -> TxSubmissionMempoolWriter (GenTxId blk) (GenTx blk) TicketNo m
getMempoolWriter :: Mempool m blk TicketNo
-> TxSubmissionMempoolWriter (GenTxId blk) (GenTx blk) TicketNo m
getMempoolWriter Mempool m blk TicketNo
mempool = TxSubmissionMempoolWriter :: forall txid tx idx (m :: * -> *).
(tx -> txid)
-> ([tx] -> m [txid]) -> TxSubmissionMempoolWriter txid tx idx m
Inbound.TxSubmissionMempoolWriter
    { txId :: GenTx blk -> GenTxId blk
Inbound.txId          = GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId
    , mempoolAddTxs :: [GenTx blk] -> m [GenTxId blk]
mempoolAddTxs = \[GenTx blk]
txs ->
        ((GenTx blk, MempoolAddTxResult blk) -> GenTxId blk)
-> [(GenTx blk, MempoolAddTxResult blk)] -> [GenTxId blk]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId (GenTx blk -> GenTxId blk)
-> ((GenTx blk, MempoolAddTxResult blk) -> GenTx blk)
-> (GenTx blk, MempoolAddTxResult blk)
-> GenTxId blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenTx blk, MempoolAddTxResult blk) -> GenTx blk
forall a b. (a, b) -> a
fst) ([(GenTx blk, MempoolAddTxResult blk)] -> [GenTxId blk])
-> ([(GenTx blk, MempoolAddTxResult blk)]
    -> [(GenTx blk, MempoolAddTxResult blk)])
-> [(GenTx blk, MempoolAddTxResult blk)]
-> [GenTxId blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((GenTx blk, MempoolAddTxResult blk) -> Bool)
-> [(GenTx blk, MempoolAddTxResult blk)]
-> [(GenTx blk, MempoolAddTxResult blk)]
forall a. (a -> Bool) -> [a] -> [a]
filter (MempoolAddTxResult blk -> Bool
forall blk. MempoolAddTxResult blk -> Bool
isMempoolTxAdded (MempoolAddTxResult blk -> Bool)
-> ((GenTx blk, MempoolAddTxResult blk) -> MempoolAddTxResult blk)
-> (GenTx blk, MempoolAddTxResult blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenTx blk, MempoolAddTxResult blk) -> MempoolAddTxResult blk
forall a b. (a, b) -> b
snd) ([(GenTx blk, MempoolAddTxResult blk)] -> [GenTxId blk])
-> m [(GenTx blk, MempoolAddTxResult blk)] -> m [GenTxId blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Mempool m blk TicketNo
-> [GenTx blk] -> m [(GenTx blk, MempoolAddTxResult blk)]
forall (m :: * -> *) blk idx.
MonadSTM m =>
Mempool m blk idx
-> [GenTx blk] -> m [(GenTx blk, MempoolAddTxResult blk)]
addTxs Mempool m blk TicketNo
mempool [GenTx blk]
txs
    }