{-# 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 (..)
  , getMempoolReader
  , getMempoolWriter
  , getPeersFromCurrentLedger
  , getPeersFromCurrentLedgerAfterSlot
  , initNodeKernel
  ) where



import           Control.DeepSeq (force)
import           Control.Monad
import           Control.Monad.Except
import           Data.Bifunctor (second)
import           Data.Hashable (Hashable)
import           Data.List.NonEmpty (NonEmpty)
import           Data.Map.Strict (Map)
import           Data.Maybe (isJust, mapMaybe)
import           Data.Proxy
import qualified Data.Text as Text
import           Data.Time.Clock (UTCTime)
import           GHC.Stack (HasCallStack)
import           System.Random (StdGen)

import           Control.Tracer

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

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

import           Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import           Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment
                     (InvalidBlockPunishment)
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

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

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

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

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

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

      -- | The fetch mode, used by diffusion.
      --
    , NodeKernel m remotePeer localPeer blk -> STM m FetchMode
getFetchMode           :: STM m FetchMode

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

initBlockFetchConsensusInterface
    :: forall m peer blk.
       ( IOLike m
       , BlockSupportsProtocol blk
       , SupportsNode.ConfigSupportsNode blk
       , History.HasHardForkHistory blk
       , IsLedger (LedgerState blk)
       )
    => TopLevelConfig blk
    -> ChainDB m blk
    -> STM m (Map peer (AnchoredFragment (Header blk)))
    -> (Header blk -> SizeInBytes)
    -> BlockchainTime m
    -> m (BlockFetchConsensusInterface peer (Header blk) blk m)
initBlockFetchConsensusInterface :: TopLevelConfig blk
-> ChainDB m blk
-> STM m (Map peer (AnchoredFragment (Header blk)))
-> (Header blk -> SizeInBytes)
-> BlockchainTime m
-> m (BlockFetchConsensusInterface peer (Header blk) blk m)
initBlockFetchConsensusInterface TopLevelConfig blk
cfg ChainDB m blk
chainDB STM m (Map peer (AnchoredFragment (Header blk)))
getCandidates Header blk -> SizeInBytes
blockFetchSize BlockchainTime m
btime = do
    RunWithCachedSummary (HardForkIndices blk) m
cache <-
      STM m (Summary (HardForkIndices blk))
-> m (RunWithCachedSummary (HardForkIndices blk) m)
forall (m :: * -> *) (xs :: [*]).
MonadSTM m =>
STM m (Summary xs) -> m (RunWithCachedSummary xs m)
History.runWithCachedSummary
        (ExtLedgerState blk -> Summary (HardForkIndices blk)
toSummary (ExtLedgerState blk -> Summary (HardForkIndices blk))
-> STM m (ExtLedgerState blk)
-> STM m (Summary (HardForkIndices blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
(Monad (STM m), IsLedger (LedgerState blk)) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB m blk
chainDB)
    let slotToUTCTime :: RealPoint blk -> STM m UTCTime
slotToUTCTime RealPoint blk
rp =
              (Either PastHorizonException RelativeTime -> UTCTime)
-> STM m (Either PastHorizonException RelativeTime)
-> STM m UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                ((PastHorizonException -> UTCTime)
-> (RelativeTime -> UTCTime)
-> Either PastHorizonException RelativeTime
-> UTCTime
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PastHorizonException -> UTCTime
errMsg RelativeTime -> UTCTime
toAbsolute)
            (STM m (Either PastHorizonException RelativeTime) -> STM m UTCTime)
-> STM m (Either PastHorizonException RelativeTime)
-> STM m UTCTime
forall a b. (a -> b) -> a -> b
$ RunWithCachedSummary (HardForkIndices blk) m
-> Qry RelativeTime
-> STM m (Either PastHorizonException RelativeTime)
forall (xs :: [*]) (m :: * -> *).
RunWithCachedSummary xs m
-> forall a. Qry a -> STM m (Either PastHorizonException a)
History.cachedRunQuery
                RunWithCachedSummary (HardForkIndices blk) m
cache
                ((RelativeTime, SlotLength) -> RelativeTime
forall a b. (a, b) -> a
fst ((RelativeTime, SlotLength) -> RelativeTime)
-> Qry (RelativeTime, SlotLength) -> Qry RelativeTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotNo -> Qry (RelativeTime, SlotLength)
History.slotToWallclock (RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot RealPoint blk
rp))
          where
            -- This @cachedRunQuery@ fail for the following reasons.
            --
            -- By the PRECONDITIONs documented in the 'headerForgeUTCTime', we
            -- can assume that the given header was validated by the ChainSync
            -- client. This means its slot was, at some point, within the ledger
            -- view forecast range of the ledger state of our contemporary
            -- intersection with the header itself (and that intersection
            -- extended our contemporary immutable tip). A few additional facts
            -- ensure that we will always be able to thereafter correctly
            -- convert that header's slot using our current chain's ledger
            -- state.
            --
            --   o For under-developed reasons, the ledger view forecast range
            --     is equivalent to the time forecast range, ie " Definition
            --     17.2 (Forecast range) " from The Consensus Report.
            --
            --   o Because rollback is bounded, our currently selected chain
            --     will always be an evolution (ie " switch(n, bs) ") of that
            --     intersection point. (This one is somewhat obvious in
            --     retrospect, but we're being explicit here in order to
            --     emphasize the relation to the " chain evolution " jargon.)
            --
            --   o Because " stability itself is stable ", the HFC satisfies "
            --     Property 17.3 (Time conversions stable under chain evolution)
            --     " from The Consensus Report.
            errMsg :: PastHorizonException -> UTCTime
errMsg PastHorizonException
err =
              String -> UTCTime
forall a. HasCallStack => String -> a
error (String -> UTCTime) -> String -> UTCTime
forall a b. (a -> b) -> a -> b
$
                 String
"Consensus could not determine forge UTCTime!"
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> RealPoint blk -> String
forall a. Show a => a -> String
show RealPoint blk
rp
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PastHorizonException -> String
forall a. Show a => a -> String
show PastHorizonException
err
        headerForgeUTCTime :: FromConsensus (Header blk) -> STM m UTCTime
headerForgeUTCTime = RealPoint blk -> STM m UTCTime
slotToUTCTime (RealPoint blk -> STM m UTCTime)
-> (FromConsensus (Header blk) -> RealPoint blk)
-> FromConsensus (Header blk)
-> STM m UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header blk -> RealPoint blk
forall blk. HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint (Header blk -> RealPoint blk)
-> (FromConsensus (Header blk) -> Header blk)
-> FromConsensus (Header blk)
-> RealPoint blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromConsensus (Header blk) -> Header blk
forall a. FromConsensus a -> a
unFromConsensus
        blockForgeUTCTime :: FromConsensus blk -> STM m UTCTime
blockForgeUTCTime  = RealPoint blk -> STM m UTCTime
slotToUTCTime (RealPoint blk -> STM m UTCTime)
-> (FromConsensus blk -> RealPoint blk)
-> FromConsensus blk
-> STM m UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint  (blk -> RealPoint blk)
-> (FromConsensus blk -> blk) -> FromConsensus blk -> RealPoint blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromConsensus blk -> blk
forall a. FromConsensus a -> a
unFromConsensus

    BlockFetchConsensusInterface peer (Header blk) blk m
-> m (BlockFetchConsensusInterface peer (Header blk) blk m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlockFetchConsensusInterface :: forall peer header block (m :: * -> *).
STM m (Map peer (AnchoredFragment header))
-> STM m (AnchoredFragment header)
-> STM m FetchMode
-> STM m (Point block -> Bool)
-> (WhetherReceivingTentativeBlocks
    -> STM m (Point block -> block -> m ()))
-> STM m MaxSlotNo
-> (HasCallStack =>
    AnchoredFragment header -> AnchoredFragment header -> Bool)
-> (HasCallStack =>
    AnchoredFragment header -> AnchoredFragment header -> Ordering)
-> (header -> SizeInBytes)
-> (header -> block -> Bool)
-> (FromConsensus header -> STM m UTCTime)
-> (FromConsensus block -> STM m UTCTime)
-> BlockFetchConsensusInterface peer header block m
BlockFetchConsensusInterface {STM m (Map peer (AnchoredFragment (Header blk)))
STM m FetchMode
STM m MaxSlotNo
STM m (AnchoredFragment (Header blk))
STM m (Point blk -> Bool)
HasCallStack =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Bool
HasCallStack =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Ordering
WhetherReceivingTentativeBlocks -> STM m (Point blk -> blk -> m ())
FromConsensus blk -> STM m UTCTime
FromConsensus (Header blk) -> STM m UTCTime
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Ordering
Header blk -> SizeInBytes
Header blk -> blk -> Bool
readCandidateChains :: STM m (Map peer (AnchoredFragment (Header blk)))
readCurrentChain :: STM m (AnchoredFragment (Header blk))
readFetchedBlocks :: STM m (Point blk -> Bool)
mkAddFetchedBlock :: WhetherReceivingTentativeBlocks -> STM m (Point blk -> blk -> m ())
readFetchedMaxSlotNo :: STM m MaxSlotNo
plausibleCandidateChain :: HasCallStack =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Bool
compareCandidateChains :: HasCallStack =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Ordering
blockFetchSize :: Header blk -> SizeInBytes
blockMatchesHeader :: Header blk -> blk -> Bool
headerForgeUTCTime :: FromConsensus (Header blk) -> STM m UTCTime
blockForgeUTCTime :: FromConsensus blk -> STM m UTCTime
compareCandidateChains :: AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Ordering
plausibleCandidateChain :: HasCallStack =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Bool
readFetchedMaxSlotNo :: STM m MaxSlotNo
mkAddFetchedBlock :: WhetherReceivingTentativeBlocks -> STM m (Point blk -> blk -> m ())
readFetchedBlocks :: STM m (Point blk -> Bool)
readFetchMode :: STM m FetchMode
readCurrentChain :: STM m (AnchoredFragment (Header blk))
readCandidateChains :: STM m (Map peer (AnchoredFragment (Header blk)))
blockMatchesHeader :: Header blk -> blk -> Bool
blockForgeUTCTime :: FromConsensus blk -> STM m UTCTime
headerForgeUTCTime :: FromConsensus (Header blk) -> STM m UTCTime
blockFetchSize :: Header blk -> SizeInBytes
readFetchMode :: STM m FetchMode
..}
  where
    toSummary ::
         ExtLedgerState blk
      -> History.Summary (History.HardForkIndices blk)
    toSummary :: ExtLedgerState blk -> Summary (HardForkIndices blk)
toSummary = LedgerConfig blk
-> LedgerState blk -> Summary (HardForkIndices blk)
forall blk.
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk -> Summary (HardForkIndices blk)
History.hardForkSummary (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg) (LedgerState blk -> Summary (HardForkIndices blk))
-> (ExtLedgerState blk -> LedgerState blk)
-> ExtLedgerState blk
-> Summary (HardForkIndices blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState

    toAbsolute :: RelativeTime -> UTCTime
    toAbsolute :: RelativeTime -> UTCTime
toAbsolute =
        SystemStart -> RelativeTime -> UTCTime
fromRelativeTime (BlockConfig blk -> SystemStart
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> SystemStart
SupportsNode.getSystemStart (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg))

    bcfg :: BlockConfig blk
    bcfg :: BlockConfig blk
bcfg = TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg

    blockMatchesHeader :: Header blk -> blk -> Bool
    blockMatchesHeader :: Header blk -> blk -> Bool
blockMatchesHeader = Header blk -> blk -> Bool
forall blk. GetHeader blk => Header blk -> blk -> Bool
Block.blockMatchesHeader

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

    readCurrentChain :: STM m (AnchoredFragment (Header blk))
    readCurrentChain :: STM m (AnchoredFragment (Header blk))
readCurrentChain = ChainDB m blk -> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (Header blk))
ChainDB.getCurrentChain ChainDB m blk
chainDB

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

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

    -- See 'mkAddFetchedBlock_'
    mkAddFetchedBlock ::
         WhetherReceivingTentativeBlocks
      -> STM m (Point blk -> blk -> m ())
    mkAddFetchedBlock :: WhetherReceivingTentativeBlocks -> STM m (Point blk -> blk -> m ())
mkAddFetchedBlock WhetherReceivingTentativeBlocks
enabledPipelining = do
      SelectView (BlockProtocol blk)
-> InvalidBlockPunishment m -> InvalidBlockPunishment m
unlessImproved <- Proxy blk
-> STM
     m
     (SelectView (BlockProtocol blk)
      -> InvalidBlockPunishment m -> InvalidBlockPunishment m)
forall (proxy :: * -> *) (m :: * -> *) blk.
(IOLike m, NoThunks (SelectView (BlockProtocol blk)),
 Ord (SelectView (BlockProtocol blk))) =>
proxy blk
-> STM
     m
     (SelectView (BlockProtocol blk)
      -> InvalidBlockPunishment m -> InvalidBlockPunishment m)
InvalidBlockPunishment.mkUnlessImproved (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)
      (Point blk -> blk -> m ()) -> STM m (Point blk -> blk -> m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Point blk -> blk -> m ()) -> STM m (Point blk -> blk -> m ()))
-> (Point blk -> blk -> m ()) -> STM m (Point blk -> blk -> m ())
forall a b. (a -> b) -> a -> b
$ (SelectView (BlockProtocol blk)
 -> InvalidBlockPunishment m -> InvalidBlockPunishment m)
-> WhetherReceivingTentativeBlocks -> Point blk -> blk -> m ()
mkAddFetchedBlock_ SelectView (BlockProtocol blk)
-> InvalidBlockPunishment m -> InvalidBlockPunishment m
unlessImproved WhetherReceivingTentativeBlocks
enabledPipelining

    -- Waits until the block has been written to disk, but not until chain
    -- selection has processed the block.
    mkAddFetchedBlock_ ::
         (   SelectView (BlockProtocol blk)
          -> InvalidBlockPunishment m
          -> InvalidBlockPunishment m
         )
      -> WhetherReceivingTentativeBlocks
      -> Point blk
      -> blk
      -> m ()
    mkAddFetchedBlock_ :: (SelectView (BlockProtocol blk)
 -> InvalidBlockPunishment m -> InvalidBlockPunishment m)
-> WhetherReceivingTentativeBlocks -> Point blk -> blk -> m ()
mkAddFetchedBlock_ SelectView (BlockProtocol blk)
-> InvalidBlockPunishment m -> InvalidBlockPunishment m
unlessImproved WhetherReceivingTentativeBlocks
enabledPipelining Point blk
_pt blk
blk = m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ do
       InvalidBlockPunishment m
disconnect <- m (InvalidBlockPunishment m)
forall (m :: * -> *). IOLike m => m (InvalidBlockPunishment m)
InvalidBlockPunishment.mkPunishThisThread
       -- A BlockFetch peer can either send an entire range or none of the
       -- range; anything else will incur a disconnect. And in 'FetchDeadline'
       -- mode, which is the relevant case for this kind of DoS attack (because
       -- in bulk sync, our honest peers will be streaming a very dense chain
       -- very quickly, meaning the adversary only has very small windows during
       -- which we're interested in its chains), the node only requests whole
       -- suffixes from peers: the BlockFetch decision logic does not avoid
       -- requesting a block that is already in-flight from other peers. Thus
       -- the adversary cannot send us blocks out-of-order (during
       -- 'FetchDeadline'), even if they control more than one of our peers.
       --
       -- Therefore, the following punishment logic only needs to cover the
       -- "whole chain received in-order from a single-peer" case. Which it
       -- currently does.
       --
       -- TODO maintain the context of which ChainSync candidate incurring this
       -- fetch request, and disconnect immediately if the invalid block is not
       -- the tip of that candidate. As-is, in 'FetchDeadline' they must also
       -- send the next block, but they might be able to wait long enough that
       -- it is not desirable when it arrives, and therefore not be disconnected
       -- from. So their choices are: cause a disconnect or else do nothing for
       -- long enough. Both are fine by us, from a DoS mitigation perspective.
       let punishment :: InvalidBlockPunishment m
punishment = (Invalidity -> InvalidBlockPunishment m)
-> InvalidBlockPunishment m
forall (m :: * -> *).
(Invalidity -> InvalidBlockPunishment m)
-> InvalidBlockPunishment m
InvalidBlockPunishment.branch ((Invalidity -> InvalidBlockPunishment m)
 -> InvalidBlockPunishment m)
-> (Invalidity -> InvalidBlockPunishment m)
-> InvalidBlockPunishment m
forall a b. (a -> b) -> a -> b
$ \case
             -- invalid parents always cause a disconnect
             Invalidity
InvalidBlockPunishment.BlockPrefix -> InvalidBlockPunishment m
disconnect
             -- when pipelining, we forgive an invalid block itself if it's
             -- better than the previous invalid block this peer delivered
             Invalidity
InvalidBlockPunishment.BlockItself -> case WhetherReceivingTentativeBlocks
enabledPipelining of
               WhetherReceivingTentativeBlocks
NotReceivingTentativeBlocks -> InvalidBlockPunishment m
disconnect
               WhetherReceivingTentativeBlocks
ReceivingTentativeBlocks    ->
                 SelectView (BlockProtocol blk)
-> InvalidBlockPunishment m -> InvalidBlockPunishment m
unlessImproved (BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView BlockConfig blk
bcfg (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk)) InvalidBlockPunishment m
disconnect
       ChainDB m blk -> InvalidBlockPunishment m -> blk -> m Bool
forall (m :: * -> *) blk.
IOLike m =>
ChainDB m blk -> InvalidBlockPunishment m -> blk -> m Bool
ChainDB.addBlockWaitWrittenToDisk
         ChainDB m blk
chainDB
         InvalidBlockPunishment m
punishment
         blk
blk

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

    -- Note that @ours@ comes from the ChainDB and @cand@ from the ChainSync
    -- client.
    --
    -- Fragments are proxies for their corresponding chains; it is possible, in
    -- principle, that an empty fragment corresponds to the chain we want to
    -- adopt, and should therefore be preferred over other fragments (whose
    -- blocks we therefore do not want to download). The precondition to
    -- 'preferAnchoredCandidates' is designed precisely to rule out this
    -- possibility (for details, see the Consensus Report), but unfortunately we
    -- cannot always satisfy this precondition: although the chain sync client
    -- preserves an invariant that relates our current chain to the candidate
    -- fragment, by the time the block fetch download logic considers the
    -- fragment, our current chain might have changed.
    plausibleCandidateChain :: HasCallStack
                            => AnchoredFragment (Header blk)
                            -> AnchoredFragment (Header blk)
                            -> Bool
    plausibleCandidateChain :: AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Bool
plausibleCandidateChain AnchoredFragment (Header blk)
ours AnchoredFragment (Header blk)
cand
      -- 1. The ChainDB maintains the invariant that the anchor of our fragment
      --    corresponds to the immutable tip.
      --
      -- 2. The ChainSync client locally maintains the invariant that our
      --    fragment and the candidate fragment have the same anchor point. This
      --    establishes the precondition required by @preferAnchoredCandidate@.
      --
      -- 3. However, by the time that the BlockFetch logic processes a fragment
      --    presented to it by the ChainSync client, our current fragment might
      --    have changed, and they might no longer be anchored at the same
      --    point. This means that we are no longer guaranteed that the
      --    precondition holds.
      --
      -- 4. Our chain's anchor can only move forward. We can detect this by
      --    looking at the block numbers of the anchors.
      --
      | AnchoredFragment (Header blk) -> WithOrigin BlockNo
forall block. AnchoredFragment block -> WithOrigin BlockNo
AF.anchorBlockNo AnchoredFragment (Header blk)
cand WithOrigin BlockNo -> WithOrigin BlockNo -> Bool
forall a. Ord a => a -> a -> Bool
< AnchoredFragment (Header blk) -> WithOrigin BlockNo
forall block. AnchoredFragment block -> WithOrigin BlockNo
AF.anchorBlockNo AnchoredFragment (Header blk)
ours  -- (4)
      = case (AnchoredFragment (Header blk) -> Bool
forall v a b. AnchoredSeq v a b -> Bool
AF.null AnchoredFragment (Header blk)
ours, AnchoredFragment (Header blk) -> Bool
forall v a b. AnchoredSeq v a b -> Bool
AF.null AnchoredFragment (Header blk)
cand) of
          -- Both are non-empty, the precondition trivially holds.
          (Bool
False, Bool
False) -> BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
forall blk.
(BlockSupportsProtocol blk, HasCallStack) =>
BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate BlockConfig blk
bcfg AnchoredFragment (Header blk)
ours AnchoredFragment (Header blk)
cand
          -- The candidate is shorter than our chain and, worse, we'd have to
          -- roll back past our immutable tip (the anchor of @cand@).
          (Bool
_,     Bool
True)  -> Bool
False
          -- As argued above we can only reach this case when our chain's anchor
          -- has changed (4).
          --
          -- It is impossible for our chain to change /and/ still be empty: the
          -- anchor of our chain only changes when a new block becomes
          -- immutable. For a new block to become immutable, we must have
          -- extended our chain with at least @k + 1@ blocks. Which means our
          -- fragment can't be empty.
          (Bool
True,  Bool
_)     -> String -> Bool
forall a. HasCallStack => String -> a
error String
"impossible"

      | Bool
otherwise
      = BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
forall blk.
(BlockSupportsProtocol blk, HasCallStack) =>
BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate BlockConfig blk
bcfg AnchoredFragment (Header blk)
ours AnchoredFragment (Header blk)
cand

    compareCandidateChains :: AnchoredFragment (Header blk)
                           -> AnchoredFragment (Header blk)
                           -> Ordering
    compareCandidateChains :: AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Ordering
compareCandidateChains = BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Ordering
forall blk.
(BlockSupportsProtocol blk, HasCallStack) =>
BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Ordering
compareAnchoredFragments BlockConfig blk
bcfg

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

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

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

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

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

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

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

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

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

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

        -- At this point we have established that we are indeed slot leader
        TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> TraceForgeEvent blk
forall blk. SlotNo -> TraceForgeEvent blk
TraceNodeIsLeader SlotNo
currentSlot

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

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

        -- Get a snapshot of the mempool that is consistent with the ledger
        --
        -- NOTE: It is possible that due to adoption of new blocks the
        -- /current/ ledger will have changed. This doesn't matter: we will
        -- produce a block that fits onto the ledger we got above; if the
        -- ledger in the meantime changes, the block we produce here may or
        -- may not be adopted, but it won't be invalid.
        (ChainHash blk
mempoolHash, SlotNo
mempoolSlotNo, MempoolSnapshot blk TicketNo
mempoolSnapshot) <- m (ChainHash blk, SlotNo, MempoolSnapshot blk TicketNo)
-> WithEarlyExit
     m (ChainHash blk, SlotNo, MempoolSnapshot blk TicketNo)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ChainHash blk, SlotNo, MempoolSnapshot blk TicketNo)
 -> WithEarlyExit
      m (ChainHash blk, SlotNo, MempoolSnapshot blk TicketNo))
-> m (ChainHash blk, SlotNo, MempoolSnapshot blk TicketNo)
-> WithEarlyExit
     m (ChainHash blk, SlotNo, MempoolSnapshot blk TicketNo)
forall a b. (a -> b) -> a -> b
$ STM m (ChainHash blk, SlotNo, MempoolSnapshot blk TicketNo)
-> m (ChainHash blk, SlotNo, MempoolSnapshot blk TicketNo)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ChainHash blk, SlotNo, MempoolSnapshot blk TicketNo)
 -> m (ChainHash blk, SlotNo, MempoolSnapshot blk TicketNo))
-> STM m (ChainHash blk, SlotNo, MempoolSnapshot blk TicketNo)
-> m (ChainHash blk, SlotNo, MempoolSnapshot blk TicketNo)
forall a b. (a -> b) -> a -> b
$ do
            (ChainHash blk
mempoolHash, SlotNo
mempoolSlotNo) <- do
              MempoolSnapshot blk TicketNo
snap <- Mempool m blk TicketNo -> STM m (MempoolSnapshot blk TicketNo)
forall (m :: * -> *) blk idx.
Mempool m blk idx -> STM m (MempoolSnapshot blk idx)
getSnapshot Mempool m blk TicketNo
mempool   -- only used for its tip-like information
              let h :: ChainHash blk
                  h :: ChainHash blk
h = ChainHash (Ticked (LedgerState blk)) -> ChainHash blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash (ChainHash (Ticked (LedgerState blk)) -> ChainHash blk)
-> ChainHash (Ticked (LedgerState blk)) -> ChainHash blk
forall a b. (a -> b) -> a -> b
$ Ticked (LedgerState blk) -> ChainHash (Ticked (LedgerState blk))
forall l. GetTip l => l -> ChainHash l
getTipHash (Ticked (LedgerState blk) -> ChainHash (Ticked (LedgerState blk)))
-> Ticked (LedgerState blk) -> ChainHash (Ticked (LedgerState blk))
forall a b. (a -> b) -> a -> b
$ MempoolSnapshot blk TicketNo -> Ticked (LedgerState blk)
forall blk idx. MempoolSnapshot blk idx -> TickedLedgerState blk
snapshotLedgerState MempoolSnapshot blk TicketNo
snap
              (ChainHash blk, SlotNo) -> STM m (ChainHash blk, SlotNo)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainHash blk
h, MempoolSnapshot blk TicketNo -> SlotNo
forall blk idx. MempoolSnapshot blk idx -> SlotNo
snapshotSlotNo MempoolSnapshot blk TicketNo
snap)

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

        let txs :: [Validated (GenTx blk)]
txs = ((Validated (GenTx blk), TicketNo) -> Validated (GenTx blk))
-> [(Validated (GenTx blk), TicketNo)] -> [Validated (GenTx blk)]
forall a b. (a -> b) -> [a] -> [b]
map (Validated (GenTx blk), TicketNo) -> Validated (GenTx blk)
forall a b. (a, b) -> a
fst ([(Validated (GenTx blk), TicketNo)] -> [Validated (GenTx blk)])
-> [(Validated (GenTx blk), TicketNo)] -> [Validated (GenTx blk)]
forall a b. (a -> b) -> a -> b
$ MempoolSnapshot blk TicketNo -> [(Validated (GenTx blk), TicketNo)]
forall blk idx.
MempoolSnapshot blk idx -> [(Validated (GenTx blk), idx)]
snapshotTxs MempoolSnapshot blk TicketNo
mempoolSnapshot

        -- force the mempool's computation before the tracer event
        Int
_ <- Int -> WithEarlyExit m Int
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate ([Validated (GenTx blk)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Validated (GenTx blk)]
txs)
        Ticked (LedgerState blk)
_ <- Ticked (LedgerState blk)
-> WithEarlyExit m (Ticked (LedgerState blk))
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate (MempoolSnapshot blk TicketNo -> Ticked (LedgerState blk)
forall blk idx. MempoolSnapshot blk idx -> TickedLedgerState blk
snapshotLedgerState MempoolSnapshot blk TicketNo
mempoolSnapshot)
        TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo
-> Point blk -> ChainHash blk -> SlotNo -> TraceForgeEvent blk
forall blk.
SlotNo
-> Point blk -> ChainHash blk -> SlotNo -> TraceForgeEvent blk
TraceForgingMempoolSnapshot SlotNo
currentSlot Point blk
bcPrevPoint ChainHash blk
mempoolHash SlotNo
mempoolSlotNo

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

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

        -- Add the block to the chain DB
        let noPunish :: InvalidBlockPunishment m
noPunish = InvalidBlockPunishment m
forall (m :: * -> *). Applicative m => InvalidBlockPunishment m
InvalidBlockPunishment.noPunishment   -- no way to punish yourself
        AddBlockPromise m blk
result <- m (AddBlockPromise m blk)
-> WithEarlyExit m (AddBlockPromise m blk)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (AddBlockPromise m blk)
 -> WithEarlyExit m (AddBlockPromise m blk))
-> m (AddBlockPromise m blk)
-> WithEarlyExit m (AddBlockPromise m blk)
forall a b. (a -> b) -> a -> b
$ ChainDB m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
forall (m :: * -> *) blk.
ChainDB m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
ChainDB.addBlockAsync ChainDB m blk
chainDB InvalidBlockPunishment m
noPunish blk
newBlock
        -- Block until we have processed the block
        Point blk
curTip <- m (Point blk) -> WithEarlyExit m (Point blk)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Point blk) -> WithEarlyExit m (Point blk))
-> m (Point blk) -> WithEarlyExit m (Point blk)
forall a b. (a -> b) -> a -> b
$ STM m (Point blk) -> m (Point blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Point blk) -> m (Point blk))
-> STM m (Point blk) -> m (Point blk)
forall a b. (a -> b) -> a -> b
$ AddBlockPromise m blk -> STM m (Point blk)
forall (m :: * -> *) blk.
AddBlockPromise m blk -> STM m (Point blk)
ChainDB.blockProcessed AddBlockPromise m blk
result

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

        -- We successfully produced /and/ adopted a block
        --
        -- NOTE: we are tracing the transactions we retrieved from the Mempool,
        -- not the transactions actually /in the block/. They should always
        -- match, if they don't, that would be a bug. Unfortunately, we can't
        -- assert this here because the ability to extract transactions from a
        -- block, i.e., the @HasTxs@ class, is not implementable by all blocks,
        -- e.g., @DualBlock@.
        TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> blk -> [Validated (GenTx blk)] -> TraceForgeEvent blk
forall blk.
SlotNo -> blk -> [Validated (GenTx blk)] -> TraceForgeEvent blk
TraceAdoptedBlock SlotNo
currentSlot blk
newBlock [Validated (GenTx blk)]
txs

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

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

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

-- | Determine the 'BlockContext' for a block about to be forged from the
-- current slot, ChainDB chain fragment, and ChainDB tip block number
--
-- The 'bcPrevPoint' will either refer to the header at the tip of the current
-- chain or, in case there is already a block in this slot (e.g. another node
-- was also elected leader and managed to produce a block before us), the tip's
-- predecessor. If the chain is empty, then it will refer to the chain's anchor
-- point, which may be genesis.
mkCurrentBlockContext
  :: forall blk. RunNode blk
  => SlotNo
     -- ^ the current slot, i.e. the slot of the block about to be forged
  -> AnchoredFragment (Header blk)
     -- ^ the current chain fragment
     --
     -- Recall that the anchor point is the tip of the ImmutableDB.
  -> Either (TraceForgeEvent blk) (BlockContext blk)
     -- ^ the event records the cause of the failure
mkCurrentBlockContext :: SlotNo
-> AnchoredFragment (Header blk)
-> Either (TraceForgeEvent blk) (BlockContext blk)
mkCurrentBlockContext SlotNo
currentSlot AnchoredFragment (Header blk)
c = case AnchoredFragment (Header blk)
c of
    Empty Anchor (Header blk)
AF.AnchorGenesis ->
      -- The chain is entirely empty.
      BlockContext blk -> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. b -> Either a b
Right (BlockContext blk
 -> Either (TraceForgeEvent blk) (BlockContext blk))
-> BlockContext blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ BlockNo -> Point blk -> BlockContext blk
forall blk. BlockNo -> Point blk -> BlockContext blk
BlockContext (Proxy blk -> BlockNo
forall blk (proxy :: * -> *).
BasicEnvelopeValidation blk =>
proxy blk -> BlockNo
expectedFirstBlockNo (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)) Point blk
forall block. Point block
GenesisPoint

    Empty (AF.Anchor SlotNo
anchorSlot HeaderHash (Header blk)
anchorHash BlockNo
anchorBlockNo) ->
      let Point blk
p :: Point blk = SlotNo -> HeaderHash blk -> Point blk
forall block. SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
anchorSlot HeaderHash blk
HeaderHash (Header blk)
anchorHash
      in if SlotNo
anchorSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
currentSlot
           then BlockContext blk -> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. b -> Either a b
Right (BlockContext blk
 -> Either (TraceForgeEvent blk) (BlockContext blk))
-> BlockContext blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ BlockNo -> Point blk -> BlockContext blk
forall blk. BlockNo -> Point blk -> BlockContext blk
BlockContext (BlockNo -> BlockNo
forall a. Enum a => a -> a
succ BlockNo
anchorBlockNo) Point blk
p
           else TraceForgeEvent blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. a -> Either a b
Left  (TraceForgeEvent blk
 -> Either (TraceForgeEvent blk) (BlockContext blk))
-> TraceForgeEvent blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ SlotNo -> Point blk -> BlockNo -> TraceForgeEvent blk
forall blk. SlotNo -> Point blk -> BlockNo -> TraceForgeEvent blk
TraceSlotIsImmutable SlotNo
currentSlot Point blk
p BlockNo
anchorBlockNo

    AnchoredFragment (Header blk)
c' :> Header blk
hdr -> case Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr SlotNo -> SlotNo -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` SlotNo
currentSlot of

      -- The block at the tip of our chain has a slot number /before/ the
      -- current slot number. This is the common case, and we just want to
      -- connect our new block to the block at the tip.
      Ordering
LT -> BlockContext blk -> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. b -> Either a b
Right (BlockContext blk
 -> Either (TraceForgeEvent blk) (BlockContext blk))
-> BlockContext blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ Header blk -> BlockContext blk
forall blk.
HasHeader (Header blk) =>
Header blk -> BlockContext blk
blockContextFromPrevHeader Header blk
hdr

      -- The block at the tip of our chain has a slot that lies in the
      -- future. Although the chain DB does not adopt future blocks, if the
      -- system is under heavy load, it is possible (though unlikely) that
      -- one or more slots have passed after @currentSlot@ that we got from
      -- @onSlotChange@ and and before we queried the chain DB for the block
      -- at its tip. At the moment, we simply don't produce a block if this
      -- happens.

      -- TODO: We may wish to produce a block here anyway, treating this
      -- as similar to the @EQ@ case below, but we should be careful:
      --
      -- 1. We should think about what slot number to use.
      -- 2. We should be careful to distinguish between the case where we
      --    need to drop a block from the chain and where we don't.
      -- 3. We should be careful about slot numbers and EBBs.
      -- 4. We should probably not produce a block if the system is under
      --    very heavy load (e.g., if a lot of blocks have been produced
      --    after @currentTime@).
      --
      -- See <https://github.com/input-output-hk/ouroboros-network/issues/1462>
      Ordering
GT -> TraceForgeEvent blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. a -> Either a b
Left (TraceForgeEvent blk
 -> Either (TraceForgeEvent blk) (BlockContext blk))
-> TraceForgeEvent blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ SlotNo -> SlotNo -> TraceForgeEvent blk
forall blk. SlotNo -> SlotNo -> TraceForgeEvent blk
TraceBlockFromFuture SlotNo
currentSlot (Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr)

      -- The block at the tip has the same slot as the block we're going to
      -- produce (@currentSlot@).
      Ordering
EQ -> BlockContext blk -> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. b -> Either a b
Right (BlockContext blk
 -> Either (TraceForgeEvent blk) (BlockContext blk))
-> BlockContext blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ if Maybe EpochNo -> Bool
forall a. Maybe a -> Bool
isJust (Header blk -> Maybe EpochNo
forall blk. GetHeader blk => Header blk -> Maybe EpochNo
headerIsEBB Header blk
hdr)
        -- We allow forging a block that is the successor of an EBB in the
        -- same slot.
        then Header blk -> BlockContext blk
forall blk.
HasHeader (Header blk) =>
Header blk -> BlockContext blk
blockContextFromPrevHeader Header blk
hdr
        -- If @hdr@ is not an EBB, then forge an alternative to @hdr@: same
        -- block no and same predecessor.
        else BlockNo -> Point blk -> BlockContext blk
forall blk. BlockNo -> Point blk -> BlockContext blk
BlockContext (Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr) (Point blk -> BlockContext blk) -> Point blk -> BlockContext blk
forall a b. (a -> b) -> a -> b
$ Point (Header blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> Point (Header blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
c'

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

getMempoolReader
  :: forall m blk.
     ( LedgerSupportsMempool blk
     , IOLike m
     , HasTxId (GenTx blk)
     )
  => Mempool m blk TicketNo
  -> TxSubmissionMempoolReader (GenTxId blk) (Validated (GenTx blk)) TicketNo m
getMempoolReader :: Mempool m blk TicketNo
-> TxSubmissionMempoolReader
     (GenTxId blk) (Validated (GenTx blk)) TicketNo m
getMempoolReader Mempool m blk TicketNo
mempool = TxSubmissionMempoolReader :: forall txid tx idx (m :: * -> *).
STM m (MempoolSnapshot txid tx idx)
-> idx -> TxSubmissionMempoolReader txid tx idx m
MempoolReader.TxSubmissionMempoolReader
    { mempoolZeroIdx :: TicketNo
mempoolZeroIdx     = Mempool m blk TicketNo -> TicketNo
forall (m :: * -> *) blk idx. Mempool m blk idx -> idx
zeroIdx Mempool m blk TicketNo
mempool
    , mempoolGetSnapshot :: STM
  m (MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo)
mempoolGetSnapshot = MempoolSnapshot blk TicketNo
-> MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo
convertSnapshot (MempoolSnapshot blk TicketNo
 -> MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo)
-> STM m (MempoolSnapshot blk TicketNo)
-> STM
     m (MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mempool m blk TicketNo -> STM m (MempoolSnapshot blk TicketNo)
forall (m :: * -> *) blk idx.
Mempool m blk idx -> STM m (MempoolSnapshot blk idx)
getSnapshot Mempool m blk TicketNo
mempool
    }
  where
    convertSnapshot
      :: MempoolSnapshot               blk                                   TicketNo
      -> MempoolReader.MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo
    convertSnapshot :: MempoolSnapshot blk TicketNo
-> MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo
convertSnapshot MempoolSnapshot { TicketNo -> [(Validated (GenTx blk), TicketNo)]
snapshotTxsAfter :: forall blk idx.
MempoolSnapshot blk idx -> idx -> [(Validated (GenTx blk), idx)]
snapshotTxsAfter :: TicketNo -> [(Validated (GenTx blk), TicketNo)]
snapshotTxsAfter, TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx :: forall blk idx.
MempoolSnapshot blk idx -> idx -> Maybe (Validated (GenTx blk))
snapshotLookupTx :: TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx,
                                      GenTxId blk -> Bool
snapshotHasTx :: forall blk idx. MempoolSnapshot blk idx -> GenTxId blk -> Bool
snapshotHasTx :: GenTxId blk -> Bool
snapshotHasTx } =
      MempoolSnapshot :: forall txid tx idx.
(idx -> [(txid, idx, SizeInBytes)])
-> (idx -> Maybe tx)
-> (txid -> Bool)
-> MempoolSnapshot txid tx idx
MempoolReader.MempoolSnapshot
        { mempoolTxIdsAfter :: TicketNo -> [(GenTxId blk, TicketNo, SizeInBytes)]
mempoolTxIdsAfter = \TicketNo
idx ->
            [ (GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId (Validated (GenTx blk) -> GenTx blk
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated (GenTx blk)
tx), TicketNo
idx', Mempool m blk TicketNo -> GenTx blk -> SizeInBytes
forall (m :: * -> *) blk idx.
Mempool m blk idx -> GenTx blk -> SizeInBytes
getTxSize Mempool m blk TicketNo
mempool (Validated (GenTx blk) -> GenTx blk
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated (GenTx blk)
tx))
            | (Validated (GenTx blk)
tx, TicketNo
idx') <- TicketNo -> [(Validated (GenTx blk), TicketNo)]
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 TicketNo
  -> TxSubmissionMempoolWriter (GenTxId blk) (GenTx blk) TicketNo m
getMempoolWriter :: Mempool m blk TicketNo
-> TxSubmissionMempoolWriter (GenTxId blk) (GenTx blk) TicketNo m
getMempoolWriter Mempool m blk TicketNo
mempool = TxSubmissionMempoolWriter :: forall txid tx idx (m :: * -> *).
(tx -> txid)
-> ([tx] -> m [txid]) -> TxSubmissionMempoolWriter txid tx idx m
Inbound.TxSubmissionMempoolWriter
    { txId :: GenTx blk -> GenTxId blk
Inbound.txId          = GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId
    , mempoolAddTxs :: [GenTx blk] -> m [GenTxId blk]
mempoolAddTxs = \[GenTx blk]
txs ->
        (Validated (GenTx blk) -> GenTxId blk)
-> [Validated (GenTx blk)] -> [GenTxId blk]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId (GenTx blk -> GenTxId blk)
-> (Validated (GenTx blk) -> GenTx blk)
-> Validated (GenTx blk)
-> GenTxId blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx blk) -> GenTx blk
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated) ([Validated (GenTx blk)] -> [GenTxId blk])
-> ([MempoolAddTxResult blk] -> [Validated (GenTx blk)])
-> [MempoolAddTxResult blk]
-> [GenTxId 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] -> [GenTxId blk])
-> m [MempoolAddTxResult blk] -> m [GenTxId blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Mempool m blk TicketNo -> [GenTx blk] -> m [MempoolAddTxResult blk]
forall (m :: * -> *) blk idx.
MonadSTM m =>
Mempool m blk idx -> [GenTx blk] -> m [MempoolAddTxResult blk]
addTxs Mempool m blk TicketNo
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 remotePeer localPeer blk
  -> (LedgerState blk -> Bool)
  -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
getPeersFromCurrentLedger :: NodeKernel m remotePeer localPeer blk
-> (LedgerState blk -> Bool)
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
getPeersFromCurrentLedger NodeKernel m remotePeer localPeer blk
kernel LedgerState blk -> Bool
p = do
    LedgerState blk
immutableLedger <-
      ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> STM m (ExtLedgerState blk) -> STM m (LedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
Monad (STM m) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getImmutableLedger (NodeKernel m remotePeer localPeer blk -> ChainDB m blk
forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk -> ChainDB m blk
getChainDB NodeKernel m remotePeer localPeer blk
kernel)
    Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
 -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)]))
-> Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
forall a b. (a -> b) -> a -> b
$ do
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (LedgerState blk -> Bool
p LedgerState blk
immutableLedger)
      [(PoolStake, NonEmpty RelayAccessPoint)]
-> Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
forall (m :: * -> *) a. Monad m => a -> m a
return
        ([(PoolStake, NonEmpty RelayAccessPoint)]
 -> Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
forall a b. (a -> b) -> a -> b
$ ((PoolStake, NonEmpty StakePoolRelay)
 -> (PoolStake, NonEmpty RelayAccessPoint))
-> [(PoolStake, NonEmpty StakePoolRelay)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall a b. (a -> b) -> [a] -> [b]
map ((NonEmpty StakePoolRelay -> NonEmpty RelayAccessPoint)
-> (PoolStake, NonEmpty StakePoolRelay)
-> (PoolStake, NonEmpty RelayAccessPoint)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((StakePoolRelay -> RelayAccessPoint)
-> NonEmpty StakePoolRelay -> NonEmpty RelayAccessPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StakePoolRelay -> RelayAccessPoint
stakePoolRelayAccessPoint))
        ([(PoolStake, NonEmpty StakePoolRelay)]
 -> [(PoolStake, NonEmpty RelayAccessPoint)])
-> [(PoolStake, NonEmpty StakePoolRelay)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall a b. (a -> b) -> a -> b
$ [(PoolStake, NonEmpty StakePoolRelay)]
-> [(PoolStake, NonEmpty StakePoolRelay)]
forall a. NFData a => a -> a
force
        ([(PoolStake, NonEmpty StakePoolRelay)]
 -> [(PoolStake, NonEmpty StakePoolRelay)])
-> [(PoolStake, NonEmpty StakePoolRelay)]
-> [(PoolStake, NonEmpty StakePoolRelay)]
forall a b. (a -> b) -> a -> b
$ LedgerState blk -> [(PoolStake, NonEmpty StakePoolRelay)]
forall blk.
LedgerSupportsPeerSelection blk =>
LedgerState blk -> [(PoolStake, NonEmpty StakePoolRelay)]
getPeers LedgerState blk
immutableLedger

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