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

module Ouroboros.Consensus.NodeKernel
  ( -- * Node kernel
    MempoolCapacityBytesOverride (..)
  , NodeKernel (..)
  , NodeKernelArgs (..)
  , TraceForgeEvent (..)
  , getImmTipSlot
  , getMempoolReader
  , getMempoolWriter
  , getPeersFromCurrentLedger
  , getPeersFromCurrentLedgerAfterSlot
  , initNodeKernel
  ) where

import Cardano.Network.ConsensusMode (ConsensusMode (..))
import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers)
import Cardano.Network.PeerSelection.LocalRootPeers
  ( OutboundConnectionsState (..)
  )
import Cardano.Network.Types (LedgerStateJudgement (..))
import qualified Control.Concurrent.Class.MonadSTM as LazySTM
import qualified Control.Concurrent.Class.MonadSTM.Strict as StrictSTM
import Control.DeepSeq (force)
import Control.Monad
import qualified Control.Monad.Class.MonadTimer.SI as SI
import Control.Monad.Except
import Control.ResourceRegistry
import Control.Tracer
import Data.Bifunctor (second)
import Data.Data (Typeable)
import Data.Foldable (traverse_)
import Data.Function (on)
import Data.Functor ((<&>))
import Data.Hashable (Hashable)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust, mapMaybe)
import Data.Proxy
import qualified Data.Text as Text
import Data.Void (Void)
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.Genesis.Governor (gddWatcher)
import Ouroboros.Consensus.HeaderValidation
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.Ledger.SupportsPeerSelection
import Ouroboros.Consensus.Ledger.SupportsProtocol
import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables)
import Ouroboros.Consensus.Mempool
import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client
  ( ChainSyncClientHandle (..)
  , ChainSyncClientHandleCollection (..)
  , ChainSyncState (..)
  , newChainSyncClientHandleCollection
  )
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck
  ( HistoricityCheck
  )
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck
  ( SomeHeaderInFutureCheck
  )
import Ouroboros.Consensus.Node.GSM (GsmNodeKernelArgs (..))
import qualified Ouroboros.Consensus.Node.GSM as GSM
import Ouroboros.Consensus.Node.Genesis
  ( GenesisNodeKernelArgs (..)
  , LoEAndGDDConfig (..)
  , LoEAndGDDNodeKernelArgs (..)
  , setGetLoEFragment
  )
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.ChainDB.Init (InitChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.Init as InitChainDB
import Ouroboros.Consensus.Storage.LedgerDB
import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
import Ouroboros.Consensus.Util (whenJust)
import Ouroboros.Consensus.Util.AnchoredFragment
  ( preferAnchoredCandidate
  )
import Ouroboros.Consensus.Util.EarlyExit
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.LeakyBucket
  ( atomicallyWithMonotonicTime
  )
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.Block (castTip, tipFromHeader)
import Ouroboros.Network.BlockFetch
import Ouroboros.Network.BlockFetch.ClientState
  ( mapTraceFetchClientState
  )
import Ouroboros.Network.BlockFetch.Decision.Trace
  ( TraceDecisionEvent (..)
  )
import Ouroboros.Network.NodeToNode
  ( ConnectionId
  , MiniProtocolParameters (..)
  )
import Ouroboros.Network.PeerSelection.Governor.Types
  ( PublicPeerSelectionState
  )
import Ouroboros.Network.PeerSharing
  ( PeerSharingAPI
  , PeerSharingRegistry
  , newPeerSharingAPI
  , newPeerSharingRegistry
  , ps_POLICY_PEER_SHARE_MAX_PEERS
  , ps_POLICY_PEER_SHARE_STICKY_TIME
  )
import Ouroboros.Network.Protocol.LocalStateQuery.Type (Target (..))
import Ouroboros.Network.SizeInBytes
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 System.Random (StdGen)

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

-- | Interface against running relay node
data NodeKernel m addrNTN addrNTC blk = NodeKernel
  { forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
getChainDB :: ChainDB m blk
  -- ^ The 'ChainDB' of the node
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> Mempool m blk
getMempool :: Mempool m blk
  -- ^ The node's mempool
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> TopLevelConfig blk
getTopLevelConfig :: TopLevelConfig blk
  -- ^ The node's top-level static configuration
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk
-> FetchClientRegistry
     (ConnectionId addrNTN) (HeaderWithTime blk) blk m
getFetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk m
  -- ^ The fetch client registry, used for the block fetch clients.
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> STM m FetchMode
getFetchMode :: STM m FetchMode
  -- ^ The fetch mode, used by diffusion.
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> STM m GsmState
getGsmState :: STM m GSM.GsmState
  -- ^ The GSM state, used by diffusion. A ledger judgement can be derived
  -- from it with 'GSM.gsmStateToLedgerJudgement'.
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk
-> ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk
getChainSyncHandles :: ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk
  -- ^ The kill handle and exposed state for each ChainSync client.
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> PeerSharingRegistry addrNTN m
getPeerSharingRegistry :: PeerSharingRegistry addrNTN m
  -- ^ Read the current peer sharing registry, used for interacting with
  -- the PeerSharing protocol
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
getTracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
  -- ^ The node's tracers
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> [BlockForging m blk] -> m ()
setBlockForging :: [BlockForging m blk] -> m ()
  -- ^ Set block forging
  --
  -- When set with the empty list '[]' block forging will be disabled.
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> PeerSharingAPI addrNTN StdGen m
getPeerSharingAPI :: PeerSharingAPI addrNTN StdGen m
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk
-> StrictTVar m OutboundConnectionsState
getOutboundConnectionsState ::
      StrictTVar m OutboundConnectionsState
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> DiffusionPipeliningSupport
getDiffusionPipeliningSupport ::
      DiffusionPipeliningSupport
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> BlockchainTime m
getBlockchainTime :: BlockchainTime m
  }

-- | Arguments required when initializing a node
data NodeKernelArgs m addrNTN addrNTC blk = NodeKernelArgs
  { forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ResourceRegistry m
registry :: ResourceRegistry m
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockchainTime m
btime :: BlockchainTime m
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ChainDB m blk
chainDB :: ChainDB m blk
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB :: StorageConfig blk -> InitChainDB m blk -> m ()
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> SomeHeaderInFutureCheck m blk
chainSyncFutureCheck :: SomeHeaderInFutureCheck m blk
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> m GsmState -> HistoricityCheck m blk
chainSyncHistoricityCheck ::
      m GSM.GsmState ->
      HistoricityCheck m blk
  -- ^ See 'HistoricityCheck' for details.
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> Header blk -> SizeInBytes
blockFetchSize :: Header blk -> SizeInBytes
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> MempoolCapacityBytesOverride
mempoolCapacityOverride :: MempoolCapacityBytesOverride
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> MiniProtocolParameters
miniProtocolParameters :: MiniProtocolParameters
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockFetchConfiguration
blockFetchConfiguration :: BlockFetchConfiguration
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> StdGen
keepAliveRng :: StdGen
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GsmNodeKernelArgs m blk
gsmArgs :: GsmNodeKernelArgs m blk
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> STM m UseBootstrapPeers
getUseBootstrapPeers :: STM m UseBootstrapPeers
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> StdGen
peerSharingRng :: StdGen
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar ::
      StrictSTM.StrictTVar m (PublicPeerSelectionState addrNTN)
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GenesisNodeKernelArgs m blk
genesisArgs :: GenesisNodeKernelArgs m blk
  , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: DiffusionPipeliningSupport
  }

initNodeKernel ::
  forall m addrNTN addrNTC blk.
  ( IOLike m
  , SI.MonadTimer m
  , RunNode blk
  , Ord addrNTN
  , Hashable addrNTN
  , Typeable addrNTN
  ) =>
  NodeKernelArgs m addrNTN addrNTC blk ->
  m (NodeKernel m addrNTN addrNTC blk)
initNodeKernel :: forall (m :: * -> *) addrNTN addrNTC blk.
(IOLike m, MonadTimer m, RunNode blk, Ord addrNTN,
 Hashable addrNTN, Typeable addrNTN) =>
NodeKernelArgs m addrNTN addrNTC blk
-> m (NodeKernel m addrNTN addrNTC blk)
initNodeKernel
  args :: NodeKernelArgs m addrNTN addrNTC blk
args@NodeKernelArgs
    { ResourceRegistry m
registry :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ResourceRegistry m
registry :: ResourceRegistry m
registry
    , TopLevelConfig blk
cfg :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg
    , Tracers m (ConnectionId addrNTN) addrNTC blk
tracers :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
tracers
    , ChainDB m blk
chainDB :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ChainDB m blk
chainDB :: ChainDB m blk
chainDB
    , StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB :: StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB
    , BlockFetchConfiguration
blockFetchConfiguration :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockFetchConfiguration
blockFetchConfiguration :: BlockFetchConfiguration
blockFetchConfiguration
    , BlockchainTime m
btime :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockchainTime m
btime :: BlockchainTime m
btime
    , GsmNodeKernelArgs m blk
gsmArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GsmNodeKernelArgs m blk
gsmArgs :: GsmNodeKernelArgs m blk
gsmArgs
    , StdGen
peerSharingRng :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> StdGen
peerSharingRng :: StdGen
peerSharingRng
    , StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar :: StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar
    , GenesisNodeKernelArgs m blk
genesisArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GenesisNodeKernelArgs m blk
genesisArgs :: GenesisNodeKernelArgs m blk
genesisArgs
    , DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: DiffusionPipeliningSupport
getDiffusionPipeliningSupport
    } = do
    -- using a lazy 'TVar', 'BlockForging' does not have a 'NoThunks' instance.
    blockForgingVar :: LazySTM.TMVar m [BlockForging m blk] <- [BlockForging m blk] -> m (TMVar m [BlockForging m blk])
forall a. a -> m (TMVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TMVar m a)
LazySTM.newTMVarIO []
    initChainDB (configStorage cfg) (InitChainDB.fromFull chainDB)

    st <- initInternalState args
    let IS
          { blockFetchInterface
          , fetchClientRegistry
          , mempool
          , peerSharingRegistry
          , varChainSyncHandles
          , varGsmState
          } = st

    varOutboundConnectionsState <- newTVarIO UntrustedState

    do
      let GsmNodeKernelArgs{..} = gsmArgs
          gsmTracerArgs =
            ( Tip (HeaderWithTime blk) -> Tip blk
forall {k1} {k2} (a :: k1) (b :: k2).
(HeaderHash a ~ HeaderHash b) =>
Tip a -> Tip b
castTip (Tip (HeaderWithTime blk) -> Tip blk)
-> ((AnchoredSeq
       (WithOrigin SlotNo)
       (Anchor (HeaderWithTime blk))
       (HeaderWithTime blk),
     LedgerState blk EmptyMK)
    -> Tip (HeaderWithTime blk))
-> (AnchoredSeq
      (WithOrigin SlotNo)
      (Anchor (HeaderWithTime blk))
      (HeaderWithTime blk),
    LedgerState blk EmptyMK)
-> Tip blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Anchor (HeaderWithTime blk) -> Tip (HeaderWithTime blk))
-> (HeaderWithTime blk -> Tip (HeaderWithTime blk))
-> Either (Anchor (HeaderWithTime blk)) (HeaderWithTime blk)
-> Tip (HeaderWithTime blk)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Anchor (HeaderWithTime blk) -> Tip (HeaderWithTime blk)
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Tip b
AF.anchorToTip HeaderWithTime blk -> Tip (HeaderWithTime blk)
forall a. HasHeader a => a -> Tip a
tipFromHeader (Either (Anchor (HeaderWithTime blk)) (HeaderWithTime blk)
 -> Tip (HeaderWithTime blk))
-> ((AnchoredSeq
       (WithOrigin SlotNo)
       (Anchor (HeaderWithTime blk))
       (HeaderWithTime blk),
     LedgerState blk EmptyMK)
    -> Either (Anchor (HeaderWithTime blk)) (HeaderWithTime blk))
-> (AnchoredSeq
      (WithOrigin SlotNo)
      (Anchor (HeaderWithTime blk))
      (HeaderWithTime blk),
    LedgerState blk EmptyMK)
-> Tip (HeaderWithTime blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
-> Either (Anchor (HeaderWithTime blk)) (HeaderWithTime blk)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.head (AnchoredSeq
   (WithOrigin SlotNo)
   (Anchor (HeaderWithTime blk))
   (HeaderWithTime blk)
 -> Either (Anchor (HeaderWithTime blk)) (HeaderWithTime blk))
-> ((AnchoredSeq
       (WithOrigin SlotNo)
       (Anchor (HeaderWithTime blk))
       (HeaderWithTime blk),
     LedgerState blk EmptyMK)
    -> AnchoredSeq
         (WithOrigin SlotNo)
         (Anchor (HeaderWithTime blk))
         (HeaderWithTime blk))
-> (AnchoredSeq
      (WithOrigin SlotNo)
      (Anchor (HeaderWithTime blk))
      (HeaderWithTime blk),
    LedgerState blk EmptyMK)
-> Either (Anchor (HeaderWithTime blk)) (HeaderWithTime blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredSeq
   (WithOrigin SlotNo)
   (Anchor (HeaderWithTime blk))
   (HeaderWithTime blk),
 LedgerState blk EmptyMK)
-> AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk)
forall a b. (a, b) -> a
fst
            , Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer m (TraceGsmEvent (Tip blk))
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f -> f (TraceGsmEvent (Tip blk))
gsmTracer Tracers m (ConnectionId addrNTN) addrNTC blk
tracers
            )

      let gsm =
            ((AnchoredSeq
    (WithOrigin SlotNo)
    (Anchor (HeaderWithTime blk))
    (HeaderWithTime blk),
  LedgerState blk EmptyMK)
 -> Tip blk,
 Tracer m (TraceGsmEvent (Tip blk)))
-> GsmView
     m
     (ConnectionId addrNTN)
     (AnchoredSeq
        (WithOrigin SlotNo)
        (Anchor (HeaderWithTime blk))
        (HeaderWithTime blk),
      LedgerState blk EmptyMK)
     (ChainSyncState blk)
-> GsmEntryPoints m
forall (m :: * -> *) upstreamPeer selection tracedSelection
       candidate.
(MonadDelay m, MonadTimer m) =>
(selection -> tracedSelection,
 Tracer m (TraceGsmEvent tracedSelection))
-> GsmView m upstreamPeer selection candidate -> GsmEntryPoints m
GSM.realGsmEntryPoints
              ((AnchoredSeq
    (WithOrigin SlotNo)
    (Anchor (HeaderWithTime blk))
    (HeaderWithTime blk),
  LedgerState blk EmptyMK)
 -> Tip blk,
 Tracer m (TraceGsmEvent (Tip blk)))
gsmTracerArgs
              GSM.GsmView
                { antiThunderingHerd :: Maybe StdGen
GSM.antiThunderingHerd = StdGen -> Maybe StdGen
forall a. a -> Maybe a
Just StdGen
gsmAntiThunderingHerd
                , candidateOverSelection :: (AnchoredSeq
   (WithOrigin SlotNo)
   (Anchor (HeaderWithTime blk))
   (HeaderWithTime blk),
 LedgerState blk EmptyMK)
-> ChainSyncState blk -> CandidateVersusSelection
GSM.candidateOverSelection = \(AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
headers, LedgerState blk EmptyMK
_lst) ChainSyncState blk
state ->
                    case AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
-> AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk)
-> Maybe (Point (HeaderWithTime blk))
forall block1 block2.
(HasHeader block1, HasHeader block2,
 HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2 -> Maybe (Point block1)
AF.intersectionPoint AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
headers (ChainSyncState blk
-> AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk)
forall blk.
ChainSyncState blk -> AnchoredFragment (HeaderWithTime blk)
csCandidate ChainSyncState blk
state) of
                      Maybe (Point (HeaderWithTime blk))
Nothing -> CandidateVersusSelection
GSM.CandidateDoesNotIntersect
                      Just{} ->
                        Bool -> CandidateVersusSelection
GSM.WhetherCandidateIsBetter (Bool -> CandidateVersusSelection)
-> Bool -> CandidateVersusSelection
forall a b. (a -> b) -> a -> b
$ -- precondition requires intersection
                          BlockConfig blk
-> AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk)
-> AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk)
-> Bool
forall blk (h :: * -> *) (h' :: * -> *).
(BlockSupportsProtocol blk, HasCallStack, GetHeader1 h,
 GetHeader1 h', HeaderHash (h blk) ~ HeaderHash (h' blk),
 HasHeader (h blk), HasHeader (h' blk)) =>
BlockConfig blk
-> AnchoredFragment (h blk) -> AnchoredFragment (h' blk) -> Bool
preferAnchoredCandidate
                            (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg)
                            AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
headers
                            (ChainSyncState blk
-> AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk)
forall blk.
ChainSyncState blk -> AnchoredFragment (HeaderWithTime blk)
csCandidate ChainSyncState blk
state)
                , peerIsIdle :: ChainSyncState blk -> Bool
GSM.peerIsIdle = ChainSyncState blk -> Bool
forall blk. ChainSyncState blk -> Bool
csIdling
                , durationUntilTooOld :: Maybe
  ((AnchoredSeq
      (WithOrigin SlotNo)
      (Anchor (HeaderWithTime blk))
      (HeaderWithTime blk),
    LedgerState blk EmptyMK)
   -> m DurationFromNow)
GSM.durationUntilTooOld =
                    Maybe (WrapDurationUntilTooOld m blk)
gsmDurationUntilTooOld
                      Maybe (WrapDurationUntilTooOld m blk)
-> (WrapDurationUntilTooOld m blk
    -> (AnchoredSeq
          (WithOrigin SlotNo)
          (Anchor (HeaderWithTime blk))
          (HeaderWithTime blk),
        LedgerState blk EmptyMK)
    -> m DurationFromNow)
-> Maybe
     ((AnchoredSeq
         (WithOrigin SlotNo)
         (Anchor (HeaderWithTime blk))
         (HeaderWithTime blk),
       LedgerState blk EmptyMK)
      -> m DurationFromNow)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \WrapDurationUntilTooOld m blk
wd (AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
_headers, LedgerState blk EmptyMK
lst) ->
                        WrapDurationUntilTooOld m blk
-> WithOrigin SlotNo -> m DurationFromNow
forall (m :: * -> *) blk.
WrapDurationUntilTooOld m blk
-> WithOrigin SlotNo -> m DurationFromNow
GSM.getDurationUntilTooOld WrapDurationUntilTooOld m blk
wd (LedgerState blk EmptyMK -> WithOrigin SlotNo
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot LedgerState blk EmptyMK
lst)
                , equivalent :: (AnchoredSeq
   (WithOrigin SlotNo)
   (Anchor (HeaderWithTime blk))
   (HeaderWithTime blk),
 LedgerState blk EmptyMK)
-> (AnchoredSeq
      (WithOrigin SlotNo)
      (Anchor (HeaderWithTime blk))
      (HeaderWithTime blk),
    LedgerState blk EmptyMK)
-> Bool
GSM.equivalent = Point (HeaderWithTime blk) -> Point (HeaderWithTime blk) -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Point (HeaderWithTime blk) -> Point (HeaderWithTime blk) -> Bool)
-> ((AnchoredSeq
       (WithOrigin SlotNo)
       (Anchor (HeaderWithTime blk))
       (HeaderWithTime blk),
     LedgerState blk EmptyMK)
    -> Point (HeaderWithTime blk))
-> (AnchoredSeq
      (WithOrigin SlotNo)
      (Anchor (HeaderWithTime blk))
      (HeaderWithTime blk),
    LedgerState blk EmptyMK)
-> (AnchoredSeq
      (WithOrigin SlotNo)
      (Anchor (HeaderWithTime blk))
      (HeaderWithTime blk),
    LedgerState blk EmptyMK)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
-> Point (HeaderWithTime blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredSeq
   (WithOrigin SlotNo)
   (Anchor (HeaderWithTime blk))
   (HeaderWithTime blk)
 -> Point (HeaderWithTime blk))
-> ((AnchoredSeq
       (WithOrigin SlotNo)
       (Anchor (HeaderWithTime blk))
       (HeaderWithTime blk),
     LedgerState blk EmptyMK)
    -> AnchoredSeq
         (WithOrigin SlotNo)
         (Anchor (HeaderWithTime blk))
         (HeaderWithTime blk))
-> (AnchoredSeq
      (WithOrigin SlotNo)
      (Anchor (HeaderWithTime blk))
      (HeaderWithTime blk),
    LedgerState blk EmptyMK)
-> Point (HeaderWithTime blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredSeq
   (WithOrigin SlotNo)
   (Anchor (HeaderWithTime blk))
   (HeaderWithTime blk),
 LedgerState blk EmptyMK)
-> AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk)
forall a b. (a, b) -> a
fst)
                , getChainSyncStates :: STM
  m (Map (ConnectionId addrNTN) (StrictTVar m (ChainSyncState blk)))
GSM.getChainSyncStates = (ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk))
-> Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)
-> Map (ConnectionId addrNTN) (StrictTVar m (ChainSyncState blk))
forall a b.
(a -> b)
-> Map (ConnectionId addrNTN) a -> Map (ConnectionId addrNTN) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk)
cschState (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)
 -> Map (ConnectionId addrNTN) (StrictTVar m (ChainSyncState blk)))
-> STM m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
-> STM
     m (Map (ConnectionId addrNTN) (StrictTVar m (ChainSyncState blk)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk
-> STM m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
forall peer (m :: * -> *) blk.
ChainSyncClientHandleCollection peer m blk
-> STM m (Map peer (ChainSyncClientHandle m blk))
cschcMap ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk
varChainSyncHandles
                , getCurrentSelection :: STM
  m
  (AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk),
   LedgerState blk EmptyMK)
GSM.getCurrentSelection = do
                    headers <- ChainDB m blk
-> STM
     m
     (AnchoredSeq
        (WithOrigin SlotNo)
        (Anchor (HeaderWithTime blk))
        (HeaderWithTime blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (HeaderWithTime blk))
ChainDB.getCurrentChainWithTime ChainDB m blk
chainDB
                    extLedgerState <- ChainDB.getCurrentLedger chainDB
                    return (headers, ledgerState extLedgerState)
                , minCaughtUpDuration :: NominalDiffTime
GSM.minCaughtUpDuration = NominalDiffTime
gsmMinCaughtUpDuration
                , setCaughtUpPersistentMark :: Bool -> m ()
GSM.setCaughtUpPersistentMark = \Bool
upd ->
                    (if Bool
upd then MarkerFileView m -> m ()
forall (m :: * -> *). MarkerFileView m -> m ()
GSM.touchMarkerFile else MarkerFileView m -> m ()
forall (m :: * -> *). MarkerFileView m -> m ()
GSM.removeMarkerFile)
                      MarkerFileView m
gsmMarkerFileView
                , writeGsmState :: GsmState -> m ()
GSM.writeGsmState = \GsmState
gsmState ->
                    (Time -> STM m ()) -> m ()
forall (m :: * -> *) b.
(MonadMonotonicTime m, MonadSTM m) =>
(Time -> STM m b) -> m b
atomicallyWithMonotonicTime ((Time -> STM m ()) -> m ()) -> (Time -> STM m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Time
time -> do
                      StrictTVar m GsmState -> GsmState -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m GsmState
varGsmState GsmState
gsmState
                      handles <- ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk
-> STM m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
forall peer (m :: * -> *) blk.
ChainSyncClientHandleCollection peer m blk
-> STM m (Map peer (ChainSyncClientHandle m blk))
cschcMap ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk
varChainSyncHandles
                      traverse_ (($ time) . ($ gsmState) . cschOnGsmStateChanged) handles
                , isHaaSatisfied :: STM m Bool
GSM.isHaaSatisfied = do
                    StrictTVar m OutboundConnectionsState
-> STM m OutboundConnectionsState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m OutboundConnectionsState
varOutboundConnectionsState STM m OutboundConnectionsState
-> (OutboundConnectionsState -> Bool) -> STM m Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                      -- See the upstream Haddocks for the exact conditions under
                      -- which the diffusion layer is in this state.
                      OutboundConnectionsState
TrustedStateWithExternalPeers -> Bool
True
                      OutboundConnectionsState
UntrustedState -> Bool
False
                }
      judgment <- GSM.gsmStateToLedgerJudgement <$> readTVarIO varGsmState
      void $ forkLinkedThread registry "NodeKernel.GSM" $ case judgment of
        LedgerStateJudgement
TooOld -> GsmEntryPoints m -> forall neverTerminates. m neverTerminates
forall (m :: * -> *).
GsmEntryPoints m -> forall neverTerminates. m neverTerminates
GSM.enterPreSyncing GsmEntryPoints m
gsm
        LedgerStateJudgement
YoungEnough -> GsmEntryPoints m -> forall neverTerminates. m neverTerminates
forall (m :: * -> *).
GsmEntryPoints m -> forall neverTerminates. m neverTerminates
GSM.enterCaughtUp GsmEntryPoints m
gsm

    peerSharingAPI <-
      newPeerSharingAPI
        publicPeerSelectionStateVar
        peerSharingRng
        ps_POLICY_PEER_SHARE_STICKY_TIME
        ps_POLICY_PEER_SHARE_MAX_PEERS

    case gnkaLoEAndGDDArgs genesisArgs of
      LoEAndGDDConfig (LoEAndGDDNodeKernelArgs m blk)
LoEAndGDDDisabled -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      LoEAndGDDEnabled LoEAndGDDNodeKernelArgs m blk
lgArgs -> do
        varLoEFragment <- AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
-> m (StrictTVar
        m
        (AnchoredSeq
           (WithOrigin SlotNo)
           (Anchor (HeaderWithTime blk))
           (HeaderWithTime blk)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (AnchoredSeq
   (WithOrigin SlotNo)
   (Anchor (HeaderWithTime blk))
   (HeaderWithTime blk)
 -> m (StrictTVar
         m
         (AnchoredSeq
            (WithOrigin SlotNo)
            (Anchor (HeaderWithTime blk))
            (HeaderWithTime blk))))
-> AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk)
-> m (StrictTVar
        m
        (AnchoredSeq
           (WithOrigin SlotNo)
           (Anchor (HeaderWithTime blk))
           (HeaderWithTime blk)))
forall a b. (a -> b) -> a -> b
$ Anchor (HeaderWithTime blk)
-> AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (HeaderWithTime blk))
     (HeaderWithTime blk)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (HeaderWithTime blk)
forall block. Anchor block
AF.AnchorGenesis
        setGetLoEFragment
          (readTVar varGsmState)
          (readTVar varLoEFragment)
          (lgnkaLoEFragmentTVar lgArgs)

        void $
          forkLinkedWatcher registry "NodeKernel.GDD" $
            gddWatcher
              cfg
              (gddTracer tracers)
              chainDB
              (lgnkaGDDRateLimit lgArgs)
              (readTVar varGsmState)
              (cschcMap varChainSyncHandles)
              varLoEFragment

    void $
      forkLinkedThread registry "NodeKernel.blockForging" $
        blockForgingController st (LazySTM.takeTMVar blockForgingVar)

    -- Run the block fetch logic in the background. This will call
    -- 'addFetchedBlock' whenever a new block is downloaded.
    void $
      forkLinkedThread registry "NodeKernel.blockFetchLogic" $
        blockFetchLogic
          (contramap castTraceFetchDecision $ blockFetchDecisionTracer tracers)
          (contramap (fmap castTraceFetchClientState) $ blockFetchClientTracer tracers)
          blockFetchInterface
          fetchClientRegistry
          blockFetchConfiguration

    return
      NodeKernel
        { getChainDB = chainDB
        , getMempool = mempool
        , getTopLevelConfig = cfg
        , getFetchClientRegistry = fetchClientRegistry
        , getFetchMode = readFetchMode blockFetchInterface
        , getGsmState = readTVar varGsmState
        , getChainSyncHandles = varChainSyncHandles
        , getPeerSharingRegistry = peerSharingRegistry
        , getTracers = tracers
        , setBlockForging = \[BlockForging m blk]
a -> STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ())
-> ([BlockForging m blk] -> STM m ())
-> [BlockForging m blk]
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar m [BlockForging m blk] -> [BlockForging m blk] -> STM m ()
forall a. TMVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> a -> STM m ()
LazySTM.putTMVar TMVar m [BlockForging m blk]
blockForgingVar ([BlockForging m blk] -> m ()) -> [BlockForging m blk] -> m ()
forall a b. (a -> b) -> a -> b
$! [BlockForging m blk]
a
        , getPeerSharingAPI = peerSharingAPI
        , getOutboundConnectionsState =
            varOutboundConnectionsState
        , getDiffusionPipeliningSupport
        , getBlockchainTime = btime
        }
   where
    blockForgingController ::
      InternalState m remotePeer localPeer blk ->
      STM m [BlockForging m blk] ->
      m Void
    blockForgingController :: forall remotePeer localPeer.
InternalState m remotePeer localPeer blk
-> STM m [BlockForging m blk] -> m Void
blockForgingController InternalState m remotePeer localPeer blk
st STM m [BlockForging m blk]
getBlockForging = [Thread m Void] -> m Void
go []
     where
      go :: [Thread m Void] -> m Void
      go :: [Thread m Void] -> m Void
go ![Thread m Void]
forgingThreads = do
        blockForging <- STM m [BlockForging m blk] -> m [BlockForging m blk]
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m [BlockForging m blk]
getBlockForging
        traverse_ cancelThread forgingThreads
        blockForging' <- traverse (forkBlockForging st) blockForging
        go blockForging'

castTraceFetchDecision ::
  forall remotePeer blk.
  TraceDecisionEvent remotePeer (HeaderWithTime blk) -> TraceDecisionEvent remotePeer (Header blk)
castTraceFetchDecision :: forall remotePeer blk.
TraceDecisionEvent remotePeer (HeaderWithTime blk)
-> TraceDecisionEvent remotePeer (Header blk)
castTraceFetchDecision = \case
  PeersFetch [TraceLabelPeer
   remotePeer (FetchDecision [Point (HeaderWithTime blk)])]
xs -> [TraceLabelPeer remotePeer (FetchDecision [Point (Header blk)])]
-> TraceDecisionEvent remotePeer (Header blk)
forall peer header.
[TraceLabelPeer peer (FetchDecision [Point header])]
-> TraceDecisionEvent peer header
PeersFetch ((TraceLabelPeer
   remotePeer (FetchDecision [Point (HeaderWithTime blk)])
 -> TraceLabelPeer remotePeer (FetchDecision [Point (Header blk)]))
-> [TraceLabelPeer
      remotePeer (FetchDecision [Point (HeaderWithTime blk)])]
-> [TraceLabelPeer remotePeer (FetchDecision [Point (Header blk)])]
forall a b. (a -> b) -> [a] -> [b]
map ((FetchDecision [Point (HeaderWithTime blk)]
 -> FetchDecision [Point (Header blk)])
-> TraceLabelPeer
     remotePeer (FetchDecision [Point (HeaderWithTime blk)])
-> TraceLabelPeer remotePeer (FetchDecision [Point (Header blk)])
forall a b.
(a -> b)
-> TraceLabelPeer remotePeer a -> TraceLabelPeer remotePeer b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Point (HeaderWithTime blk)] -> [Point (Header blk)])
-> FetchDecision [Point (HeaderWithTime blk)]
-> FetchDecision [Point (Header blk)]
forall b c a. (b -> c) -> Either a b -> Either a c
forall (p :: MapKind) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Point (HeaderWithTime blk) -> Point (Header blk))
-> [Point (HeaderWithTime blk)] -> [Point (Header blk)]
forall a b. (a -> b) -> [a] -> [b]
map Point (HeaderWithTime blk) -> Point (Header blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint))) [TraceLabelPeer
   remotePeer (FetchDecision [Point (HeaderWithTime blk)])]
xs) -- [TraceLabelPeer peer (FetchDecision [Point header])]
  PeerStarvedUs remotePeer
peer -> remotePeer -> TraceDecisionEvent remotePeer (Header blk)
forall peer header. peer -> TraceDecisionEvent peer header
PeerStarvedUs remotePeer
peer

castTraceFetchClientState ::
  forall blk.
  HasHeader (Header blk) =>
  TraceFetchClientState (HeaderWithTime blk) -> TraceFetchClientState (Header blk)
castTraceFetchClientState :: forall blk.
HasHeader (Header blk) =>
TraceFetchClientState (HeaderWithTime blk)
-> TraceFetchClientState (Header blk)
castTraceFetchClientState = (HeaderWithTime blk -> Header blk)
-> TraceFetchClientState (HeaderWithTime blk)
-> TraceFetchClientState (Header blk)
forall h1 h2.
(HeaderHash h1 ~ HeaderHash h2, HasHeader h2) =>
(h1 -> h2) -> TraceFetchClientState h1 -> TraceFetchClientState h2
mapTraceFetchClientState HeaderWithTime blk -> Header blk
forall blk. HeaderWithTime blk -> Header blk
hwtHeader

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

data InternalState m addrNTN addrNTC blk = IS
  { forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
  , forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
  , forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> ResourceRegistry m
registry :: ResourceRegistry m
  , forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> BlockchainTime m
btime :: BlockchainTime m
  , forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> ChainDB m blk
chainDB :: ChainDB m blk
  , forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> BlockFetchConsensusInterface
     (ConnectionId addrNTN) (HeaderWithTime blk) blk m
blockFetchInterface ::
      BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk m
  , forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> FetchClientRegistry
     (ConnectionId addrNTN) (HeaderWithTime blk) blk m
fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk m
  , forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk
varChainSyncHandles :: ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk
  , forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> StrictTVar m GsmState
varGsmState :: StrictTVar m GSM.GsmState
  , forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> Mempool m blk
mempool :: Mempool m blk
  , forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> PeerSharingRegistry addrNTN m
peerSharingRegistry :: PeerSharingRegistry addrNTN m
  }

initInternalState ::
  forall m addrNTN addrNTC blk.
  ( IOLike m
  , Ord addrNTN
  , Typeable addrNTN
  , RunNode blk
  ) =>
  NodeKernelArgs m addrNTN addrNTC blk ->
  m (InternalState m addrNTN addrNTC blk)
initInternalState :: forall (m :: * -> *) addrNTN addrNTC blk.
(IOLike m, Ord addrNTN, Typeable addrNTN, RunNode blk) =>
NodeKernelArgs m addrNTN addrNTC blk
-> m (InternalState m addrNTN addrNTC blk)
initInternalState
  NodeKernelArgs
    { Tracers m (ConnectionId addrNTN) addrNTC blk
tracers :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
tracers
    , ChainDB m blk
chainDB :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ChainDB m blk
chainDB :: ChainDB m blk
chainDB
    , ResourceRegistry m
registry :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ResourceRegistry m
registry :: ResourceRegistry m
registry
    , TopLevelConfig blk
cfg :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg
    , Header blk -> SizeInBytes
blockFetchSize :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> Header blk -> SizeInBytes
blockFetchSize :: Header blk -> SizeInBytes
blockFetchSize
    , BlockchainTime m
btime :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockchainTime m
btime :: BlockchainTime m
btime
    , MempoolCapacityBytesOverride
mempoolCapacityOverride :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> MempoolCapacityBytesOverride
mempoolCapacityOverride :: MempoolCapacityBytesOverride
mempoolCapacityOverride
    , GsmNodeKernelArgs m blk
gsmArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GsmNodeKernelArgs m blk
gsmArgs :: GsmNodeKernelArgs m blk
gsmArgs
    , STM m UseBootstrapPeers
getUseBootstrapPeers :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> STM m UseBootstrapPeers
getUseBootstrapPeers :: STM m UseBootstrapPeers
getUseBootstrapPeers
    , DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: DiffusionPipeliningSupport
getDiffusionPipeliningSupport
    , GenesisNodeKernelArgs m blk
genesisArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GenesisNodeKernelArgs m blk
genesisArgs :: GenesisNodeKernelArgs m blk
genesisArgs
    } = do
    varGsmState <- do
      let GsmNodeKernelArgs{Maybe (WrapDurationUntilTooOld m blk)
StdGen
NominalDiffTime
MarkerFileView m
gsmMinCaughtUpDuration :: forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> NominalDiffTime
gsmMarkerFileView :: forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> MarkerFileView m
gsmDurationUntilTooOld :: forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> Maybe (WrapDurationUntilTooOld m blk)
gsmAntiThunderingHerd :: forall (m :: * -> *) blk. GsmNodeKernelArgs m blk -> StdGen
gsmAntiThunderingHerd :: StdGen
gsmDurationUntilTooOld :: Maybe (WrapDurationUntilTooOld m blk)
gsmMarkerFileView :: MarkerFileView m
gsmMinCaughtUpDuration :: NominalDiffTime
..} = GsmNodeKernelArgs m blk
gsmArgs
      gsmState <-
        m (LedgerState blk EmptyMK)
-> Maybe (WrapDurationUntilTooOld m blk)
-> MarkerFileView m
-> m GsmState
forall blk (m :: * -> *).
(GetTip (LedgerState blk), Monad m) =>
m (LedgerState blk EmptyMK)
-> Maybe (WrapDurationUntilTooOld m blk)
-> MarkerFileView m
-> m GsmState
GSM.initializationGsmState
          (STM m (LedgerState blk EmptyMK) -> m (LedgerState blk EmptyMK)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LedgerState blk EmptyMK) -> m (LedgerState blk EmptyMK))
-> STM m (LedgerState blk EmptyMK) -> m (LedgerState blk EmptyMK)
forall a b. (a -> b) -> a -> b
$ ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState (ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK)
-> STM m (ExtLedgerState blk EmptyMK)
-> STM m (LedgerState blk EmptyMK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (ExtLedgerState blk EmptyMK)
ChainDB.getCurrentLedger ChainDB m blk
chainDB)
          Maybe (WrapDurationUntilTooOld m blk)
gsmDurationUntilTooOld
          MarkerFileView m
gsmMarkerFileView
      newTVarIO gsmState

    varChainSyncHandles <- atomically newChainSyncClientHandleCollection
    mempool <-
      openMempool
        registry
        (chainDBLedgerInterface chainDB)
        (configLedger cfg)
        mempoolCapacityOverride
        (mempoolTracer tracers)

    fetchClientRegistry <- newFetchClientRegistry

    let readFetchMode =
          ConsensusMode
-> BlockchainTime m
-> STM m (AnchoredFragment (Header blk))
-> STM m UseBootstrapPeers
-> STM m LedgerStateJudgement
-> STM m FetchMode
forall (m :: * -> *) blk.
(MonadSTM m, HasHeader blk) =>
ConsensusMode
-> BlockchainTime m
-> STM m (AnchoredFragment blk)
-> STM m UseBootstrapPeers
-> STM m LedgerStateJudgement
-> STM m FetchMode
BlockFetchClientInterface.readFetchModeDefault
            (LoEAndGDDConfig (LoEAndGDDNodeKernelArgs m blk) -> ConsensusMode
forall a. LoEAndGDDConfig a -> ConsensusMode
toConsensusMode (LoEAndGDDConfig (LoEAndGDDNodeKernelArgs m blk) -> ConsensusMode)
-> LoEAndGDDConfig (LoEAndGDDNodeKernelArgs m blk) -> ConsensusMode
forall a b. (a -> b) -> a -> b
$ GenesisNodeKernelArgs m blk
-> LoEAndGDDConfig (LoEAndGDDNodeKernelArgs m blk)
forall (m :: * -> *) blk.
GenesisNodeKernelArgs m blk
-> LoEAndGDDConfig (LoEAndGDDNodeKernelArgs m blk)
gnkaLoEAndGDDArgs GenesisNodeKernelArgs m blk
genesisArgs)
            BlockchainTime m
btime
            (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)
            STM m UseBootstrapPeers
getUseBootstrapPeers
            (GsmState -> LedgerStateJudgement
GSM.gsmStateToLedgerJudgement (GsmState -> LedgerStateJudgement)
-> STM m GsmState -> STM m LedgerStateJudgement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m GsmState -> STM m GsmState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m GsmState
varGsmState)
        blockFetchInterface ::
          BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk m
        blockFetchInterface =
          Tracer m (TraceEventDbf (ConnectionId addrNTN))
-> BlockConfig blk
-> ChainDbView m blk
-> ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk
-> (Header blk -> SizeInBytes)
-> STM m FetchMode
-> DiffusionPipeliningSupport
-> BlockFetchConsensusInterface
     (ConnectionId addrNTN) (HeaderWithTime blk) blk m
forall (m :: * -> *) peer blk.
(IOLike m, BlockSupportsDiffusionPipelining blk, Ord peer,
 LedgerSupportsProtocol blk, ConfigSupportsNode blk) =>
Tracer m (TraceEventDbf peer)
-> BlockConfig blk
-> ChainDbView m blk
-> ChainSyncClientHandleCollection peer m blk
-> (Header blk -> SizeInBytes)
-> STM m FetchMode
-> DiffusionPipeliningSupport
-> BlockFetchConsensusInterface peer (HeaderWithTime blk) blk m
BlockFetchClientInterface.mkBlockFetchConsensusInterface
            (Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer m (TraceEventDbf (ConnectionId addrNTN))
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f -> f (TraceEventDbf remotePeer)
dbfTracer Tracers m (ConnectionId addrNTN) addrNTC blk
tracers)
            (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg)
            (ChainDB m blk -> ChainDbView m blk
forall (m :: * -> *) blk. ChainDB m blk -> ChainDbView m blk
BlockFetchClientInterface.defaultChainDbView ChainDB m blk
chainDB)
            ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk
varChainSyncHandles
            Header blk -> SizeInBytes
blockFetchSize
            STM m FetchMode
readFetchMode
            DiffusionPipeliningSupport
getDiffusionPipeliningSupport

    peerSharingRegistry <- newPeerSharingRegistry

    return IS{..}
   where
    toConsensusMode :: forall a. LoEAndGDDConfig a -> ConsensusMode
    toConsensusMode :: forall a. LoEAndGDDConfig a -> ConsensusMode
toConsensusMode = \case
      LoEAndGDDConfig a
LoEAndGDDDisabled -> ConsensusMode
PraosMode
      LoEAndGDDEnabled a
_ -> ConsensusMode
GenesisMode

forkBlockForging ::
  forall m addrNTN addrNTC blk.
  (IOLike m, RunNode blk) =>
  InternalState m addrNTN addrNTC blk ->
  BlockForging m blk ->
  m (Thread m Void)
forkBlockForging :: forall (m :: * -> *) addrNTN addrNTC blk.
(IOLike m, RunNode blk) =>
InternalState m addrNTN addrNTC blk
-> BlockForging m blk -> m (Thread m Void)
forkBlockForging IS{StrictTVar m GsmState
TopLevelConfig blk
Mempool m blk
BlockchainTime m
ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk
ChainDB m blk
ResourceRegistry m
BlockFetchConsensusInterface
  (ConnectionId addrNTN) (HeaderWithTime blk) blk m
PeerSharingRegistry addrNTN m
FetchClientRegistry
  (ConnectionId addrNTN) (HeaderWithTime blk) blk m
Tracers m (ConnectionId addrNTN) addrNTC blk
blockFetchInterface :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> BlockFetchConsensusInterface
     (ConnectionId addrNTN) (HeaderWithTime blk) blk m
fetchClientRegistry :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> FetchClientRegistry
     (ConnectionId addrNTN) (HeaderWithTime blk) blk m
mempool :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> Mempool m blk
peerSharingRegistry :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> PeerSharingRegistry addrNTN m
varChainSyncHandles :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk
varGsmState :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> StrictTVar m GsmState
tracers :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
cfg :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> TopLevelConfig blk
registry :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> ResourceRegistry m
btime :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> BlockchainTime m
chainDB :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> ChainDB m blk
tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
cfg :: TopLevelConfig blk
registry :: ResourceRegistry m
btime :: BlockchainTime m
chainDB :: ChainDB m blk
blockFetchInterface :: BlockFetchConsensusInterface
  (ConnectionId addrNTN) (HeaderWithTime blk) blk m
fetchClientRegistry :: FetchClientRegistry
  (ConnectionId addrNTN) (HeaderWithTime blk) blk m
varChainSyncHandles :: ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk
varGsmState :: StrictTVar m GsmState
mempool :: Mempool m blk
peerSharingRegistry :: PeerSharingRegistry addrNTN m
..} BlockForging m blk
blockForging =
  ResourceRegistry m
-> String -> Watcher m SlotNo SlotNo -> m (Thread m Void)
forall (m :: * -> *) a fp.
(IOLike m, Eq fp, HasCallStack) =>
ResourceRegistry m -> String -> Watcher m a fp -> m (Thread m Void)
forkLinkedWatcher ResourceRegistry m
registry String
threadLabel (Watcher m SlotNo SlotNo -> m (Thread m Void))
-> Watcher m SlotNo SlotNo -> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$
    BlockchainTime m -> (SlotNo -> m ()) -> Watcher m SlotNo SlotNo
forall (m :: * -> *).
IOLike m =>
BlockchainTime m -> (SlotNo -> m ()) -> Watcher m SlotNo SlotNo
knownSlotWatcher BlockchainTime m
btime ((SlotNo -> m ()) -> Watcher m SlotNo SlotNo)
-> (SlotNo -> m ()) -> Watcher m SlotNo SlotNo
forall a b. (a -> b) -> a -> b
$
      \SlotNo
currentSlot -> (ResourceRegistry m -> m ()) -> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry (\ResourceRegistry m
rr -> WithEarlyExit m () -> m ()
forall (m :: * -> *). Functor m => WithEarlyExit m () -> m ()
withEarlyExit_ (WithEarlyExit m () -> m ()) -> WithEarlyExit m () -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m -> SlotNo -> WithEarlyExit m ()
go ResourceRegistry m
rr SlotNo
currentSlot)
 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 :: ResourceRegistry m -> SlotNo -> WithEarlyExit m ()
  go :: ResourceRegistry m -> SlotNo -> WithEarlyExit m ()
go ResourceRegistry m
reg 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{bcBlockNo, bcPrevPoint} <- 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

    trace $ TraceBlockContext currentSlot bcBlockNo bcPrevPoint

    -- Get forker corresponding to bcPrevPoint
    --
    -- This might fail if, in between choosing 'bcPrevPoint' and this call to
    -- 'ChainDB.getReadOnlyForkerAtPoint', 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.
    forkerEith <- lift $ ChainDB.getReadOnlyForkerAtPoint chainDB reg (SpecificPoint bcPrevPoint)
    -- Remember to close this forker before exiting!
    forker <- case forkerEith of
      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 (ReadOnlyForker' m blk)
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
      Right ReadOnlyForker' m blk
forker -> ReadOnlyForker' m blk -> WithEarlyExit m (ReadOnlyForker' m blk)
forall a. a -> WithEarlyExit m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReadOnlyForker' m blk
forker

    unticked <- lift $ atomically $ LedgerDB.roforkerGetLedgerState forker

    trace $ TraceLedgerState currentSlot bcPrevPoint

    -- We require the ticked ledger view in order to construct the ticked
    -- 'ChainDepState'.
    ledgerView <-
      case runExcept $
        forecastFor
          ( ledgerViewForecastAt
              (configLedger cfg)
              (ledgerState unticked)
          )
          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
          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 ()) -> m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ ReadOnlyForker' m blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> m ()
roforkerClose ReadOnlyForker' m blk
forker
          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

    -- 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 =
          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 if we are the leader
    proof <- do
      shouldForge <-
        lift $
          checkShouldForge
            blockForging
            ( contramap
                (TraceLabelCreds (forgeLabel blockForging))
                (forgeStateInfoTracer tracers)
            )
            cfg
            currentSlot
            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
          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 ()) -> m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ ReadOnlyForker' m blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> m ()
roforkerClose ReadOnlyForker' m blk
forker
          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
          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 ()) -> m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ ReadOnlyForker' m blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> m ()
roforkerClose ReadOnlyForker' m blk
forker
          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
          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 ()) -> m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ ReadOnlyForker' m blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> m ()
roforkerClose ReadOnlyForker' m blk
forker
          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

    -- Tick the ledger state for the 'SlotNo' we're producing a block for
    let tickedLedgerState :: Ticked (LedgerState blk) DiffMK
        tickedLedgerState =
          ComputeLedgerEvents
-> LedgerConfig blk
-> SlotNo
-> LedgerState blk EmptyMK
-> Ticked (LedgerState blk) DiffMK
forall (l :: LedgerStateKind).
IsLedger l =>
ComputeLedgerEvents
-> LedgerCfg l -> SlotNo -> l EmptyMK -> Ticked l DiffMK
applyChainTick
            ComputeLedgerEvents
OmitLedgerEvents
            (TopLevelConfig blk -> LedgerConfig 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)

    _ <- evaluate tickedLedgerState
    trace $ TraceForgeTickedLedgerState currentSlot bcPrevPoint

    -- 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.
    (mempoolHash, mempoolSlotNo) <- lift $ atomically $ do
      snap <- getSnapshot mempool -- only used for its tip-like information
      pure (castHash $ snapshotStateHash snap, snapshotSlotNo snap)

    let readTables = (LedgerTables (ExtLedgerState blk) ValuesMK
 -> LedgerTables (LedgerState blk) ValuesMK)
-> m (LedgerTables (ExtLedgerState blk) ValuesMK)
-> m (LedgerTables (LedgerState blk) ValuesMK)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LedgerTables (ExtLedgerState blk) ValuesMK
-> LedgerTables (LedgerState blk) ValuesMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: MapKind).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables (m (LedgerTables (ExtLedgerState blk) ValuesMK)
 -> m (LedgerTables (LedgerState blk) ValuesMK))
-> (LedgerTables (LedgerState blk) KeysMK
    -> m (LedgerTables (ExtLedgerState blk) ValuesMK))
-> LedgerTables (LedgerState blk) KeysMK
-> m (LedgerTables (LedgerState blk) ValuesMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadOnlyForker' m blk
-> LedgerTables (ExtLedgerState blk) KeysMK
-> m (LedgerTables (ExtLedgerState blk) ValuesMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk
-> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
roforkerReadTables ReadOnlyForker' m blk
forker (LedgerTables (ExtLedgerState blk) KeysMK
 -> m (LedgerTables (ExtLedgerState blk) ValuesMK))
-> (LedgerTables (LedgerState blk) KeysMK
    -> LedgerTables (ExtLedgerState blk) KeysMK)
-> LedgerTables (LedgerState blk) KeysMK
-> m (LedgerTables (ExtLedgerState blk) ValuesMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerTables (LedgerState blk) KeysMK
-> LedgerTables (ExtLedgerState blk) KeysMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: MapKind).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables

    mempoolSnapshot <-
      lift $
        getSnapshotFor
          mempool
          currentSlot
          tickedLedgerState
          readTables

    lift $ roforkerClose forker

    let txs =
          MempoolSnapshot blk -> TxMeasure blk -> [Validated (GenTx blk)]
forall blk.
MempoolSnapshot blk -> TxMeasure blk -> [Validated (GenTx blk)]
snapshotTake MempoolSnapshot blk
mempoolSnapshot (TxMeasure blk -> [Validated (GenTx blk)])
-> TxMeasure blk -> [Validated (GenTx blk)]
forall a b. (a -> b) -> a -> b
$
            LedgerConfig blk
-> Ticked (LedgerState blk) DiffMK -> TxMeasure blk
forall blk (mk :: MapKind).
TxLimits blk =>
LedgerConfig blk -> TickedLedgerState blk mk -> TxMeasure blk
forall (mk :: MapKind).
LedgerConfig blk -> TickedLedgerState blk mk -> TxMeasure blk
blockCapacityTxMeasure (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg) Ticked (LedgerState blk) DiffMK
tickedLedgerState
    -- NB respect the capacity of the ledger state we're extending,
    -- which is /not/ 'snapshotLedgerState'

    -- force the mempool's computation before the tracer event
    _ <- evaluate (length txs)
    _ <- evaluate mempoolHash

    trace $ TraceForgingMempoolSnapshot currentSlot bcPrevPoint mempoolHash mempoolSlotNo

    -- Actually produce the block
    newBlock <-
      lift $
        Block.forgeBlock
          blockForging
          cfg
          bcBlockNo
          currentSlot
          (forgetLedgerTables tickedLedgerState)
          txs
          proof

    trace $
      TraceForgedBlock
        currentSlot
        (ledgerTipPoint (ledgerState unticked))
        newBlock
        (snapshotMempoolSize mempoolSnapshot)

    -- Add the block to the chain DB
    let 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.
    uninterruptibleMask_ $ do
      result <- lift $ ChainDB.addBlockAsync chainDB noPunish 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

  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. Tracer m a -> a -> m ()
traceWith (Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer m (TraceLabelCreds (TraceForgeEvent blk))
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceLabelCreds (TraceForgeEvent blk))
forgeTracer Tracers m (ConnectionId addrNTN) addrNTC 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)

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

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

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

getMempoolReader ::
  forall m blk.
  ( LedgerSupportsMempool blk
  , IOLike m
  , HasTxId (GenTx blk)
  ) =>
  Mempool m blk ->
  TxSubmissionMempoolReader (GenTxId blk) (Validated (GenTx blk)) TicketNo m
getMempoolReader :: forall (m :: * -> *) blk.
(LedgerSupportsMempool blk, IOLike m, HasTxId (GenTx blk)) =>
Mempool m blk
-> TxSubmissionMempoolReader
     (GenTxId blk) (Validated (GenTx blk)) TicketNo m
getMempoolReader Mempool m blk
mempool =
  MempoolReader.TxSubmissionMempoolReader
    { mempoolZeroIdx :: TicketNo
mempoolZeroIdx = TicketNo
zeroTicketNo
    , mempoolGetSnapshot :: STM
  m (MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo)
mempoolGetSnapshot = MempoolSnapshot blk
-> MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo
convertSnapshot (MempoolSnapshot blk
 -> MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo)
-> STM m (MempoolSnapshot blk)
-> STM
     m (MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mempool m blk -> STM m (MempoolSnapshot blk)
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool m blk
mempool
    }
 where
  convertSnapshot ::
    MempoolSnapshot blk ->
    MempoolReader.MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo
  convertSnapshot :: MempoolSnapshot blk
-> MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo
convertSnapshot
    MempoolSnapshot
      { TicketNo -> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxsAfter :: TicketNo -> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxsAfter :: forall blk.
MempoolSnapshot blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxsAfter
      , TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx :: TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx :: forall blk.
MempoolSnapshot blk -> TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx
      , GenTxId blk -> Bool
snapshotHasTx :: GenTxId blk -> Bool
snapshotHasTx :: forall blk. MempoolSnapshot blk -> GenTxId blk -> Bool
snapshotHasTx
      } =
      MempoolReader.MempoolSnapshot
        { mempoolTxIdsAfter :: TicketNo -> [(GenTxId blk, TicketNo, SizeInBytes)]
mempoolTxIdsAfter = \TicketNo
idx ->
            [ ( GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId (Validated (GenTx blk) -> GenTx blk
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated (GenTx blk)
tx)
              , TicketNo
idx'
              , Word32 -> SizeInBytes
SizeInBytes (Word32 -> SizeInBytes) -> Word32 -> SizeInBytes
forall a b. (a -> b) -> a -> b
$ ByteSize32 -> Word32
unByteSize32 (ByteSize32 -> Word32) -> ByteSize32 -> Word32
forall a b. (a -> b) -> a -> b
$ TxMeasure blk -> ByteSize32
forall a. HasByteSize a => a -> ByteSize32
txMeasureByteSize TxMeasure blk
msr
              )
            | (Validated (GenTx blk)
tx, TicketNo
idx', TxMeasure blk
msr) <- TicketNo -> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxsAfter TicketNo
idx
            ]
        , mempoolLookupTx :: TicketNo -> Maybe (Validated (GenTx blk))
mempoolLookupTx = TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx
        , mempoolHasTx :: GenTxId blk -> Bool
mempoolHasTx = GenTxId blk -> Bool
snapshotHasTx
        }

getMempoolWriter ::
  ( LedgerSupportsMempool blk
  , IOLike m
  , HasTxId (GenTx blk)
  ) =>
  Mempool m blk ->
  TxSubmissionMempoolWriter (GenTxId blk) (GenTx blk) TicketNo m
getMempoolWriter :: forall blk (m :: * -> *).
(LedgerSupportsMempool blk, IOLike m, HasTxId (GenTx blk)) =>
Mempool m blk
-> TxSubmissionMempoolWriter (GenTxId blk) (GenTx blk) TicketNo m
getMempoolWriter Mempool m blk
mempool =
  Inbound.TxSubmissionMempoolWriter
    { txId :: GenTx blk -> TxId (GenTx blk)
Inbound.txId = GenTx blk -> TxId (GenTx blk)
forall tx. HasTxId tx => tx -> TxId tx
txId
    , mempoolAddTxs :: [GenTx blk] -> m [TxId (GenTx blk)]
mempoolAddTxs = \[GenTx blk]
txs ->
        (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)] -> [TxId (GenTx blk)])
-> ([MempoolAddTxResult blk] -> [Validated (GenTx blk)])
-> [MempoolAddTxResult blk]
-> [TxId (GenTx blk)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MempoolAddTxResult blk -> Maybe (Validated (GenTx blk)))
-> [MempoolAddTxResult blk] -> [Validated (GenTx blk)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe MempoolAddTxResult blk -> Maybe (Validated (GenTx blk))
forall blk. MempoolAddTxResult blk -> Maybe (Validated (GenTx blk))
mempoolTxAddedToMaybe
          ([MempoolAddTxResult blk] -> [TxId (GenTx blk)])
-> m [MempoolAddTxResult blk] -> m [TxId (GenTx blk)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mempool m blk -> [GenTx blk] -> m [MempoolAddTxResult blk]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool m blk
mempool [GenTx blk]
txs
    }

{-------------------------------------------------------------------------------
  PeerSelection integration
-------------------------------------------------------------------------------}

-- | Retrieve the peers registered in the current chain/ledger state by
-- descending stake.
--
-- For example, for Shelley, this will return the stake pool relays ordered by
-- descending stake.
--
-- Only returns a 'Just' when the given predicate returns 'True'. This predicate
-- can for example check whether the slot of the ledger state is older or newer
-- than some slot number.
--
-- We don't use the ledger state at the tip of the chain, but the ledger state
-- @k@ blocks back, i.e., at the tip of the immutable chain, because any stake
-- pools registered in that ledger state are guaranteed to be stable. This
-- justifies merging the future and current stake pools.
getPeersFromCurrentLedger ::
  (IOLike m, LedgerSupportsPeerSelection blk) =>
  NodeKernel m addrNTN addrNTC blk ->
  (LedgerState blk EmptyMK -> Bool) ->
  STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
getPeersFromCurrentLedger :: forall (m :: * -> *) blk addrNTN addrNTC.
(IOLike m, LedgerSupportsPeerSelection blk) =>
NodeKernel m addrNTN addrNTC blk
-> (LedgerState blk EmptyMK -> Bool)
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
getPeersFromCurrentLedger NodeKernel m addrNTN addrNTC blk
kernel LedgerState blk EmptyMK -> Bool
p = do
  immutableLedger <-
    ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState (ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK)
-> STM m (ExtLedgerState blk EmptyMK)
-> STM m (LedgerState blk EmptyMK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (ExtLedgerState blk EmptyMK)
ChainDB.getImmutableLedger (NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
getChainDB NodeKernel m addrNTN addrNTC blk
kernel)
  return $ do
    guard (p immutableLedger)
    return $
      map (second (fmap stakePoolRelayAccessPoint)) $
        force $
          getPeers immutableLedger

-- | Like 'getPeersFromCurrentLedger' but with a \"after slot number X\"
-- condition.
getPeersFromCurrentLedgerAfterSlot ::
  forall m blk addrNTN addrNTC.
  ( IOLike m
  , LedgerSupportsPeerSelection blk
  , UpdateLedger blk
  ) =>
  NodeKernel m addrNTN addrNTC blk ->
  SlotNo ->
  STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
getPeersFromCurrentLedgerAfterSlot :: forall (m :: * -> *) blk addrNTN addrNTC.
(IOLike m, LedgerSupportsPeerSelection blk, UpdateLedger blk) =>
NodeKernel m addrNTN addrNTC blk
-> SlotNo -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
getPeersFromCurrentLedgerAfterSlot NodeKernel m addrNTN addrNTC blk
kernel SlotNo
slotNo =
  NodeKernel m addrNTN addrNTC blk
-> (LedgerState blk EmptyMK -> Bool)
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
forall (m :: * -> *) blk addrNTN addrNTC.
(IOLike m, LedgerSupportsPeerSelection blk) =>
NodeKernel m addrNTN addrNTC blk
-> (LedgerState blk EmptyMK -> Bool)
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
getPeersFromCurrentLedger NodeKernel m addrNTN addrNTC blk
kernel LedgerState blk EmptyMK -> Bool
forall (mk :: MapKind). LedgerState blk mk -> Bool
afterSlotNo
 where
  afterSlotNo :: LedgerState blk mk -> Bool
  afterSlotNo :: forall (mk :: MapKind). LedgerState blk mk -> Bool
afterSlotNo LedgerState blk mk
st =
    case LedgerState blk mk -> WithOrigin SlotNo
forall blk (mk :: MapKind).
UpdateLedger blk =>
LedgerState blk mk -> WithOrigin SlotNo
ledgerTipSlot LedgerState blk mk
st of
      WithOrigin SlotNo
Origin -> Bool
False
      NotOrigin SlotNo
tip -> SlotNo
tip SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
slotNo

-- | Retrieve the slot of the immutable tip
getImmTipSlot ::
  ( IOLike m
  , UpdateLedger blk
  ) =>
  NodeKernel m addrNTN addrNTC blk ->
  STM m (WithOrigin SlotNo)
getImmTipSlot :: forall (m :: * -> *) blk addrNTN addrNTC.
(IOLike m, UpdateLedger blk) =>
NodeKernel m addrNTN addrNTC blk -> STM m (WithOrigin SlotNo)
getImmTipSlot NodeKernel m addrNTN addrNTC blk
kernel =
  ExtLedgerState blk EmptyMK -> WithOrigin SlotNo
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot
    (ExtLedgerState blk EmptyMK -> WithOrigin SlotNo)
-> STM m (ExtLedgerState blk EmptyMK) -> STM m (WithOrigin SlotNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (ExtLedgerState blk EmptyMK)
ChainDB.getImmutableLedger (NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
getChainDB NodeKernel m addrNTN addrNTC blk
kernel)