{-# 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 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           Data.Map.Strict (Map)
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.Mempool
import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                     (ChainSyncClientHandle (..), ChainSyncState (..),
                     viewChainSyncState)
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck
                     (HistoricityCheck)
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck
                     (SomeHeaderInFutureCheck)
import           Ouroboros.Consensus.Node.Genesis (GenesisNodeKernelArgs (..),
                     LoEAndGDDConfig (..), setGetLoEFragment)
import           Ouroboros.Consensus.Node.GSM (GsmNodeKernelArgs (..))
import qualified Ouroboros.Consensus.Node.GSM as GSM
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.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.Diffusion (PublicPeerSelectionState)
import           Ouroboros.Network.NodeToNode (ConnectionId,
                     MiniProtocolParameters (..))
import           Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers)
import           Ouroboros.Network.PeerSelection.LedgerPeers.Type
                     (LedgerStateJudgement (..))
import           Ouroboros.Network.PeerSelection.LocalRootPeers
                     (OutboundConnectionsState (..))
import           Ouroboros.Network.PeerSharing (PeerSharingAPI,
                     PeerSharingRegistry, newPeerSharingAPI,
                     newPeerSharingRegistry, ps_POLICY_PEER_SHARE_MAX_PEERS,
                     ps_POLICY_PEER_SHARE_STICKY_TIME)
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 {
      -- | The 'ChainDB' of the node
      forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
getChainDB              :: ChainDB m blk

      -- | The node's mempool
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> Mempool m blk
getMempool              :: Mempool m blk

      -- | The node's top-level static configuration
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> TopLevelConfig blk
getTopLevelConfig       :: TopLevelConfig blk

      -- | The fetch client registry, used for the block fetch clients.
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk
-> FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
getFetchClientRegistry  :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m

      -- | The fetch mode, used by diffusion.
      --
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> STM m FetchMode
getFetchMode            :: STM m FetchMode

      -- | 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 -> STM m GsmState
getGsmState             :: STM m GSM.GsmState

      -- | The kill handle and exposed state for each ChainSync client.
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk
-> StrictTVar
     m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
getChainSyncHandles     :: StrictTVar m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))

      -- | Read the current peer sharing registry, used for interacting with
      -- the PeerSharing protocol
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> PeerSharingRegistry addrNTN m
getPeerSharingRegistry  :: PeerSharingRegistry addrNTN m

      -- | The node's tracers
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
getTracers              :: Tracers m (ConnectionId addrNTN) addrNTC blk

      -- | Set block forging
      --
      -- When set with the empty list '[]' block forging will be disabled.
      --
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> [BlockForging m blk] -> m ()
setBlockForging        :: [BlockForging m blk] -> m ()

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

-- | 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
      -- | See 'HistoricityCheck' for details.
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> m GsmState -> HistoricityCheck m blk
chainSyncHistoricityCheck
                              :: m GSM.GsmState -> HistoricityCheck m blk
    , 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
$sel:registry:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ResourceRegistry m
registry :: ResourceRegistry m
registry, TopLevelConfig blk
$sel:cfg:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg, Tracers m (ConnectionId addrNTN) addrNTC blk
$sel:tracers:NodeKernelArgs :: 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
$sel:chainDB:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ChainDB m blk
chainDB :: ChainDB m blk
chainDB, StorageConfig blk -> InitChainDB m blk -> m ()
$sel:initChainDB:NodeKernelArgs :: 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
$sel:blockFetchConfiguration:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockFetchConfiguration
blockFetchConfiguration :: BlockFetchConfiguration
blockFetchConfiguration
                                   , GsmNodeKernelArgs m blk
$sel:gsmArgs:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GsmNodeKernelArgs m blk
gsmArgs :: GsmNodeKernelArgs m blk
gsmArgs
                                   , StdGen
$sel:peerSharingRng:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> StdGen
peerSharingRng :: StdGen
peerSharingRng
                                   , StrictTVar m (PublicPeerSelectionState addrNTN)
$sel:publicPeerSelectionStateVar:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar :: StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar
                                   , GenesisNodeKernelArgs m blk
$sel:genesisArgs:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GenesisNodeKernelArgs m blk
genesisArgs :: GenesisNodeKernelArgs m blk
genesisArgs
                                   , DiffusionPipeliningSupport
$sel:getDiffusionPipeliningSupport:NodeKernelArgs :: 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.
    TMVar m [BlockForging m blk]
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 []
    StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB (TopLevelConfig blk -> StorageConfig blk
forall blk. TopLevelConfig blk -> StorageConfig blk
configStorage TopLevelConfig blk
cfg) (ChainDB m blk -> InitChainDB m blk
forall blk (m :: * -> *).
(IsLedger (LedgerState blk), IOLike m) =>
ChainDB m blk -> InitChainDB m blk
InitChainDB.fromFull ChainDB m blk
chainDB)

    InternalState m addrNTN addrNTC blk
st <- NodeKernelArgs m addrNTN addrNTC blk
-> m (InternalState m addrNTN addrNTC blk)
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 m addrNTN addrNTC blk
args
    let IS
          { BlockFetchConsensusInterface
  (ConnectionId addrNTN) (Header blk) blk m
blockFetchInterface :: BlockFetchConsensusInterface
  (ConnectionId addrNTN) (Header blk) blk m
$sel:blockFetchInterface:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> BlockFetchConsensusInterface
     (ConnectionId addrNTN) (Header blk) blk m
blockFetchInterface
          , FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
$sel:fetchClientRegistry:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
fetchClientRegistry
          , Mempool m blk
mempool :: Mempool m blk
$sel:mempool:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> Mempool m blk
mempool
          , PeerSharingRegistry addrNTN m
peerSharingRegistry :: PeerSharingRegistry addrNTN m
$sel:peerSharingRegistry:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> PeerSharingRegistry addrNTN m
peerSharingRegistry
          , StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles :: StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
$sel:varChainSyncHandles:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> StrictTVar
     m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles
          , StrictTVar m GsmState
varGsmState :: StrictTVar m GsmState
$sel:varGsmState:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> StrictTVar m GsmState
varGsmState
          } = InternalState m addrNTN addrNTC blk
st

    StrictTVar m OutboundConnectionsState
varOutboundConnectionsState <- OutboundConnectionsState
-> m (StrictTVar m OutboundConnectionsState)
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO OutboundConnectionsState
UntrustedState

    do  let GsmNodeKernelArgs {Maybe (WrapDurationUntilTooOld m blk)
StdGen
NominalDiffTime
MarkerFileView m
gsmAntiThunderingHerd :: StdGen
gsmDurationUntilTooOld :: Maybe (WrapDurationUntilTooOld m blk)
gsmMarkerFileView :: MarkerFileView m
gsmMinCaughtUpDuration :: NominalDiffTime
gsmAntiThunderingHerd :: forall (m :: * -> *) blk. GsmNodeKernelArgs m blk -> StdGen
gsmDurationUntilTooOld :: forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> Maybe (WrapDurationUntilTooOld m blk)
gsmMarkerFileView :: forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> MarkerFileView m
gsmMinCaughtUpDuration :: forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> NominalDiffTime
..} = GsmNodeKernelArgs m blk
gsmArgs
            gsmTracerArgs :: ((AnchoredSeq
    (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
  LedgerState blk)
 -> Tip blk,
 Tracer m (TraceGsmEvent (Tip blk)))
gsmTracerArgs          =
              ( Tip (Header blk) -> Tip blk
forall {k1} {k2} (a :: k1) (b :: k2).
(HeaderHash a ~ HeaderHash b) =>
Tip a -> Tip b
castTip (Tip (Header blk) -> Tip blk)
-> ((AnchoredSeq
       (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
     LedgerState blk)
    -> Tip (Header blk))
-> (AnchoredSeq
      (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
    LedgerState blk)
-> Tip blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Anchor (Header blk) -> Tip (Header blk))
-> (Header blk -> Tip (Header blk))
-> Either (Anchor (Header blk)) (Header blk)
-> Tip (Header blk)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Anchor (Header blk) -> Tip (Header blk)
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Tip b
AF.anchorToTip Header blk -> Tip (Header blk)
forall a. HasHeader a => a -> Tip a
tipFromHeader (Either (Anchor (Header blk)) (Header blk) -> Tip (Header blk))
-> ((AnchoredSeq
       (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
     LedgerState blk)
    -> Either (Anchor (Header blk)) (Header blk))
-> (AnchoredSeq
      (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
    LedgerState blk)
-> Tip (Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> Either (Anchor (Header blk)) (Header blk)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.head (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
 -> Either (Anchor (Header blk)) (Header blk))
-> ((AnchoredSeq
       (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
     LedgerState blk)
    -> AnchoredSeq
         (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
-> (AnchoredSeq
      (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
    LedgerState blk)
-> Either (Anchor (Header blk)) (Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredSeq
   (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
 LedgerState blk)
-> AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header 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 :: GsmEntryPoints m
gsm = ((AnchoredSeq
    (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
  LedgerState blk)
 -> Tip blk,
 Tracer m (TraceGsmEvent (Tip blk)))
-> GsmView
     m
     (ConnectionId addrNTN)
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
      LedgerState blk)
     (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 (Header blk)) (Header blk),
  LedgerState blk)
 -> 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 (Header blk)) (Header blk),
 LedgerState blk)
-> ChainSyncState blk -> CandidateVersusSelection
GSM.candidateOverSelection    = \(AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
headers, LedgerState blk
_lst) ChainSyncState blk
state ->
                    case AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> Maybe (Point (Header 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 (Header blk)) (Header blk)
headers (ChainSyncState blk
-> AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
forall blk. ChainSyncState blk -> AnchoredFragment (Header blk)
csCandidate ChainSyncState blk
state) of
                        Maybe (Point (Header 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 (Header blk)) (Header blk)
-> AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> Bool
forall blk.
(BlockSupportsProtocol blk, HasCallStack) =>
BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate
                                (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg)
                                AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
headers
                                (ChainSyncState blk
-> AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
forall blk. ChainSyncState blk -> AnchoredFragment (Header 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 (Header blk)) (Header blk),
    LedgerState blk)
   -> m DurationFromNow)
GSM.durationUntilTooOld       =
                      Maybe (WrapDurationUntilTooOld m blk)
gsmDurationUntilTooOld
                  Maybe (WrapDurationUntilTooOld m blk)
-> (WrapDurationUntilTooOld m blk
    -> (AnchoredSeq
          (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
        LedgerState blk)
    -> m DurationFromNow)
-> Maybe
     ((AnchoredSeq
         (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
       LedgerState blk)
      -> m DurationFromNow)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \WrapDurationUntilTooOld m blk
wd (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
_headers, LedgerState blk
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 -> WithOrigin SlotNo
forall l. GetTip l => l -> WithOrigin SlotNo
getTipSlot LedgerState blk
lst)
              , equivalent :: (AnchoredSeq
   (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
 LedgerState blk)
-> (AnchoredSeq
      (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
    LedgerState blk)
-> Bool
GSM.equivalent                = Point (Header blk) -> Point (Header blk) -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Point (Header blk) -> Point (Header blk) -> Bool)
-> ((AnchoredSeq
       (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
     LedgerState blk)
    -> Point (Header blk))
-> (AnchoredSeq
      (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
    LedgerState blk)
-> (AnchoredSeq
      (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
    LedgerState blk)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
 -> Point (Header blk))
-> ((AnchoredSeq
       (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
     LedgerState blk)
    -> AnchoredSeq
         (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
-> (AnchoredSeq
      (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
    LedgerState blk)
-> Point (Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredSeq
   (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
 LedgerState blk)
-> AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header 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
<$> StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
-> STM m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles
              , getCurrentSelection :: STM
  m
  (AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
   LedgerState blk)
GSM.getCurrentSelection       = do
                  AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
headers        <- ChainDB m blk
-> STM
     m
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (Header blk))
ChainDB.getCurrentChain  ChainDB m blk
chainDB
                  ExtLedgerState blk
extLedgerState <- ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
(Monad (STM m), IsLedger (LedgerState blk)) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB m blk
chainDB
                  (AnchoredSeq
   (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
 LedgerState blk)
-> STM
     m
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
      LedgerState blk)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
headers, ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
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
                    Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)
handles <- StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
-> STM m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles
                    (ChainSyncClientHandle m blk -> STM m ())
-> Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)
-> STM m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (((Time -> STM m ()) -> Time -> STM m ()
forall a b. (a -> b) -> a -> b
$ Time
time) ((Time -> STM m ()) -> STM m ())
-> (ChainSyncClientHandle m blk -> Time -> STM m ())
-> ChainSyncClientHandle m blk
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((GsmState -> Time -> STM m ()) -> GsmState -> Time -> STM m ()
forall a b. (a -> b) -> a -> b
$ GsmState
gsmState) ((GsmState -> Time -> STM m ()) -> Time -> STM m ())
-> (ChainSyncClientHandle m blk -> GsmState -> Time -> STM m ())
-> ChainSyncClientHandle m blk
-> Time
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainSyncClientHandle m blk -> GsmState -> Time -> STM m ()
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> GsmState -> Time -> STM m ()
cschOnGsmStateChanged) Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)
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
              }
        LedgerStateJudgement
judgment <- GsmState -> LedgerStateJudgement
GSM.gsmStateToLedgerJudgement (GsmState -> LedgerStateJudgement)
-> m GsmState -> m LedgerStateJudgement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m GsmState -> m GsmState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m GsmState
varGsmState
        m (Thread m Any) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m Any) -> m ()) -> m (Thread m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m -> String -> m Any -> m (Thread m Any)
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
"NodeKernel.GSM" (m Any -> m (Thread m Any)) -> m Any -> m (Thread m Any)
forall a b. (a -> b) -> a -> b
$ case LedgerStateJudgement
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 addrNTN StdGen m
peerSharingAPI <- StrictTVar m (PublicPeerSelectionState addrNTN)
-> StdGen
-> DiffTime
-> PeerSharingAmount
-> m (PeerSharingAPI addrNTN StdGen m)
forall (m :: * -> *) addr s.
MonadSTM m =>
StrictTVar m (PublicPeerSelectionState addr)
-> s
-> DiffTime
-> PeerSharingAmount
-> m (PeerSharingAPI addr s m)
newPeerSharingAPI StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar
                                        StdGen
peerSharingRng
                                        DiffTime
ps_POLICY_PEER_SHARE_STICKY_TIME
                                        PeerSharingAmount
ps_POLICY_PEER_SHARE_MAX_PEERS

    case GenesisNodeKernelArgs m blk
-> LoEAndGDDConfig (StrictTVar m (GetLoEFragment m blk))
forall (m :: * -> *) blk.
GenesisNodeKernelArgs m blk
-> LoEAndGDDConfig (StrictTVar m (GetLoEFragment m blk))
gnkaGetLoEFragment GenesisNodeKernelArgs m blk
genesisArgs of
      LoEAndGDDConfig (StrictTVar m (GetLoEFragment m blk))
LoEAndGDDDisabled                  -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      LoEAndGDDEnabled StrictTVar m (GetLoEFragment m blk)
varGetLoEFragment -> do
        StrictTVar
  m
  (AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
varLoEFragment <- AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> m (StrictTVar
        m
        (AnchoredSeq
           (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
 -> m (StrictTVar
         m
         (AnchoredSeq
            (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))
-> AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> m (StrictTVar
        m
        (AnchoredSeq
           (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
forall a b. (a -> b) -> a -> b
$ Anchor (Header blk)
-> AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (Header blk)
forall block. Anchor block
AF.AnchorGenesis
        STM m GsmState
-> STM
     m
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
-> StrictTVar m (GetLoEFragment m blk)
-> m ()
forall (m :: * -> *) blk.
(IOLike m, GetHeader blk) =>
STM m GsmState
-> STM m (AnchoredFragment (Header blk))
-> StrictTVar m (GetLoEFragment m blk)
-> m ()
setGetLoEFragment
          (StrictTVar m GsmState -> STM m GsmState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m GsmState
varGsmState)
          (StrictTVar
  m
  (AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
-> STM
     m
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m
  (AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
varLoEFragment)
          StrictTVar m (GetLoEFragment m blk)
varGetLoEFragment

        m (Thread m Void) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m Void) -> m ()) -> m (Thread m Void) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m
-> String
-> Watcher
     m
     (GsmState, GDDStateView m blk (ConnectionId addrNTN))
     (Map
        (ConnectionId addrNTN) (StrictMaybe (WithOrigin SlotNo), Bool))
-> 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
"NodeKernel.GDD" (Watcher
   m
   (GsmState, GDDStateView m blk (ConnectionId addrNTN))
   (Map
      (ConnectionId addrNTN) (StrictMaybe (WithOrigin SlotNo), Bool))
 -> m (Thread m Void))
-> Watcher
     m
     (GsmState, GDDStateView m blk (ConnectionId addrNTN))
     (Map
        (ConnectionId addrNTN) (StrictMaybe (WithOrigin SlotNo), Bool))
-> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$
          TopLevelConfig blk
-> Tracer m (TraceGDDEvent (ConnectionId addrNTN) blk)
-> ChainDB m blk
-> STM m GsmState
-> STM m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
-> StrictTVar
     m
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
-> Watcher
     m
     (GsmState, GDDStateView m blk (ConnectionId addrNTN))
     (Map
        (ConnectionId addrNTN) (StrictMaybe (WithOrigin SlotNo), Bool))
forall (m :: * -> *) blk peer.
(IOLike m, Ord peer, LedgerSupportsProtocol blk,
 HasHardForkHistory blk) =>
TopLevelConfig blk
-> Tracer m (TraceGDDEvent peer blk)
-> ChainDB m blk
-> STM m GsmState
-> STM m (Map peer (ChainSyncClientHandle m blk))
-> StrictTVar m (AnchoredFragment (Header blk))
-> Watcher
     m
     (GsmState, GDDStateView m blk peer)
     (Map peer (StrictMaybe (WithOrigin SlotNo), Bool))
gddWatcher
            TopLevelConfig blk
cfg
            (Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer m (TraceGDDEvent (ConnectionId addrNTN) blk)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceGDDEvent remotePeer blk)
gddTracer Tracers m (ConnectionId addrNTN) addrNTC blk
tracers)
            ChainDB m blk
chainDB
            (StrictTVar m GsmState -> STM m GsmState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m GsmState
varGsmState)
            -- TODO GDD should only consider (big) ledger peers
            (StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
-> STM m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles)
            StrictTVar
  m
  (AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
varLoEFragment

    m (Thread m Void) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m Void) -> m ()) -> m (Thread m Void) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m -> String -> m Void -> m (Thread m Void)
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
"NodeKernel.blockForging" (m Void -> m (Thread m Void)) -> m Void -> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$
                            InternalState m addrNTN addrNTC blk
-> STM m [BlockForging m blk] -> m Void
forall remotePeer localPeer.
InternalState m remotePeer localPeer blk
-> STM m [BlockForging m blk] -> m Void
blockForgingController InternalState m addrNTN addrNTC blk
st (TMVar m [BlockForging m blk] -> STM m [BlockForging m blk]
forall a. TMVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
LazySTM.takeTMVar TMVar m [BlockForging m blk]
blockForgingVar)

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

    NodeKernel m addrNTN addrNTC blk
-> m (NodeKernel m addrNTN addrNTC blk)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return NodeKernel
      { $sel:getChainDB:NodeKernel :: ChainDB m blk
getChainDB              = ChainDB m blk
chainDB
      , $sel:getMempool:NodeKernel :: Mempool m blk
getMempool              = Mempool m blk
mempool
      , $sel:getTopLevelConfig:NodeKernel :: TopLevelConfig blk
getTopLevelConfig       = TopLevelConfig blk
cfg
      , $sel:getFetchClientRegistry:NodeKernel :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
getFetchClientRegistry  = FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
fetchClientRegistry
      , $sel:getFetchMode:NodeKernel :: STM m FetchMode
getFetchMode            = BlockFetchConsensusInterface
  (ConnectionId addrNTN) (Header blk) blk m
-> STM m FetchMode
forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m -> STM m FetchMode
readFetchMode BlockFetchConsensusInterface
  (ConnectionId addrNTN) (Header blk) blk m
blockFetchInterface
      , $sel:getGsmState:NodeKernel :: STM m GsmState
getGsmState             = StrictTVar m GsmState -> STM m GsmState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m GsmState
varGsmState
      , $sel:getChainSyncHandles:NodeKernel :: StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
getChainSyncHandles     = StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles
      , $sel:getPeerSharingRegistry:NodeKernel :: PeerSharingRegistry addrNTN m
getPeerSharingRegistry  = PeerSharingRegistry addrNTN m
peerSharingRegistry
      , $sel:getTracers:NodeKernel :: Tracers m (ConnectionId addrNTN) addrNTC blk
getTracers              = Tracers m (ConnectionId addrNTN) addrNTC blk
tracers
      , $sel:setBlockForging:NodeKernel :: [BlockForging m blk] -> m ()
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
      , $sel:getPeerSharingAPI:NodeKernel :: PeerSharingAPI addrNTN StdGen m
getPeerSharingAPI       = PeerSharingAPI addrNTN StdGen m
peerSharingAPI
      , $sel:getOutboundConnectionsState:NodeKernel :: StrictTVar m OutboundConnectionsState
getOutboundConnectionsState
                                = StrictTVar m OutboundConnectionsState
varOutboundConnectionsState
      , DiffusionPipeliningSupport
$sel:getDiffusionPipeliningSupport:NodeKernel :: DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: DiffusionPipeliningSupport
getDiffusionPipeliningSupport
      }
  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 m blk]
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
          (Thread m Void -> m ()) -> [Thread m Void] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Thread m Void -> m ()
forall (m :: * -> *) a. MonadAsync m => Thread m a -> m ()
cancelThread [Thread m Void]
forgingThreads
          [Thread m Void]
blockForging' <- (BlockForging m blk -> m (Thread m Void))
-> [BlockForging m blk] -> m [Thread m Void]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (InternalState m remotePeer localPeer blk
-> BlockForging m blk -> m (Thread m Void)
forall (m :: * -> *) addrNTN addrNTC blk.
(IOLike m, RunNode blk) =>
InternalState m addrNTN addrNTC blk
-> BlockForging m blk -> m (Thread m Void)
forkBlockForging InternalState m remotePeer localPeer blk
st) [BlockForging m blk]
blockForging
          [Thread m Void] -> m Void
go [Thread m Void]
blockForging'

{-------------------------------------------------------------------------------
  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) (Header blk) blk m
blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (Header blk) blk m
    , forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
    , forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> StrictTVar
     m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles :: StrictTVar m (Map (ConnectionId addrNTN) (ChainSyncClientHandle 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
$sel:tracers:NodeKernelArgs :: 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
$sel:chainDB:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ChainDB m blk
chainDB :: ChainDB m blk
chainDB, ResourceRegistry m
$sel:registry:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ResourceRegistry m
registry :: ResourceRegistry m
registry, TopLevelConfig blk
$sel:cfg:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg
                                 , Header blk -> SizeInBytes
$sel:blockFetchSize:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> Header blk -> SizeInBytes
blockFetchSize :: Header blk -> SizeInBytes
blockFetchSize, BlockchainTime m
$sel:btime:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockchainTime m
btime :: BlockchainTime m
btime
                                 , MempoolCapacityBytesOverride
$sel:mempoolCapacityOverride:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> MempoolCapacityBytesOverride
mempoolCapacityOverride :: MempoolCapacityBytesOverride
mempoolCapacityOverride
                                 , GsmNodeKernelArgs m blk
$sel:gsmArgs:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GsmNodeKernelArgs m blk
gsmArgs :: GsmNodeKernelArgs m blk
gsmArgs, STM m UseBootstrapPeers
$sel:getUseBootstrapPeers:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> STM m UseBootstrapPeers
getUseBootstrapPeers :: STM m UseBootstrapPeers
getUseBootstrapPeers
                                 , DiffusionPipeliningSupport
$sel:getDiffusionPipeliningSupport:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: DiffusionPipeliningSupport
getDiffusionPipeliningSupport
                                 } = do
    StrictTVar m GsmState
varGsmState <- do
      let GsmNodeKernelArgs {Maybe (WrapDurationUntilTooOld m blk)
StdGen
NominalDiffTime
MarkerFileView m
gsmAntiThunderingHerd :: forall (m :: * -> *) blk. GsmNodeKernelArgs m blk -> StdGen
gsmDurationUntilTooOld :: forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> Maybe (WrapDurationUntilTooOld m blk)
gsmMarkerFileView :: forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> MarkerFileView m
gsmMinCaughtUpDuration :: forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> NominalDiffTime
gsmAntiThunderingHerd :: StdGen
gsmDurationUntilTooOld :: Maybe (WrapDurationUntilTooOld m blk)
gsmMarkerFileView :: MarkerFileView m
gsmMinCaughtUpDuration :: NominalDiffTime
..} = GsmNodeKernelArgs m blk
gsmArgs
      GsmState
gsmState <- m (LedgerState blk)
-> Maybe (WrapDurationUntilTooOld m blk)
-> MarkerFileView m
-> m GsmState
forall blk (m :: * -> *).
(GetTip (LedgerState blk), Monad m) =>
m (LedgerState blk)
-> Maybe (WrapDurationUntilTooOld m blk)
-> MarkerFileView m
-> m GsmState
GSM.initializationGsmState
        (STM m (LedgerState blk) -> m (LedgerState blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LedgerState blk) -> m (LedgerState blk))
-> STM m (LedgerState blk) -> m (LedgerState blk)
forall a b. (a -> b) -> a -> b
$ ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> STM m (ExtLedgerState blk) -> STM m (LedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
(Monad (STM m), IsLedger (LedgerState blk)) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB m blk
chainDB)
        Maybe (WrapDurationUntilTooOld m blk)
gsmDurationUntilTooOld
        MarkerFileView m
gsmMarkerFileView
      GsmState -> m (StrictTVar m GsmState)
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO GsmState
gsmState

    StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles <- Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)
-> m (StrictTVar
        m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)
forall a. Monoid a => a
mempty
    Mempool m blk
mempool       <- ResourceRegistry m
-> LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> m (Mempool m blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
ResourceRegistry m
-> LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> m (Mempool m blk)
openMempool ResourceRegistry m
registry
                                 (ChainDB m blk -> LedgerInterface m blk
forall (m :: * -> *) blk.
(IOLike m, IsLedger (LedgerState blk)) =>
ChainDB m blk -> LedgerInterface m blk
chainDBLedgerInterface ChainDB m blk
chainDB)
                                 (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg)
                                 MempoolCapacityBytesOverride
mempoolCapacityOverride
                                 (Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer m (TraceEventMempool blk)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f -> f (TraceEventMempool blk)
mempoolTracer Tracers m (ConnectionId addrNTN) addrNTC blk
tracers)

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

    let getCandidates :: STM m (Map (ConnectionId addrNTN) (AnchoredFragment (Header blk)))
        getCandidates :: STM m (Map (ConnectionId addrNTN) (AnchoredFragment (Header blk)))
getCandidates = StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
-> (ChainSyncState blk -> AnchoredFragment (Header blk))
-> STM
     m (Map (ConnectionId addrNTN) (AnchoredFragment (Header blk)))
forall (m :: * -> *) peer blk a.
IOLike m =>
StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> (ChainSyncState blk -> a) -> STM m (Map peer a)
viewChainSyncState StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles ChainSyncState blk -> AnchoredFragment (Header blk)
forall blk. ChainSyncState blk -> AnchoredFragment (Header blk)
csCandidate

    RealPoint blk -> STM m UTCTime
slotForgeTimeOracle <- TopLevelConfig blk
-> ChainDB m blk -> m (RealPoint blk -> STM m UTCTime)
forall (m :: * -> *) blk.
(IOLike m, BlockSupportsProtocol blk, HasHardForkHistory blk,
 ConfigSupportsNode blk, IsLedger (LedgerState blk)) =>
TopLevelConfig blk
-> ChainDB m blk -> m (SlotForgeTimeOracle m blk)
BlockFetchClientInterface.initSlotForgeTimeOracle TopLevelConfig blk
cfg ChainDB m blk
chainDB
    let readFetchMode :: STM m FetchMode
readFetchMode = BlockchainTime m
-> STM m (AnchoredFragment (Header blk))
-> STM m UseBootstrapPeers
-> STM m LedgerStateJudgement
-> STM m FetchMode
forall (m :: * -> *) blk.
(MonadSTM m, HasHeader blk) =>
BlockchainTime m
-> STM m (AnchoredFragment blk)
-> STM m UseBootstrapPeers
-> STM m LedgerStateJudgement
-> STM m FetchMode
BlockFetchClientInterface.readFetchModeDefault
          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) (Header blk) blk m
        blockFetchInterface :: BlockFetchConsensusInterface
  (ConnectionId addrNTN) (Header blk) blk m
blockFetchInterface = BlockConfig blk
-> ChainDbView m blk
-> STM
     m (Map (ConnectionId addrNTN) (AnchoredFragment (Header blk)))
-> (Header blk -> SizeInBytes)
-> (RealPoint blk -> STM m UTCTime)
-> STM m FetchMode
-> DiffusionPipeliningSupport
-> BlockFetchConsensusInterface
     (ConnectionId addrNTN) (Header blk) blk m
forall (m :: * -> *) peer blk.
(IOLike m, BlockSupportsDiffusionPipelining blk,
 BlockSupportsProtocol blk) =>
BlockConfig blk
-> ChainDbView m blk
-> STM m (Map peer (AnchoredFragment (Header blk)))
-> (Header blk -> SizeInBytes)
-> SlotForgeTimeOracle m blk
-> STM m FetchMode
-> DiffusionPipeliningSupport
-> BlockFetchConsensusInterface peer (Header blk) blk m
BlockFetchClientInterface.mkBlockFetchConsensusInterface
          (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg)
          (ChainDB m blk -> ChainDbView m blk
forall (m :: * -> *) blk.
IOLike m =>
ChainDB m blk -> ChainDbView m blk
BlockFetchClientInterface.defaultChainDbView ChainDB m blk
chainDB)
          STM m (Map (ConnectionId addrNTN) (AnchoredFragment (Header blk)))
getCandidates
          Header blk -> SizeInBytes
blockFetchSize
          RealPoint blk -> STM m UTCTime
slotForgeTimeOracle
          STM m FetchMode
readFetchMode
          DiffusionPipeliningSupport
getDiffusionPipeliningSupport

    PeerSharingRegistry addrNTN m
peerSharingRegistry <- m (PeerSharingRegistry addrNTN m)
forall (m :: * -> *) peer.
(MonadSTM m, Ord peer) =>
m (PeerSharingRegistry peer m)
newPeerSharingRegistry

    InternalState m addrNTN addrNTC blk
-> m (InternalState m addrNTN addrNTC blk)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return IS {StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
StrictTVar m GsmState
TopLevelConfig blk
Mempool m blk
BlockchainTime m
ChainDB m blk
ResourceRegistry m
BlockFetchConsensusInterface
  (ConnectionId addrNTN) (Header blk) blk m
PeerSharingRegistry addrNTN m
FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
Tracers m (ConnectionId addrNTN) addrNTC blk
$sel:blockFetchInterface:IS :: BlockFetchConsensusInterface
  (ConnectionId addrNTN) (Header blk) blk m
$sel:fetchClientRegistry:IS :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
$sel:mempool:IS :: Mempool m blk
$sel:peerSharingRegistry:IS :: PeerSharingRegistry addrNTN m
$sel:varChainSyncHandles:IS :: StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
$sel:varGsmState:IS :: StrictTVar m GsmState
$sel:tracers:IS :: Tracers m (ConnectionId addrNTN) addrNTC blk
$sel:cfg:IS :: TopLevelConfig blk
$sel:registry:IS :: ResourceRegistry m
$sel:btime:IS :: BlockchainTime m
$sel:chainDB:IS :: ChainDB m blk
tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
chainDB :: ChainDB m blk
registry :: ResourceRegistry m
cfg :: TopLevelConfig blk
btime :: BlockchainTime m
varGsmState :: StrictTVar m GsmState
varChainSyncHandles :: StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
mempool :: Mempool m blk
fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
blockFetchInterface :: BlockFetchConsensusInterface
  (ConnectionId addrNTN) (Header blk) blk m
peerSharingRegistry :: PeerSharingRegistry addrNTN m
..}

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 (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
StrictTVar m GsmState
TopLevelConfig blk
Mempool m blk
BlockchainTime m
ChainDB m blk
ResourceRegistry m
BlockFetchConsensusInterface
  (ConnectionId addrNTN) (Header blk) blk m
PeerSharingRegistry addrNTN m
FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
Tracers m (ConnectionId addrNTN) addrNTC blk
$sel:blockFetchInterface:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> BlockFetchConsensusInterface
     (ConnectionId addrNTN) (Header blk) blk m
$sel:fetchClientRegistry:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
$sel:mempool:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> Mempool m blk
$sel:peerSharingRegistry:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> PeerSharingRegistry addrNTN m
$sel:varChainSyncHandles:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> StrictTVar
     m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
$sel:varGsmState:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> StrictTVar m GsmState
$sel:tracers:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
$sel:cfg:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> TopLevelConfig blk
$sel:registry:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> ResourceRegistry m
$sel:btime:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> BlockchainTime m
$sel:chainDB:IS :: 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) (Header blk) blk m
fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
varChainSyncHandles :: StrictTVar
  m (Map (ConnectionId addrNTN) (ChainSyncClientHandle 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
$ WithEarlyExit m () -> m ()
forall (m :: * -> *). Functor m => WithEarlyExit m () -> m ()
withEarlyExit_ (WithEarlyExit m () -> m ())
-> (SlotNo -> WithEarlyExit m ()) -> SlotNo -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> WithEarlyExit m ()
go
  where
    threadLabel :: String
    threadLabel :: String
threadLabel =
        String
"NodeKernel.blockForging." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (BlockForging m blk -> Text
forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel BlockForging m blk
blockForging)

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

        -- Figure out which block to connect to
        --
        -- Normally this will be the current block at the tip, but it may
        -- be the /previous/ block, if there were multiple slot leaders
        BlockContext{BlockNo
bcBlockNo :: BlockNo
$sel:bcBlockNo:BlockContext :: forall blk. BlockContext blk -> BlockNo
bcBlockNo, Point blk
bcPrevPoint :: Point blk
$sel:bcPrevPoint:BlockContext :: forall blk. BlockContext blk -> Point blk
bcPrevPoint} <- do
          Either (TraceForgeEvent blk) (BlockContext blk)
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 Either (TraceForgeEvent blk) (BlockContext blk)
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

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

        -- Get ledger state corresponding to bcPrevPoint
        --
        -- This might fail if, in between choosing 'bcPrevPoint' and this call to
        -- 'getPastLedger', we switched to a fork where 'bcPrevPoint' is no longer
        -- on our chain. When that happens, we simply give up on the chance to
        -- produce a block.
        ExtLedgerState blk
unticked <- do
          Maybe (ExtLedgerState blk)
mExtLedger <- m (Maybe (ExtLedgerState blk))
-> WithEarlyExit m (Maybe (ExtLedgerState blk))
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe (ExtLedgerState blk))
 -> WithEarlyExit m (Maybe (ExtLedgerState blk)))
-> m (Maybe (ExtLedgerState blk))
-> WithEarlyExit m (Maybe (ExtLedgerState blk))
forall a b. (a -> b) -> a -> b
$ STM m (Maybe (ExtLedgerState blk))
-> m (Maybe (ExtLedgerState blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (ExtLedgerState blk))
 -> m (Maybe (ExtLedgerState blk)))
-> STM m (Maybe (ExtLedgerState blk))
-> m (Maybe (ExtLedgerState blk))
forall a b. (a -> b) -> a -> b
$ ChainDB m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk))
forall (m :: * -> *) blk.
(Monad (STM m), LedgerSupportsProtocol blk) =>
ChainDB m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk))
ChainDB.getPastLedger ChainDB m blk
chainDB Point blk
bcPrevPoint
          case Maybe (ExtLedgerState blk)
mExtLedger of
            Just ExtLedgerState blk
l  -> ExtLedgerState blk -> WithEarlyExit m (ExtLedgerState blk)
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. Monad m => a -> m a
return ExtLedgerState blk
l
            Maybe (ExtLedgerState blk)
Nothing -> do
              TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> Point blk -> TraceForgeEvent blk
forall blk. SlotNo -> Point blk -> TraceForgeEvent blk
TraceNoLedgerState SlotNo
currentSlot Point blk
bcPrevPoint
              WithEarlyExit m (ExtLedgerState blk)
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly

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

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

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

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

        -- Check if we are the leader
        IsLeader (BlockProtocol blk)
proof <- do
          ShouldForge blk
shouldForge <- m (ShouldForge blk) -> WithEarlyExit m (ShouldForge blk)
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ShouldForge blk) -> WithEarlyExit m (ShouldForge blk))
-> m (ShouldForge blk) -> WithEarlyExit m (ShouldForge blk)
forall a b. (a -> b) -> a -> b
$
            BlockForging m blk
-> Tracer m (ForgeStateInfo blk)
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ShouldForge blk)
forall (m :: * -> *) blk.
(Monad m, ConsensusProtocol (BlockProtocol blk), HasCallStack) =>
BlockForging m blk
-> Tracer m (ForgeStateInfo blk)
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ShouldForge blk)
checkShouldForge BlockForging m blk
blockForging
              ((ForgeStateInfo blk -> TraceLabelCreds (ForgeStateInfo blk))
-> Tracer m (TraceLabelCreds (ForgeStateInfo blk))
-> Tracer m (ForgeStateInfo blk)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (Text -> ForgeStateInfo blk -> TraceLabelCreds (ForgeStateInfo blk)
forall a. Text -> a -> TraceLabelCreds a
TraceLabelCreds (BlockForging m blk -> Text
forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel BlockForging m blk
blockForging))
                (Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer m (TraceLabelCreds (ForgeStateInfo blk))
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceLabelCreds (ForgeStateInfo blk))
forgeStateInfoTracer Tracers m (ConnectionId addrNTN) addrNTC blk
tracers))
              TopLevelConfig blk
cfg
              SlotNo
currentSlot
              Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState
          case ShouldForge blk
shouldForge of
            ForgeStateUpdateError ForgeStateUpdateError blk
err -> do
              TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> ForgeStateUpdateError blk -> TraceForgeEvent blk
forall blk.
SlotNo -> ForgeStateUpdateError blk -> TraceForgeEvent blk
TraceForgeStateUpdateError SlotNo
currentSlot ForgeStateUpdateError blk
err
              WithEarlyExit m (IsLeader (BlockProtocol blk))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
            CannotForge CannotForge blk
cannotForge -> do
              TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> CannotForge blk -> TraceForgeEvent blk
forall blk. SlotNo -> CannotForge blk -> TraceForgeEvent blk
TraceNodeCannotForge SlotNo
currentSlot CannotForge blk
cannotForge
              WithEarlyExit m (IsLeader (BlockProtocol blk))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
            ShouldForge blk
NotLeader -> do
              TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> TraceForgeEvent blk
forall blk. SlotNo -> TraceForgeEvent blk
TraceNodeNotLeader SlotNo
currentSlot
              WithEarlyExit m (IsLeader (BlockProtocol blk))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
            ShouldForge IsLeader (BlockProtocol blk)
p -> IsLeader (BlockProtocol blk)
-> WithEarlyExit m (IsLeader (BlockProtocol blk))
forall 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
        TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> TraceForgeEvent blk
forall blk. SlotNo -> TraceForgeEvent blk
TraceNodeIsLeader SlotNo
currentSlot

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

        TickedLedgerState blk
_ <- TickedLedgerState blk -> WithEarlyExit m (TickedLedgerState blk)
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate TickedLedgerState blk
tickedLedgerState
        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
TraceForgeTickedLedgerState SlotNo
currentSlot Point blk
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.
        (ChainHash blk
mempoolHash, SlotNo
mempoolSlotNo, MempoolSnapshot blk
mempoolSnapshot) <- m (ChainHash blk, SlotNo, MempoolSnapshot blk)
-> WithEarlyExit m (ChainHash blk, SlotNo, MempoolSnapshot 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 (ChainHash blk, SlotNo, MempoolSnapshot blk)
 -> WithEarlyExit m (ChainHash blk, SlotNo, MempoolSnapshot blk))
-> m (ChainHash blk, SlotNo, MempoolSnapshot blk)
-> WithEarlyExit m (ChainHash blk, SlotNo, MempoolSnapshot blk)
forall a b. (a -> b) -> a -> b
$ STM m (ChainHash blk, SlotNo, MempoolSnapshot blk)
-> m (ChainHash blk, SlotNo, MempoolSnapshot blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ChainHash blk, SlotNo, MempoolSnapshot blk)
 -> m (ChainHash blk, SlotNo, MempoolSnapshot blk))
-> STM m (ChainHash blk, SlotNo, MempoolSnapshot blk)
-> m (ChainHash blk, SlotNo, MempoolSnapshot blk)
forall a b. (a -> b) -> a -> b
$ do
            (ChainHash blk
mempoolHash, SlotNo
mempoolSlotNo) <- do
              MempoolSnapshot blk
snap <- Mempool m blk -> STM m (MempoolSnapshot blk)
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool m blk
mempool   -- only used for its tip-like information
              let h :: ChainHash blk
                  h :: ChainHash blk
h = ChainHash (TickedLedgerState blk) -> ChainHash blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash (ChainHash (TickedLedgerState blk) -> ChainHash blk)
-> ChainHash (TickedLedgerState blk) -> ChainHash blk
forall a b. (a -> b) -> a -> b
$ TickedLedgerState blk -> ChainHash (TickedLedgerState blk)
forall l. GetTip l => l -> ChainHash l
getTipHash (TickedLedgerState blk -> ChainHash (TickedLedgerState blk))
-> TickedLedgerState blk -> ChainHash (TickedLedgerState blk)
forall a b. (a -> b) -> a -> b
$ MempoolSnapshot blk -> TickedLedgerState blk
forall blk. MempoolSnapshot blk -> TickedLedgerState blk
snapshotLedgerState MempoolSnapshot blk
snap
              (ChainHash blk, SlotNo) -> STM m (ChainHash blk, SlotNo)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainHash blk
h, MempoolSnapshot blk -> SlotNo
forall blk. MempoolSnapshot blk -> SlotNo
snapshotSlotNo MempoolSnapshot blk
snap)

            MempoolSnapshot blk
snap <- Mempool m blk
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk)
forall (m :: * -> *) blk.
Mempool m blk
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk)
getSnapshotFor
                      Mempool m blk
mempool
                      (SlotNo -> TickedLedgerState blk -> ForgeLedgerState blk
forall blk. SlotNo -> TickedLedgerState blk -> ForgeLedgerState blk
ForgeInKnownSlot SlotNo
currentSlot TickedLedgerState blk
tickedLedgerState)
            (ChainHash blk, SlotNo, MempoolSnapshot blk)
-> STM m (ChainHash blk, SlotNo, MempoolSnapshot blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainHash blk
mempoolHash, SlotNo
mempoolSlotNo, MempoolSnapshot blk
snap)

        let txs :: [Validated (GenTx blk)]
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 -> TickedLedgerState blk -> TxMeasure blk
forall blk.
TxLimits blk =>
LedgerConfig blk -> TickedLedgerState blk -> TxMeasure blk
blockCapacityTxMeasure (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg) TickedLedgerState blk
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
        Int
_ <- Int -> WithEarlyExit m Int
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate ([Validated (GenTx blk)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Validated (GenTx blk)]
txs)
        TickedLedgerState blk
_ <- TickedLedgerState blk -> WithEarlyExit m (TickedLedgerState blk)
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate (MempoolSnapshot blk -> TickedLedgerState blk
forall blk. MempoolSnapshot blk -> TickedLedgerState blk
snapshotLedgerState MempoolSnapshot blk
mempoolSnapshot)
        TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo
-> Point blk -> ChainHash blk -> SlotNo -> TraceForgeEvent blk
forall blk.
SlotNo
-> Point blk -> ChainHash blk -> SlotNo -> TraceForgeEvent blk
TraceForgingMempoolSnapshot SlotNo
currentSlot Point blk
bcPrevPoint ChainHash blk
mempoolHash SlotNo
mempoolSlotNo

        -- Actually produce the block
        blk
newBlock <- m blk -> WithEarlyExit m blk
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m blk -> WithEarlyExit m blk) -> m blk -> WithEarlyExit m blk
forall a b. (a -> b) -> a -> b
$
          BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
Block.forgeBlock BlockForging m blk
blockForging
            TopLevelConfig blk
cfg
            BlockNo
bcBlockNo
            SlotNo
currentSlot
            TickedLedgerState blk
tickedLedgerState
            [Validated (GenTx blk)]
txs
            IsLeader (BlockProtocol blk)
proof

        TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> Point blk -> blk -> MempoolSize -> TraceForgeEvent blk
forall blk.
SlotNo -> Point blk -> blk -> MempoolSize -> TraceForgeEvent blk
TraceForgedBlock
                  SlotNo
currentSlot
                  (LedgerState blk -> Point blk
forall blk. UpdateLedger blk => LedgerState blk -> Point blk
ledgerTipPoint (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
unticked))
                  blk
newBlock
                  (MempoolSnapshot blk -> MempoolSize
forall blk. MempoolSnapshot blk -> MempoolSize
snapshotMempoolSize MempoolSnapshot blk
mempoolSnapshot)

        -- Add the block to the chain DB
        let noPunish :: InvalidBlockPunishment m
noPunish = InvalidBlockPunishment m
forall (m :: * -> *). Applicative m => InvalidBlockPunishment m
InvalidBlockPunishment.noPunishment   -- no way to punish yourself
        -- Make sure that if an async exception is thrown while a block is
        -- added to the chain db, we will remove txs from the mempool.

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

          -- Check whether we adopted our block
          Bool -> WithEarlyExit m () -> WithEarlyExit m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AddBlockResult blk
mbCurTip AddBlockResult blk -> AddBlockResult blk -> Bool
forall a. Eq a => a -> a -> Bool
/= Point blk -> AddBlockResult blk
forall blk. Point blk -> AddBlockResult blk
SuccesfullyAddedBlock (blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint blk
newBlock)) (WithEarlyExit m () -> WithEarlyExit m ())
-> WithEarlyExit m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ do
            Maybe (ExtValidationError blk)
isInvalid <- m (Maybe (ExtValidationError blk))
-> WithEarlyExit m (Maybe (ExtValidationError 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 (Maybe (ExtValidationError blk))
 -> WithEarlyExit m (Maybe (ExtValidationError blk)))
-> m (Maybe (ExtValidationError blk))
-> WithEarlyExit m (Maybe (ExtValidationError blk))
forall a b. (a -> b) -> a -> b
$ STM m (Maybe (ExtValidationError blk))
-> m (Maybe (ExtValidationError blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (ExtValidationError blk))
 -> m (Maybe (ExtValidationError blk)))
-> STM m (Maybe (ExtValidationError blk))
-> m (Maybe (ExtValidationError blk))
forall a b. (a -> b) -> a -> b
$
              ((HeaderHash blk -> Maybe (ExtValidationError blk))
-> HeaderHash blk -> Maybe (ExtValidationError blk)
forall a b. (a -> b) -> a -> b
$ blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
newBlock) ((HeaderHash blk -> Maybe (ExtValidationError blk))
 -> Maybe (ExtValidationError blk))
-> (WithFingerprint
      (HeaderHash blk -> Maybe (ExtValidationError blk))
    -> HeaderHash blk -> Maybe (ExtValidationError blk))
-> WithFingerprint
     (HeaderHash blk -> Maybe (ExtValidationError blk))
-> Maybe (ExtValidationError blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithFingerprint (HeaderHash blk -> Maybe (ExtValidationError blk))
-> HeaderHash blk -> Maybe (ExtValidationError blk)
forall a. WithFingerprint a -> a
forgetFingerprint (WithFingerprint (HeaderHash blk -> Maybe (ExtValidationError blk))
 -> Maybe (ExtValidationError blk))
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
-> STM m (Maybe (ExtValidationError blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              ChainDB m blk
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
forall (m :: * -> *) blk.
ChainDB m blk
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
ChainDB.getIsInvalidBlock ChainDB m blk
chainDB
            case Maybe (ExtValidationError blk)
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.
                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
$ Mempool m blk -> [GenTxId blk] -> m ()
forall (m :: * -> *) blk. Mempool m blk -> [GenTxId blk] -> m ()
removeTxs Mempool m blk
mempool ((Validated (GenTx blk) -> GenTxId blk)
-> [Validated (GenTx blk)] -> [GenTxId blk]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId (GenTx blk -> GenTxId blk)
-> (Validated (GenTx blk) -> GenTx blk)
-> Validated (GenTx blk)
-> GenTxId 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)
            WithEarlyExit m ()
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
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@.
        TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> blk -> [Validated (GenTx blk)] -> TraceForgeEvent blk
forall blk.
SlotNo -> blk -> [Validated (GenTx blk)] -> TraceForgeEvent blk
TraceAdoptedBlock SlotNo
currentSlot blk
newBlock [Validated (GenTx blk)]
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
  => SlotNo
     -- ^ the current slot, i.e. the slot of the block about to be forged
  -> AnchoredFragment (Header blk)
     -- ^ the current chain fragment
     --
     -- Recall that the anchor point is the tip of the ImmutableDB.
  -> Either (TraceForgeEvent blk) (BlockContext blk)
     -- ^ the event records the cause of the failure
mkCurrentBlockContext :: 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, ByteSize32)]
snapshotTxsAfter :: TicketNo -> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxsAfter :: forall blk.
MempoolSnapshot blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo, ByteSize32)]
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
byteSize
              )
            | (Validated (GenTx blk)
tx, TicketNo
idx', ByteSize32
byteSize) <- TicketNo -> [(Validated (GenTx blk), TicketNo, ByteSize32)]
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 -> Bool)
  -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
getPeersFromCurrentLedger :: forall (m :: * -> *) blk addrNTN addrNTC.
(IOLike m, LedgerSupportsPeerSelection blk) =>
NodeKernel m addrNTN addrNTC blk
-> (LedgerState blk -> Bool)
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
getPeersFromCurrentLedger NodeKernel m addrNTN addrNTC blk
kernel LedgerState blk -> Bool
p = do
    LedgerState blk
immutableLedger <-
      ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> STM m (ExtLedgerState blk) -> STM m (LedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
Monad (STM m) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
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)
    Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
 -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)]))
-> Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
forall a b. (a -> b) -> a -> b
$ do
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (LedgerState blk -> Bool
p LedgerState blk
immutableLedger)
      [(PoolStake, NonEmpty RelayAccessPoint)]
-> Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ([(PoolStake, NonEmpty RelayAccessPoint)]
 -> Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
forall a b. (a -> b) -> a -> b
$ ((PoolStake, NonEmpty StakePoolRelay)
 -> (PoolStake, NonEmpty RelayAccessPoint))
-> [(PoolStake, NonEmpty StakePoolRelay)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall a b. (a -> b) -> [a] -> [b]
map ((NonEmpty StakePoolRelay -> NonEmpty RelayAccessPoint)
-> (PoolStake, NonEmpty StakePoolRelay)
-> (PoolStake, NonEmpty RelayAccessPoint)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((StakePoolRelay -> RelayAccessPoint)
-> NonEmpty StakePoolRelay -> NonEmpty RelayAccessPoint
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StakePoolRelay -> RelayAccessPoint
stakePoolRelayAccessPoint))
        ([(PoolStake, NonEmpty StakePoolRelay)]
 -> [(PoolStake, NonEmpty RelayAccessPoint)])
-> [(PoolStake, NonEmpty StakePoolRelay)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall a b. (a -> b) -> a -> b
$ [(PoolStake, NonEmpty StakePoolRelay)]
-> [(PoolStake, NonEmpty StakePoolRelay)]
forall a. NFData a => a -> a
force
        ([(PoolStake, NonEmpty StakePoolRelay)]
 -> [(PoolStake, NonEmpty StakePoolRelay)])
-> [(PoolStake, NonEmpty StakePoolRelay)]
-> [(PoolStake, NonEmpty StakePoolRelay)]
forall a b. (a -> b) -> a -> b
$ LedgerState blk -> [(PoolStake, NonEmpty StakePoolRelay)]
forall blk.
LedgerSupportsPeerSelection blk =>
LedgerState blk -> [(PoolStake, NonEmpty StakePoolRelay)]
getPeers LedgerState blk
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 -> Bool)
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
forall (m :: * -> *) blk addrNTN addrNTC.
(IOLike m, LedgerSupportsPeerSelection blk) =>
NodeKernel m addrNTN addrNTC blk
-> (LedgerState blk -> Bool)
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
getPeersFromCurrentLedger NodeKernel m addrNTN addrNTC blk
kernel LedgerState blk -> Bool
afterSlotNo
  where
    afterSlotNo :: LedgerState blk -> Bool
    afterSlotNo :: LedgerState blk -> Bool
afterSlotNo LedgerState blk
st =
      case LedgerState blk -> WithOrigin SlotNo
forall blk.
UpdateLedger blk =>
LedgerState blk -> WithOrigin SlotNo
ledgerTipSlot LedgerState blk
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 -> WithOrigin SlotNo
forall l. GetTip l => l -> WithOrigin SlotNo
getTipSlot
    (ExtLedgerState blk -> WithOrigin SlotNo)
-> STM m (ExtLedgerState blk) -> STM m (WithOrigin SlotNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
Monad (STM m) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
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)