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

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


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

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

-- | Interface against running relay node
data NodeKernel m addrNTN addrNTC blk = NodeKernel {
      -- | 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) (HeaderWithTime blk) blk m
getFetchClientRegistry  :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime 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
-> ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk
getChainSyncHandles     :: ChainSyncClientHandleCollection (ConnectionId addrNTN) 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
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> BlockchainTime m
getBlockchainTime      :: BlockchainTime m
    }

-- | Arguments required when initializing a node
data NodeKernelArgs m addrNTN addrNTC blk = NodeKernelArgs {
      forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
tracers                 :: Tracers m (ConnectionId addrNTN) addrNTC blk
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ResourceRegistry m
registry                :: ResourceRegistry m
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> TopLevelConfig blk
cfg                     :: TopLevelConfig blk
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockchainTime m
btime                   :: BlockchainTime m
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ChainDB m blk
chainDB                 :: ChainDB m blk
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB             :: StorageConfig blk -> InitChainDB m blk -> m ()
    , forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> SomeHeaderInFutureCheck m blk
chainSyncFutureCheck    :: SomeHeaderInFutureCheck m blk
      -- | 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
registry :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ResourceRegistry m
registry :: ResourceRegistry m
registry, TopLevelConfig blk
cfg :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg, Tracers m (ConnectionId addrNTN) addrNTC blk
tracers :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
tracers
                                   , ChainDB m blk
chainDB :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ChainDB m blk
chainDB :: ChainDB m blk
chainDB, StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB :: StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB
                                   , BlockFetchConfiguration
blockFetchConfiguration :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockFetchConfiguration
blockFetchConfiguration :: BlockFetchConfiguration
blockFetchConfiguration
                                   , BlockchainTime m
btime :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockchainTime m
btime :: BlockchainTime m
btime
                                   , GsmNodeKernelArgs m blk
gsmArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GsmNodeKernelArgs m blk
gsmArgs :: GsmNodeKernelArgs m blk
gsmArgs
                                   , StdGen
peerSharingRng :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> StdGen
peerSharingRng :: StdGen
peerSharingRng
                                   , StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar :: StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar
                                   , GenesisNodeKernelArgs m blk
genesisArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GenesisNodeKernelArgs m blk
genesisArgs :: GenesisNodeKernelArgs m blk
genesisArgs
                                   , DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: DiffusionPipeliningSupport
getDiffusionPipeliningSupport
                                   } = do
    -- using a lazy 'TVar', 'BlockForging' does not have a 'NoThunks' instance.
    blockForgingVar :: LazySTM.TMVar m [BlockForging m blk] <- [BlockForging m blk] -> m (TMVar m [BlockForging m blk])
forall a. a -> m (TMVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TMVar m a)
LazySTM.newTMVarIO []
    initChainDB (configStorage cfg) (InitChainDB.fromFull chainDB)

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

    varOutboundConnectionsState <- newTVarIO UntrustedState

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

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

    peerSharingAPI <- newPeerSharingAPI publicPeerSelectionStateVar
                                        peerSharingRng
                                        ps_POLICY_PEER_SHARE_STICKY_TIME
                                        ps_POLICY_PEER_SHARE_MAX_PEERS

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

        void $ forkLinkedWatcher registry "NodeKernel.GDD" $
          gddWatcher
            cfg
            (gddTracer tracers)
            chainDB
            (lgnkaGDDRateLimit lgArgs)
            (readTVar varGsmState)
            -- TODO GDD should only consider (big) ledger peers
            (cschcMap varChainSyncHandles)
            varLoEFragment

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

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

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

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

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

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

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

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

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

    fetchClientRegistry <- newFetchClientRegistry

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

    peerSharingRegistry <- newPeerSharingRegistry

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

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

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

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

      trace $ TraceBlockContext currentSlot bcBlockNo bcPrevPoint

      -- Get forker corresponding to bcPrevPoint
      --
      -- This might fail if, in between choosing 'bcPrevPoint' and this call to
      -- 'ChainDB.getReadOnlyForkerAtPoint', we switched to a fork where 'bcPrevPoint'
      -- is no longer on our chain. When that happens, we simply give up on the
      -- chance to produce a block.
      forkerEith <- lift $ ChainDB.getReadOnlyForkerAtPoint chainDB reg (SpecificPoint bcPrevPoint)
      -- Remember to close this forker before exiting!
      forker <- case forkerEith of
        Left GetForkerError
_ -> do
          TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> Point blk -> TraceForgeEvent blk
forall blk. SlotNo -> Point blk -> TraceForgeEvent blk
TraceNoLedgerState SlotNo
currentSlot Point blk
bcPrevPoint
          WithEarlyExit m (ReadOnlyForker' m blk)
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
        Right ReadOnlyForker' m blk
forker -> ReadOnlyForker' m blk -> WithEarlyExit m (ReadOnlyForker' m blk)
forall a. a -> WithEarlyExit m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReadOnlyForker' m blk
forker

      unticked <- lift $ atomically $ LedgerDB.roforkerGetLedgerState forker

      trace $ TraceLedgerState currentSlot bcPrevPoint

      -- We require the ticked ledger view in order to construct the ticked
      -- 'ChainDepState'.
      ledgerView <-
        case runExcept $ forecastFor
                          (ledgerViewForecastAt
                            (configLedger cfg)
                            (ledgerState unticked))
                          currentSlot of
          Left OutsideForecastRange
err -> do
            -- There are so many empty slots between the tip of our chain and the
            -- current slot that we cannot get an ledger view anymore In
            -- principle, this is no problem; we can still produce a block (we use
            -- the ticked ledger state). However, we probably don't /want/ to
            -- produce a block in this case; we are most likely missing a blocks
            -- on our chain.
            TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> OutsideForecastRange -> TraceForgeEvent blk
forall blk. SlotNo -> OutsideForecastRange -> TraceForgeEvent blk
TraceNoLedgerView SlotNo
currentSlot OutsideForecastRange
err
            m () -> WithEarlyExit m ()
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithEarlyExit m ()) -> m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ ReadOnlyForker' m blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> m ()
roforkerClose ReadOnlyForker' m blk
forker
            WithEarlyExit m (LedgerView (BlockProtocol blk))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
          Right LedgerView (BlockProtocol blk)
lv ->
            LedgerView (BlockProtocol blk)
-> WithEarlyExit m (LedgerView (BlockProtocol blk))
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. Monad m => a -> m a
return LedgerView (BlockProtocol blk)
lv

      trace $ TraceLedgerView currentSlot

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

      -- Check if we are the leader
      proof <- do
        shouldForge <- lift $
          checkShouldForge
            blockForging
            (contramap (TraceLabelCreds (forgeLabel blockForging))
              (forgeStateInfoTracer tracers))
            cfg
            currentSlot
            tickedChainDepState
        case shouldForge of
          ForgeStateUpdateError ForgeStateUpdateError blk
err -> do
            TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> ForgeStateUpdateError blk -> TraceForgeEvent blk
forall blk.
SlotNo -> ForgeStateUpdateError blk -> TraceForgeEvent blk
TraceForgeStateUpdateError SlotNo
currentSlot ForgeStateUpdateError blk
err
            m () -> WithEarlyExit m ()
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithEarlyExit m ()) -> m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ ReadOnlyForker' m blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> m ()
roforkerClose ReadOnlyForker' m blk
forker
            WithEarlyExit m (IsLeader (BlockProtocol blk))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
          CannotForge CannotForge blk
cannotForge -> do
            TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> CannotForge blk -> TraceForgeEvent blk
forall blk. SlotNo -> CannotForge blk -> TraceForgeEvent blk
TraceNodeCannotForge SlotNo
currentSlot CannotForge blk
cannotForge
            m () -> WithEarlyExit m ()
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithEarlyExit m ()) -> m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ ReadOnlyForker' m blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> m ()
roforkerClose ReadOnlyForker' m blk
forker
            WithEarlyExit m (IsLeader (BlockProtocol blk))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
          ShouldForge blk
NotLeader -> do
            TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> TraceForgeEvent blk
forall blk. SlotNo -> TraceForgeEvent blk
TraceNodeNotLeader SlotNo
currentSlot
            m () -> WithEarlyExit m ()
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithEarlyExit m ()) -> m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ ReadOnlyForker' m blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> m ()
roforkerClose ReadOnlyForker' m blk
forker
            WithEarlyExit m (IsLeader (BlockProtocol blk))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
          ShouldForge IsLeader (BlockProtocol blk)
p -> IsLeader (BlockProtocol blk)
-> WithEarlyExit m (IsLeader (BlockProtocol blk))
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. Monad m => a -> m a
return IsLeader (BlockProtocol blk)
p

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

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

      _ <- evaluate tickedLedgerState
      trace $ TraceForgeTickedLedgerState currentSlot bcPrevPoint

      -- Get a snapshot of the mempool that is consistent with the ledger
      --
      -- NOTE: It is possible that due to adoption of new blocks the
      -- /current/ ledger will have changed. This doesn't matter: we will
      -- produce a block that fits onto the ledger we got above; if the
      -- ledger in the meantime changes, the block we produce here may or
      -- may not be adopted, but it won't be invalid.
      (mempoolHash, mempoolSlotNo) <- lift $ atomically $ do
        snap <- getSnapshot mempool   -- only used for its tip-like information
        pure (castHash $ snapshotStateHash snap, snapshotSlotNo snap)

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

      mempoolSnapshot <- lift $ getSnapshotFor
                                  mempool
                                  currentSlot
                                  tickedLedgerState
                                  readTables

      lift $ roforkerClose forker

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

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

      trace $ TraceForgingMempoolSnapshot currentSlot bcPrevPoint mempoolHash mempoolSlotNo

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

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

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

      -- 'addBlockAsync' is a non-blocking action, so `mask_` would suffice,
      -- but the finalizer is a blocking operation, hence we need to use
      -- 'uninterruptibleMask_' to make sure that async exceptions do not
      -- interrupt it.
      uninterruptibleMask_ $ do
        result <- lift $ ChainDB.addBlockAsync chainDB noPunish newBlock
        -- Block until we have processed the block
        mbCurTip <- lift $ atomically $ ChainDB.blockProcessed result

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

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

    trace :: TraceForgeEvent blk -> WithEarlyExit m ()
    trace :: TraceForgeEvent blk -> WithEarlyExit m ()
trace =
          m () -> WithEarlyExit m ()
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
        (m () -> WithEarlyExit m ())
-> (TraceForgeEvent blk -> m ())
-> TraceForgeEvent blk
-> WithEarlyExit m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracer m (TraceLabelCreds (TraceForgeEvent blk))
-> TraceLabelCreds (TraceForgeEvent blk) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer m (TraceLabelCreds (TraceForgeEvent blk))
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceLabelCreds (TraceForgeEvent blk))
forgeTracer Tracers m (ConnectionId addrNTN) addrNTC blk
tracers)
        (TraceLabelCreds (TraceForgeEvent blk) -> m ())
-> (TraceForgeEvent blk -> TraceLabelCreds (TraceForgeEvent blk))
-> TraceForgeEvent blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> TraceForgeEvent blk -> TraceLabelCreds (TraceForgeEvent blk)
forall a. Text -> a -> TraceLabelCreds a
TraceLabelCreds (BlockForging m blk -> Text
forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel BlockForging m blk
blockForging)

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

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

-- | Determine the 'BlockContext' for a block about to be forged from the
-- current slot, ChainDB chain fragment, and ChainDB tip block number
--
-- The 'bcPrevPoint' will either refer to the header at the tip of the current
-- chain or, in case there is already a block in this slot (e.g. another node
-- was also elected leader and managed to produce a block before us), the tip's
-- predecessor. If the chain is empty, then it will refer to the chain's anchor
-- point, which may be genesis.
mkCurrentBlockContext ::
     forall blk. RunNode blk
  => 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, TxMeasure blk)]
snapshotTxsAfter :: TicketNo -> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxsAfter :: forall blk.
MempoolSnapshot blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxsAfter, TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx :: TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx :: forall blk.
MempoolSnapshot blk -> TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx,
                                      GenTxId blk -> Bool
snapshotHasTx :: GenTxId blk -> Bool
snapshotHasTx :: forall blk. MempoolSnapshot blk -> GenTxId blk -> Bool
snapshotHasTx } =
      MempoolReader.MempoolSnapshot
        { mempoolTxIdsAfter :: TicketNo -> [(GenTxId blk, TicketNo, SizeInBytes)]
mempoolTxIdsAfter = \TicketNo
idx ->
            [ ( GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId (Validated (GenTx blk) -> GenTx blk
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated (GenTx blk)
tx)
              , TicketNo
idx'
              , Word32 -> SizeInBytes
SizeInBytes (Word32 -> SizeInBytes) -> Word32 -> SizeInBytes
forall a b. (a -> b) -> a -> b
$ ByteSize32 -> Word32
unByteSize32 (ByteSize32 -> Word32) -> ByteSize32 -> Word32
forall a b. (a -> b) -> a -> b
$ TxMeasure blk -> ByteSize32
forall a. HasByteSize a => a -> ByteSize32
txMeasureByteSize TxMeasure blk
msr
              )
            | (Validated (GenTx blk)
tx, TicketNo
idx', TxMeasure blk
msr) <- TicketNo -> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxsAfter TicketNo
idx
            ]
        , mempoolLookupTx :: TicketNo -> Maybe (Validated (GenTx blk))
mempoolLookupTx   = TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx
        , mempoolHasTx :: GenTxId blk -> Bool
mempoolHasTx      = GenTxId blk -> Bool
snapshotHasTx
        }

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

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

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

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

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