{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Ouroboros.Consensus.NodeKernel (
MempoolCapacityBytesOverride (..)
, NodeKernel (..)
, NodeKernelArgs (..)
, TraceForgeEvent (..)
, getImmTipSlot
, getMempoolReader
, getMempoolWriter
, getPeersFromCurrentLedger
, getPeersFromCurrentLedgerAfterSlot
, initNodeKernel
) where
import qualified Control.Concurrent.Class.MonadSTM as LazySTM
import qualified Control.Concurrent.Class.MonadSTM.Strict as StrictSTM
import Control.DeepSeq (force)
import Control.Monad
import qualified Control.Monad.Class.MonadTimer.SI as SI
import Control.Monad.Except
import Control.ResourceRegistry
import Control.Tracer
import Data.Bifunctor (second)
import Data.Data (Typeable)
import Data.Foldable (traverse_)
import Data.Function (on)
import Data.Functor ((<&>))
import Data.Hashable (Hashable)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import Data.Maybe (isJust, mapMaybe)
import Data.Proxy
import qualified Data.Text as Text
import Data.Void (Void)
import Ouroboros.Consensus.Block hiding (blockMatchesHeader)
import qualified Ouroboros.Consensus.Block as Block
import Ouroboros.Consensus.BlockchainTime
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Forecast
import Ouroboros.Consensus.Genesis.Governor (gddWatcher)
import Ouroboros.Consensus.HeaderValidation
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.Ledger.SupportsPeerSelection
import Ouroboros.Consensus.Ledger.SupportsProtocol
import Ouroboros.Consensus.Mempool
import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client
(ChainSyncClientHandle (..), ChainSyncState (..),
viewChainSyncState)
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck
(HistoricityCheck)
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck
(SomeHeaderInFutureCheck)
import Ouroboros.Consensus.Node.Genesis (GenesisNodeKernelArgs (..),
LoEAndGDDConfig (..), setGetLoEFragment)
import Ouroboros.Consensus.Node.GSM (GsmNodeKernelArgs (..))
import qualified Ouroboros.Consensus.Node.GSM as GSM
import Ouroboros.Consensus.Node.Run
import Ouroboros.Consensus.Node.Tracers
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Storage.ChainDB.API (AddBlockResult (..),
ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment
import Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.Init as InitChainDB
import Ouroboros.Consensus.Util.AnchoredFragment
(preferAnchoredCandidate)
import Ouroboros.Consensus.Util.EarlyExit
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.LeakyBucket
(atomicallyWithMonotonicTime)
import Ouroboros.Consensus.Util.Orphans ()
import Ouroboros.Consensus.Util.STM
import Ouroboros.Network.AnchoredFragment (AnchoredFragment,
AnchoredSeq (..))
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Block (castTip, tipFromHeader)
import Ouroboros.Network.BlockFetch
import Ouroboros.Network.Diffusion (PublicPeerSelectionState)
import Ouroboros.Network.NodeToNode (ConnectionId,
MiniProtocolParameters (..))
import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers)
import Ouroboros.Network.PeerSelection.LedgerPeers.Type
(LedgerStateJudgement (..))
import Ouroboros.Network.PeerSelection.LocalRootPeers
(OutboundConnectionsState (..))
import Ouroboros.Network.PeerSharing (PeerSharingAPI,
PeerSharingRegistry, newPeerSharingAPI,
newPeerSharingRegistry, ps_POLICY_PEER_SHARE_MAX_PEERS,
ps_POLICY_PEER_SHARE_STICKY_TIME)
import Ouroboros.Network.SizeInBytes
import Ouroboros.Network.TxSubmission.Inbound
(TxSubmissionMempoolWriter)
import qualified Ouroboros.Network.TxSubmission.Inbound as Inbound
import Ouroboros.Network.TxSubmission.Mempool.Reader
(TxSubmissionMempoolReader)
import qualified Ouroboros.Network.TxSubmission.Mempool.Reader as MempoolReader
import System.Random (StdGen)
data NodeKernel m addrNTN addrNTC blk = NodeKernel {
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
getChainDB :: ChainDB m blk
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> Mempool m blk
getMempool :: Mempool m blk
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> TopLevelConfig blk
getTopLevelConfig :: TopLevelConfig blk
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk
-> FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
getFetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> STM m FetchMode
getFetchMode :: STM m FetchMode
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> STM m GsmState
getGsmState :: STM m GSM.GsmState
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk
-> StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
getChainSyncHandles :: StrictTVar m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> PeerSharingRegistry addrNTN m
getPeerSharingRegistry :: PeerSharingRegistry addrNTN m
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
getTracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> [BlockForging m blk] -> m ()
setBlockForging :: [BlockForging m blk] -> m ()
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> PeerSharingAPI addrNTN StdGen m
getPeerSharingAPI :: PeerSharingAPI addrNTN StdGen m
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk
-> StrictTVar m OutboundConnectionsState
getOutboundConnectionsState
:: StrictTVar m OutboundConnectionsState
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> DiffusionPipeliningSupport
getDiffusionPipeliningSupport
:: DiffusionPipeliningSupport
}
data NodeKernelArgs m addrNTN addrNTC blk = NodeKernelArgs {
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ResourceRegistry m
registry :: ResourceRegistry m
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockchainTime m
btime :: BlockchainTime m
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ChainDB m blk
chainDB :: ChainDB m blk
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB :: StorageConfig blk -> InitChainDB m blk -> m ()
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> SomeHeaderInFutureCheck m blk
chainSyncFutureCheck :: SomeHeaderInFutureCheck m blk
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> m GsmState -> HistoricityCheck m blk
chainSyncHistoricityCheck
:: m GSM.GsmState -> HistoricityCheck m blk
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> Header blk -> SizeInBytes
blockFetchSize :: Header blk -> SizeInBytes
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> MempoolCapacityBytesOverride
mempoolCapacityOverride :: MempoolCapacityBytesOverride
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> MiniProtocolParameters
miniProtocolParameters :: MiniProtocolParameters
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockFetchConfiguration
blockFetchConfiguration :: BlockFetchConfiguration
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> StdGen
keepAliveRng :: StdGen
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GsmNodeKernelArgs m blk
gsmArgs :: GsmNodeKernelArgs m blk
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> STM m UseBootstrapPeers
getUseBootstrapPeers :: STM m UseBootstrapPeers
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> StdGen
peerSharingRng :: StdGen
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar
:: StrictSTM.StrictTVar m (PublicPeerSelectionState addrNTN)
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GenesisNodeKernelArgs m blk
genesisArgs :: GenesisNodeKernelArgs m blk
, forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: DiffusionPipeliningSupport
}
initNodeKernel ::
forall m addrNTN addrNTC blk.
( IOLike m
, SI.MonadTimer m
, RunNode blk
, Ord addrNTN
, Hashable addrNTN
, Typeable addrNTN
)
=> NodeKernelArgs m addrNTN addrNTC blk
-> m (NodeKernel m addrNTN addrNTC blk)
initNodeKernel :: forall (m :: * -> *) addrNTN addrNTC blk.
(IOLike m, MonadTimer m, RunNode blk, Ord addrNTN,
Hashable addrNTN, Typeable addrNTN) =>
NodeKernelArgs m addrNTN addrNTC blk
-> m (NodeKernel m addrNTN addrNTC blk)
initNodeKernel args :: NodeKernelArgs m addrNTN addrNTC blk
args@NodeKernelArgs { ResourceRegistry m
$sel:registry:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ResourceRegistry m
registry :: ResourceRegistry m
registry, TopLevelConfig blk
$sel:cfg:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg, Tracers m (ConnectionId addrNTN) addrNTC blk
$sel:tracers:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
tracers
, ChainDB m blk
$sel:chainDB:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ChainDB m blk
chainDB :: ChainDB m blk
chainDB, StorageConfig blk -> InitChainDB m blk -> m ()
$sel:initChainDB:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB :: StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB
, BlockFetchConfiguration
$sel:blockFetchConfiguration:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockFetchConfiguration
blockFetchConfiguration :: BlockFetchConfiguration
blockFetchConfiguration
, GsmNodeKernelArgs m blk
$sel:gsmArgs:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GsmNodeKernelArgs m blk
gsmArgs :: GsmNodeKernelArgs m blk
gsmArgs
, StdGen
$sel:peerSharingRng:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> StdGen
peerSharingRng :: StdGen
peerSharingRng
, StrictTVar m (PublicPeerSelectionState addrNTN)
$sel:publicPeerSelectionStateVar:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar :: StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar
, GenesisNodeKernelArgs m blk
$sel:genesisArgs:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GenesisNodeKernelArgs m blk
genesisArgs :: GenesisNodeKernelArgs m blk
genesisArgs
, DiffusionPipeliningSupport
$sel:getDiffusionPipeliningSupport:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: DiffusionPipeliningSupport
getDiffusionPipeliningSupport
} = do
TMVar m [BlockForging m blk]
blockForgingVar :: LazySTM.TMVar m [BlockForging m blk] <- [BlockForging m blk] -> m (TMVar m [BlockForging m blk])
forall a. a -> m (TMVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TMVar m a)
LazySTM.newTMVarIO []
StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB (TopLevelConfig blk -> StorageConfig blk
forall blk. TopLevelConfig blk -> StorageConfig blk
configStorage TopLevelConfig blk
cfg) (ChainDB m blk -> InitChainDB m blk
forall blk (m :: * -> *).
(IsLedger (LedgerState blk), IOLike m) =>
ChainDB m blk -> InitChainDB m blk
InitChainDB.fromFull ChainDB m blk
chainDB)
InternalState m addrNTN addrNTC blk
st <- NodeKernelArgs m addrNTN addrNTC blk
-> m (InternalState m addrNTN addrNTC blk)
forall (m :: * -> *) addrNTN addrNTC blk.
(IOLike m, Ord addrNTN, Typeable addrNTN, RunNode blk) =>
NodeKernelArgs m addrNTN addrNTC blk
-> m (InternalState m addrNTN addrNTC blk)
initInternalState NodeKernelArgs m addrNTN addrNTC blk
args
let IS
{ BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
blockFetchInterface :: BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
$sel:blockFetchInterface:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
blockFetchInterface
, FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
$sel:fetchClientRegistry:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
fetchClientRegistry
, Mempool m blk
mempool :: Mempool m blk
$sel:mempool:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> Mempool m blk
mempool
, PeerSharingRegistry addrNTN m
peerSharingRegistry :: PeerSharingRegistry addrNTN m
$sel:peerSharingRegistry:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> PeerSharingRegistry addrNTN m
peerSharingRegistry
, StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles :: StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
$sel:varChainSyncHandles:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles
, StrictTVar m GsmState
varGsmState :: StrictTVar m GsmState
$sel:varGsmState:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> StrictTVar m GsmState
varGsmState
} = InternalState m addrNTN addrNTC blk
st
StrictTVar m OutboundConnectionsState
varOutboundConnectionsState <- OutboundConnectionsState
-> m (StrictTVar m OutboundConnectionsState)
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO OutboundConnectionsState
UntrustedState
do let GsmNodeKernelArgs {Maybe (WrapDurationUntilTooOld m blk)
StdGen
NominalDiffTime
MarkerFileView m
gsmAntiThunderingHerd :: StdGen
gsmDurationUntilTooOld :: Maybe (WrapDurationUntilTooOld m blk)
gsmMarkerFileView :: MarkerFileView m
gsmMinCaughtUpDuration :: NominalDiffTime
gsmAntiThunderingHerd :: forall (m :: * -> *) blk. GsmNodeKernelArgs m blk -> StdGen
gsmDurationUntilTooOld :: forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> Maybe (WrapDurationUntilTooOld m blk)
gsmMarkerFileView :: forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> MarkerFileView m
gsmMinCaughtUpDuration :: forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> NominalDiffTime
..} = GsmNodeKernelArgs m blk
gsmArgs
gsmTracerArgs :: ((AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> Tip blk,
Tracer m (TraceGsmEvent (Tip blk)))
gsmTracerArgs =
( Tip (Header blk) -> Tip blk
forall {k1} {k2} (a :: k1) (b :: k2).
(HeaderHash a ~ HeaderHash b) =>
Tip a -> Tip b
castTip (Tip (Header blk) -> Tip blk)
-> ((AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> Tip (Header blk))
-> (AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> Tip blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Anchor (Header blk) -> Tip (Header blk))
-> (Header blk -> Tip (Header blk))
-> Either (Anchor (Header blk)) (Header blk)
-> Tip (Header blk)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Anchor (Header blk) -> Tip (Header blk)
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Tip b
AF.anchorToTip Header blk -> Tip (Header blk)
forall a. HasHeader a => a -> Tip a
tipFromHeader (Either (Anchor (Header blk)) (Header blk) -> Tip (Header blk))
-> ((AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> Either (Anchor (Header blk)) (Header blk))
-> (AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> Tip (Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> Either (Anchor (Header blk)) (Header blk)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.head (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> Either (Anchor (Header blk)) (Header blk))
-> ((AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
-> (AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> Either (Anchor (Header blk)) (Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
forall a b. (a, b) -> a
fst
, Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer m (TraceGsmEvent (Tip blk))
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f -> f (TraceGsmEvent (Tip blk))
gsmTracer Tracers m (ConnectionId addrNTN) addrNTC blk
tracers
)
let gsm :: GsmEntryPoints m
gsm = ((AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> Tip blk,
Tracer m (TraceGsmEvent (Tip blk)))
-> GsmView
m
(ConnectionId addrNTN)
(AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
(ChainSyncState blk)
-> GsmEntryPoints m
forall (m :: * -> *) upstreamPeer selection tracedSelection
candidate.
(MonadDelay m, MonadTimer m) =>
(selection -> tracedSelection,
Tracer m (TraceGsmEvent tracedSelection))
-> GsmView m upstreamPeer selection candidate -> GsmEntryPoints m
GSM.realGsmEntryPoints ((AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> Tip blk,
Tracer m (TraceGsmEvent (Tip blk)))
gsmTracerArgs GSM.GsmView
{ antiThunderingHerd :: Maybe StdGen
GSM.antiThunderingHerd = StdGen -> Maybe StdGen
forall a. a -> Maybe a
Just StdGen
gsmAntiThunderingHerd
, candidateOverSelection :: (AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> ChainSyncState blk -> CandidateVersusSelection
GSM.candidateOverSelection = \(AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
headers, LedgerState blk
_lst) ChainSyncState blk
state ->
case AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> Maybe (Point (Header blk))
forall block1 block2.
(HasHeader block1, HasHeader block2,
HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2 -> Maybe (Point block1)
AF.intersectionPoint AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
headers (ChainSyncState blk
-> AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
forall blk. ChainSyncState blk -> AnchoredFragment (Header blk)
csCandidate ChainSyncState blk
state) of
Maybe (Point (Header blk))
Nothing -> CandidateVersusSelection
GSM.CandidateDoesNotIntersect
Just{} ->
Bool -> CandidateVersusSelection
GSM.WhetherCandidateIsBetter
(Bool -> CandidateVersusSelection)
-> Bool -> CandidateVersusSelection
forall a b. (a -> b) -> a -> b
$
BlockConfig blk
-> AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> Bool
forall blk.
(BlockSupportsProtocol blk, HasCallStack) =>
BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate
(TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg)
AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
headers
(ChainSyncState blk
-> AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
forall blk. ChainSyncState blk -> AnchoredFragment (Header blk)
csCandidate ChainSyncState blk
state)
, peerIsIdle :: ChainSyncState blk -> Bool
GSM.peerIsIdle = ChainSyncState blk -> Bool
forall blk. ChainSyncState blk -> Bool
csIdling
, durationUntilTooOld :: Maybe
((AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> m DurationFromNow)
GSM.durationUntilTooOld =
Maybe (WrapDurationUntilTooOld m blk)
gsmDurationUntilTooOld
Maybe (WrapDurationUntilTooOld m blk)
-> (WrapDurationUntilTooOld m blk
-> (AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> m DurationFromNow)
-> Maybe
((AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> m DurationFromNow)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \WrapDurationUntilTooOld m blk
wd (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
_headers, LedgerState blk
lst) ->
WrapDurationUntilTooOld m blk
-> WithOrigin SlotNo -> m DurationFromNow
forall (m :: * -> *) blk.
WrapDurationUntilTooOld m blk
-> WithOrigin SlotNo -> m DurationFromNow
GSM.getDurationUntilTooOld WrapDurationUntilTooOld m blk
wd (LedgerState blk -> WithOrigin SlotNo
forall l. GetTip l => l -> WithOrigin SlotNo
getTipSlot LedgerState blk
lst)
, equivalent :: (AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> (AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> Bool
GSM.equivalent = Point (Header blk) -> Point (Header blk) -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Point (Header blk) -> Point (Header blk) -> Bool)
-> ((AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> Point (Header blk))
-> (AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> (AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> Point (Header blk))
-> ((AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
-> (AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> Point (Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
forall a b. (a, b) -> a
fst)
, getChainSyncStates :: STM
m (Map (ConnectionId addrNTN) (StrictTVar m (ChainSyncState blk)))
GSM.getChainSyncStates = (ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk))
-> Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)
-> Map (ConnectionId addrNTN) (StrictTVar m (ChainSyncState blk))
forall a b.
(a -> b)
-> Map (ConnectionId addrNTN) a -> Map (ConnectionId addrNTN) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk)
cschState (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)
-> Map (ConnectionId addrNTN) (StrictTVar m (ChainSyncState blk)))
-> STM m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
-> STM
m (Map (ConnectionId addrNTN) (StrictTVar m (ChainSyncState blk)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
-> STM m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles
, getCurrentSelection :: STM
m
(AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
GSM.getCurrentSelection = do
AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
headers <- ChainDB m blk
-> STM
m
(AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (Header blk))
ChainDB.getCurrentChain ChainDB m blk
chainDB
ExtLedgerState blk
extLedgerState <- ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
(Monad (STM m), IsLedger (LedgerState blk)) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB m blk
chainDB
(AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
-> STM
m
(AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk),
LedgerState blk)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
headers, ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
extLedgerState)
, minCaughtUpDuration :: NominalDiffTime
GSM.minCaughtUpDuration = NominalDiffTime
gsmMinCaughtUpDuration
, setCaughtUpPersistentMark :: Bool -> m ()
GSM.setCaughtUpPersistentMark = \Bool
upd ->
(if Bool
upd then MarkerFileView m -> m ()
forall (m :: * -> *). MarkerFileView m -> m ()
GSM.touchMarkerFile else MarkerFileView m -> m ()
forall (m :: * -> *). MarkerFileView m -> m ()
GSM.removeMarkerFile)
MarkerFileView m
gsmMarkerFileView
, writeGsmState :: GsmState -> m ()
GSM.writeGsmState = \GsmState
gsmState ->
(Time -> STM m ()) -> m ()
forall (m :: * -> *) b.
(MonadMonotonicTime m, MonadSTM m) =>
(Time -> STM m b) -> m b
atomicallyWithMonotonicTime ((Time -> STM m ()) -> m ()) -> (Time -> STM m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Time
time -> do
StrictTVar m GsmState -> GsmState -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m GsmState
varGsmState GsmState
gsmState
Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)
handles <- StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
-> STM m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles
(ChainSyncClientHandle m blk -> STM m ())
-> Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)
-> STM m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (((Time -> STM m ()) -> Time -> STM m ()
forall a b. (a -> b) -> a -> b
$ Time
time) ((Time -> STM m ()) -> STM m ())
-> (ChainSyncClientHandle m blk -> Time -> STM m ())
-> ChainSyncClientHandle m blk
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((GsmState -> Time -> STM m ()) -> GsmState -> Time -> STM m ()
forall a b. (a -> b) -> a -> b
$ GsmState
gsmState) ((GsmState -> Time -> STM m ()) -> Time -> STM m ())
-> (ChainSyncClientHandle m blk -> GsmState -> Time -> STM m ())
-> ChainSyncClientHandle m blk
-> Time
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainSyncClientHandle m blk -> GsmState -> Time -> STM m ()
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> GsmState -> Time -> STM m ()
cschOnGsmStateChanged) Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)
handles
, isHaaSatisfied :: STM m Bool
GSM.isHaaSatisfied = do
StrictTVar m OutboundConnectionsState
-> STM m OutboundConnectionsState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m OutboundConnectionsState
varOutboundConnectionsState STM m OutboundConnectionsState
-> (OutboundConnectionsState -> Bool) -> STM m Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
OutboundConnectionsState
TrustedStateWithExternalPeers -> Bool
True
OutboundConnectionsState
UntrustedState -> Bool
False
}
LedgerStateJudgement
judgment <- GsmState -> LedgerStateJudgement
GSM.gsmStateToLedgerJudgement (GsmState -> LedgerStateJudgement)
-> m GsmState -> m LedgerStateJudgement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m GsmState -> m GsmState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m GsmState
varGsmState
m (Thread m Any) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m Any) -> m ()) -> m (Thread m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m -> String -> m Any -> m (Thread m Any)
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
"NodeKernel.GSM" (m Any -> m (Thread m Any)) -> m Any -> m (Thread m Any)
forall a b. (a -> b) -> a -> b
$ case LedgerStateJudgement
judgment of
LedgerStateJudgement
TooOld -> GsmEntryPoints m -> forall neverTerminates. m neverTerminates
forall (m :: * -> *).
GsmEntryPoints m -> forall neverTerminates. m neverTerminates
GSM.enterPreSyncing GsmEntryPoints m
gsm
LedgerStateJudgement
YoungEnough -> GsmEntryPoints m -> forall neverTerminates. m neverTerminates
forall (m :: * -> *).
GsmEntryPoints m -> forall neverTerminates. m neverTerminates
GSM.enterCaughtUp GsmEntryPoints m
gsm
PeerSharingAPI addrNTN StdGen m
peerSharingAPI <- StrictTVar m (PublicPeerSelectionState addrNTN)
-> StdGen
-> DiffTime
-> PeerSharingAmount
-> m (PeerSharingAPI addrNTN StdGen m)
forall (m :: * -> *) addr s.
MonadSTM m =>
StrictTVar m (PublicPeerSelectionState addr)
-> s
-> DiffTime
-> PeerSharingAmount
-> m (PeerSharingAPI addr s m)
newPeerSharingAPI StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar
StdGen
peerSharingRng
DiffTime
ps_POLICY_PEER_SHARE_STICKY_TIME
PeerSharingAmount
ps_POLICY_PEER_SHARE_MAX_PEERS
case GenesisNodeKernelArgs m blk
-> LoEAndGDDConfig (StrictTVar m (GetLoEFragment m blk))
forall (m :: * -> *) blk.
GenesisNodeKernelArgs m blk
-> LoEAndGDDConfig (StrictTVar m (GetLoEFragment m blk))
gnkaGetLoEFragment GenesisNodeKernelArgs m blk
genesisArgs of
LoEAndGDDConfig (StrictTVar m (GetLoEFragment m blk))
LoEAndGDDDisabled -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
LoEAndGDDEnabled StrictTVar m (GetLoEFragment m blk)
varGetLoEFragment -> do
StrictTVar
m
(AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
varLoEFragment <- AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> m (StrictTVar
m
(AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> m (StrictTVar
m
(AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))))
-> AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> m (StrictTVar
m
(AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
forall a b. (a -> b) -> a -> b
$ Anchor (Header blk)
-> AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (Header blk)
forall block. Anchor block
AF.AnchorGenesis
STM m GsmState
-> STM
m
(AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
-> StrictTVar m (GetLoEFragment m blk)
-> m ()
forall (m :: * -> *) blk.
(IOLike m, GetHeader blk) =>
STM m GsmState
-> STM m (AnchoredFragment (Header blk))
-> StrictTVar m (GetLoEFragment m blk)
-> m ()
setGetLoEFragment
(StrictTVar m GsmState -> STM m GsmState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m GsmState
varGsmState)
(StrictTVar
m
(AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
-> STM
m
(AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
m
(AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
varLoEFragment)
StrictTVar m (GetLoEFragment m blk)
varGetLoEFragment
m (Thread m Void) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m Void) -> m ()) -> m (Thread m Void) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m
-> String
-> Watcher
m
(GsmState, GDDStateView m blk (ConnectionId addrNTN))
(Map
(ConnectionId addrNTN) (StrictMaybe (WithOrigin SlotNo), Bool))
-> m (Thread m Void)
forall (m :: * -> *) a fp.
(IOLike m, Eq fp, HasCallStack) =>
ResourceRegistry m -> String -> Watcher m a fp -> m (Thread m Void)
forkLinkedWatcher ResourceRegistry m
registry String
"NodeKernel.GDD" (Watcher
m
(GsmState, GDDStateView m blk (ConnectionId addrNTN))
(Map
(ConnectionId addrNTN) (StrictMaybe (WithOrigin SlotNo), Bool))
-> m (Thread m Void))
-> Watcher
m
(GsmState, GDDStateView m blk (ConnectionId addrNTN))
(Map
(ConnectionId addrNTN) (StrictMaybe (WithOrigin SlotNo), Bool))
-> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$
TopLevelConfig blk
-> Tracer m (TraceGDDEvent (ConnectionId addrNTN) blk)
-> ChainDB m blk
-> STM m GsmState
-> STM m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
-> StrictTVar
m
(AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
-> Watcher
m
(GsmState, GDDStateView m blk (ConnectionId addrNTN))
(Map
(ConnectionId addrNTN) (StrictMaybe (WithOrigin SlotNo), Bool))
forall (m :: * -> *) blk peer.
(IOLike m, Ord peer, LedgerSupportsProtocol blk,
HasHardForkHistory blk) =>
TopLevelConfig blk
-> Tracer m (TraceGDDEvent peer blk)
-> ChainDB m blk
-> STM m GsmState
-> STM m (Map peer (ChainSyncClientHandle m blk))
-> StrictTVar m (AnchoredFragment (Header blk))
-> Watcher
m
(GsmState, GDDStateView m blk peer)
(Map peer (StrictMaybe (WithOrigin SlotNo), Bool))
gddWatcher
TopLevelConfig blk
cfg
(Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer m (TraceGDDEvent (ConnectionId addrNTN) blk)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceGDDEvent remotePeer blk)
gddTracer Tracers m (ConnectionId addrNTN) addrNTC blk
tracers)
ChainDB m blk
chainDB
(StrictTVar m GsmState -> STM m GsmState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m GsmState
varGsmState)
(StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
-> STM m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles)
StrictTVar
m
(AnchoredSeq
(WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
varLoEFragment
m (Thread m Void) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m Void) -> m ()) -> m (Thread m Void) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m -> String -> m Void -> m (Thread m Void)
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
"NodeKernel.blockForging" (m Void -> m (Thread m Void)) -> m Void -> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$
InternalState m addrNTN addrNTC blk
-> STM m [BlockForging m blk] -> m Void
forall remotePeer localPeer.
InternalState m remotePeer localPeer blk
-> STM m [BlockForging m blk] -> m Void
blockForgingController InternalState m addrNTN addrNTC blk
st (TMVar m [BlockForging m blk] -> STM m [BlockForging m blk]
forall a. TMVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
LazySTM.takeTMVar TMVar m [BlockForging m blk]
blockForgingVar)
m (Thread m Void) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m Void) -> m ()) -> m (Thread m Void) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m -> String -> m Void -> m (Thread m Void)
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
"NodeKernel.blockFetchLogic" (m Void -> m (Thread m Void)) -> m Void -> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$
Tracer
m
[TraceLabelPeer
(ConnectionId addrNTN) (FetchDecision [Point (Header blk)])]
-> Tracer
m
(TraceLabelPeer
(ConnectionId addrNTN) (TraceFetchClientState (Header blk)))
-> BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
-> FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
-> BlockFetchConfiguration
-> m Void
forall addr header block (m :: * -> *).
(HasHeader header, HasHeader block,
HeaderHash header ~ HeaderHash block, MonadDelay m, MonadSTM m,
Ord addr, Hashable addr) =>
Tracer m [TraceLabelPeer addr (FetchDecision [Point header])]
-> Tracer m (TraceLabelPeer addr (TraceFetchClientState header))
-> BlockFetchConsensusInterface addr header block m
-> FetchClientRegistry addr header block m
-> BlockFetchConfiguration
-> m Void
blockFetchLogic
(Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer
m
[TraceLabelPeer
(ConnectionId addrNTN) (FetchDecision [Point (Header blk)])]
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f [TraceLabelPeer
remotePeer (FetchDecision [Point (Header blk)])]
blockFetchDecisionTracer Tracers m (ConnectionId addrNTN) addrNTC blk
tracers)
(Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer
m
(TraceLabelPeer
(ConnectionId addrNTN) (TraceFetchClientState (Header blk)))
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceLabelPeer
remotePeer (TraceFetchClientState (Header blk)))
blockFetchClientTracer Tracers m (ConnectionId addrNTN) addrNTC blk
tracers)
BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
blockFetchInterface
FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
fetchClientRegistry
BlockFetchConfiguration
blockFetchConfiguration
NodeKernel m addrNTN addrNTC blk
-> m (NodeKernel m addrNTN addrNTC blk)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return NodeKernel
{ $sel:getChainDB:NodeKernel :: ChainDB m blk
getChainDB = ChainDB m blk
chainDB
, $sel:getMempool:NodeKernel :: Mempool m blk
getMempool = Mempool m blk
mempool
, $sel:getTopLevelConfig:NodeKernel :: TopLevelConfig blk
getTopLevelConfig = TopLevelConfig blk
cfg
, $sel:getFetchClientRegistry:NodeKernel :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
getFetchClientRegistry = FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
fetchClientRegistry
, $sel:getFetchMode:NodeKernel :: STM m FetchMode
getFetchMode = BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
-> STM m FetchMode
forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m -> STM m FetchMode
readFetchMode BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
blockFetchInterface
, $sel:getGsmState:NodeKernel :: STM m GsmState
getGsmState = StrictTVar m GsmState -> STM m GsmState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m GsmState
varGsmState
, $sel:getChainSyncHandles:NodeKernel :: StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
getChainSyncHandles = StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles
, $sel:getPeerSharingRegistry:NodeKernel :: PeerSharingRegistry addrNTN m
getPeerSharingRegistry = PeerSharingRegistry addrNTN m
peerSharingRegistry
, $sel:getTracers:NodeKernel :: Tracers m (ConnectionId addrNTN) addrNTC blk
getTracers = Tracers m (ConnectionId addrNTN) addrNTC blk
tracers
, $sel:setBlockForging:NodeKernel :: [BlockForging m blk] -> m ()
setBlockForging = \[BlockForging m blk]
a -> STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ())
-> ([BlockForging m blk] -> STM m ())
-> [BlockForging m blk]
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar m [BlockForging m blk] -> [BlockForging m blk] -> STM m ()
forall a. TMVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> a -> STM m ()
LazySTM.putTMVar TMVar m [BlockForging m blk]
blockForgingVar ([BlockForging m blk] -> m ()) -> [BlockForging m blk] -> m ()
forall a b. (a -> b) -> a -> b
$! [BlockForging m blk]
a
, $sel:getPeerSharingAPI:NodeKernel :: PeerSharingAPI addrNTN StdGen m
getPeerSharingAPI = PeerSharingAPI addrNTN StdGen m
peerSharingAPI
, $sel:getOutboundConnectionsState:NodeKernel :: StrictTVar m OutboundConnectionsState
getOutboundConnectionsState
= StrictTVar m OutboundConnectionsState
varOutboundConnectionsState
, DiffusionPipeliningSupport
$sel:getDiffusionPipeliningSupport:NodeKernel :: DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: DiffusionPipeliningSupport
getDiffusionPipeliningSupport
}
where
blockForgingController :: InternalState m remotePeer localPeer blk
-> STM m [BlockForging m blk]
-> m Void
blockForgingController :: forall remotePeer localPeer.
InternalState m remotePeer localPeer blk
-> STM m [BlockForging m blk] -> m Void
blockForgingController InternalState m remotePeer localPeer blk
st STM m [BlockForging m blk]
getBlockForging = [Thread m Void] -> m Void
go []
where
go :: [Thread m Void] -> m Void
go :: [Thread m Void] -> m Void
go ![Thread m Void]
forgingThreads = do
[BlockForging m blk]
blockForging <- STM m [BlockForging m blk] -> m [BlockForging m blk]
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m [BlockForging m blk]
getBlockForging
(Thread m Void -> m ()) -> [Thread m Void] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Thread m Void -> m ()
forall (m :: * -> *) a. MonadAsync m => Thread m a -> m ()
cancelThread [Thread m Void]
forgingThreads
[Thread m Void]
blockForging' <- (BlockForging m blk -> m (Thread m Void))
-> [BlockForging m blk] -> m [Thread m Void]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (InternalState m remotePeer localPeer blk
-> BlockForging m blk -> m (Thread m Void)
forall (m :: * -> *) addrNTN addrNTC blk.
(IOLike m, RunNode blk) =>
InternalState m addrNTN addrNTC blk
-> BlockForging m blk -> m (Thread m Void)
forkBlockForging InternalState m remotePeer localPeer blk
st) [BlockForging m blk]
blockForging
[Thread m Void] -> m Void
go [Thread m Void]
blockForging'
data InternalState m addrNTN addrNTC blk = IS {
forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
, forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
, forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> ResourceRegistry m
registry :: ResourceRegistry m
, forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> BlockchainTime m
btime :: BlockchainTime m
, forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> ChainDB m blk
chainDB :: ChainDB m blk
, forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (Header blk) blk m
, forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
, forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles :: StrictTVar m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
, forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> StrictTVar m GsmState
varGsmState :: StrictTVar m GSM.GsmState
, forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> Mempool m blk
mempool :: Mempool m blk
, forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> PeerSharingRegistry addrNTN m
peerSharingRegistry :: PeerSharingRegistry addrNTN m
}
initInternalState ::
forall m addrNTN addrNTC blk.
( IOLike m
, Ord addrNTN
, Typeable addrNTN
, RunNode blk
)
=> NodeKernelArgs m addrNTN addrNTC blk
-> m (InternalState m addrNTN addrNTC blk)
initInternalState :: forall (m :: * -> *) addrNTN addrNTC blk.
(IOLike m, Ord addrNTN, Typeable addrNTN, RunNode blk) =>
NodeKernelArgs m addrNTN addrNTC blk
-> m (InternalState m addrNTN addrNTC blk)
initInternalState NodeKernelArgs { Tracers m (ConnectionId addrNTN) addrNTC blk
$sel:tracers:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
tracers, ChainDB m blk
$sel:chainDB:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ChainDB m blk
chainDB :: ChainDB m blk
chainDB, ResourceRegistry m
$sel:registry:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ResourceRegistry m
registry :: ResourceRegistry m
registry, TopLevelConfig blk
$sel:cfg:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg
, Header blk -> SizeInBytes
$sel:blockFetchSize:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> Header blk -> SizeInBytes
blockFetchSize :: Header blk -> SizeInBytes
blockFetchSize, BlockchainTime m
$sel:btime:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockchainTime m
btime :: BlockchainTime m
btime
, MempoolCapacityBytesOverride
$sel:mempoolCapacityOverride:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> MempoolCapacityBytesOverride
mempoolCapacityOverride :: MempoolCapacityBytesOverride
mempoolCapacityOverride
, GsmNodeKernelArgs m blk
$sel:gsmArgs:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GsmNodeKernelArgs m blk
gsmArgs :: GsmNodeKernelArgs m blk
gsmArgs, STM m UseBootstrapPeers
$sel:getUseBootstrapPeers:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> STM m UseBootstrapPeers
getUseBootstrapPeers :: STM m UseBootstrapPeers
getUseBootstrapPeers
, DiffusionPipeliningSupport
$sel:getDiffusionPipeliningSupport:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: DiffusionPipeliningSupport
getDiffusionPipeliningSupport
} = do
StrictTVar m GsmState
varGsmState <- do
let GsmNodeKernelArgs {Maybe (WrapDurationUntilTooOld m blk)
StdGen
NominalDiffTime
MarkerFileView m
gsmAntiThunderingHerd :: forall (m :: * -> *) blk. GsmNodeKernelArgs m blk -> StdGen
gsmDurationUntilTooOld :: forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> Maybe (WrapDurationUntilTooOld m blk)
gsmMarkerFileView :: forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> MarkerFileView m
gsmMinCaughtUpDuration :: forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> NominalDiffTime
gsmAntiThunderingHerd :: StdGen
gsmDurationUntilTooOld :: Maybe (WrapDurationUntilTooOld m blk)
gsmMarkerFileView :: MarkerFileView m
gsmMinCaughtUpDuration :: NominalDiffTime
..} = GsmNodeKernelArgs m blk
gsmArgs
GsmState
gsmState <- m (LedgerState blk)
-> Maybe (WrapDurationUntilTooOld m blk)
-> MarkerFileView m
-> m GsmState
forall blk (m :: * -> *).
(GetTip (LedgerState blk), Monad m) =>
m (LedgerState blk)
-> Maybe (WrapDurationUntilTooOld m blk)
-> MarkerFileView m
-> m GsmState
GSM.initializationGsmState
(STM m (LedgerState blk) -> m (LedgerState blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LedgerState blk) -> m (LedgerState blk))
-> STM m (LedgerState blk) -> m (LedgerState blk)
forall a b. (a -> b) -> a -> b
$ ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> STM m (ExtLedgerState blk) -> STM m (LedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
(Monad (STM m), IsLedger (LedgerState blk)) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB m blk
chainDB)
Maybe (WrapDurationUntilTooOld m blk)
gsmDurationUntilTooOld
MarkerFileView m
gsmMarkerFileView
GsmState -> m (StrictTVar m GsmState)
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO GsmState
gsmState
StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles <- Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)
-> m (StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk)
forall a. Monoid a => a
mempty
Mempool m blk
mempool <- ResourceRegistry m
-> LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> m (Mempool m blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk),
ValidateEnvelope blk) =>
ResourceRegistry m
-> LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> m (Mempool m blk)
openMempool ResourceRegistry m
registry
(ChainDB m blk -> LedgerInterface m blk
forall (m :: * -> *) blk.
(IOLike m, IsLedger (LedgerState blk)) =>
ChainDB m blk -> LedgerInterface m blk
chainDBLedgerInterface ChainDB m blk
chainDB)
(TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg)
MempoolCapacityBytesOverride
mempoolCapacityOverride
(Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer m (TraceEventMempool blk)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f -> f (TraceEventMempool blk)
mempoolTracer Tracers m (ConnectionId addrNTN) addrNTC blk
tracers)
FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
fetchClientRegistry <- m (FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m)
forall (m :: * -> *) peer header block.
MonadSTM m =>
m (FetchClientRegistry peer header block m)
newFetchClientRegistry
let getCandidates :: STM m (Map (ConnectionId addrNTN) (AnchoredFragment (Header blk)))
getCandidates :: STM m (Map (ConnectionId addrNTN) (AnchoredFragment (Header blk)))
getCandidates = StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
-> (ChainSyncState blk -> AnchoredFragment (Header blk))
-> STM
m (Map (ConnectionId addrNTN) (AnchoredFragment (Header blk)))
forall (m :: * -> *) peer blk a.
IOLike m =>
StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> (ChainSyncState blk -> a) -> STM m (Map peer a)
viewChainSyncState StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varChainSyncHandles ChainSyncState blk -> AnchoredFragment (Header blk)
forall blk. ChainSyncState blk -> AnchoredFragment (Header blk)
csCandidate
RealPoint blk -> STM m UTCTime
slotForgeTimeOracle <- TopLevelConfig blk
-> ChainDB m blk -> m (RealPoint blk -> STM m UTCTime)
forall (m :: * -> *) blk.
(IOLike m, BlockSupportsProtocol blk, HasHardForkHistory blk,
ConfigSupportsNode blk, IsLedger (LedgerState blk)) =>
TopLevelConfig blk
-> ChainDB m blk -> m (SlotForgeTimeOracle m blk)
BlockFetchClientInterface.initSlotForgeTimeOracle TopLevelConfig blk
cfg ChainDB m blk
chainDB
let readFetchMode :: STM m FetchMode
readFetchMode = BlockchainTime m
-> STM m (AnchoredFragment (Header blk))
-> STM m UseBootstrapPeers
-> STM m LedgerStateJudgement
-> STM m FetchMode
forall (m :: * -> *) blk.
(MonadSTM m, HasHeader blk) =>
BlockchainTime m
-> STM m (AnchoredFragment blk)
-> STM m UseBootstrapPeers
-> STM m LedgerStateJudgement
-> STM m FetchMode
BlockFetchClientInterface.readFetchModeDefault
BlockchainTime m
btime
(ChainDB m blk -> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (Header blk))
ChainDB.getCurrentChain ChainDB m blk
chainDB)
STM m UseBootstrapPeers
getUseBootstrapPeers
(GsmState -> LedgerStateJudgement
GSM.gsmStateToLedgerJudgement (GsmState -> LedgerStateJudgement)
-> STM m GsmState -> STM m LedgerStateJudgement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m GsmState -> STM m GsmState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m GsmState
varGsmState)
blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (Header blk) blk m
blockFetchInterface :: BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
blockFetchInterface = BlockConfig blk
-> ChainDbView m blk
-> STM
m (Map (ConnectionId addrNTN) (AnchoredFragment (Header blk)))
-> (Header blk -> SizeInBytes)
-> (RealPoint blk -> STM m UTCTime)
-> STM m FetchMode
-> DiffusionPipeliningSupport
-> BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
forall (m :: * -> *) peer blk.
(IOLike m, BlockSupportsDiffusionPipelining blk,
BlockSupportsProtocol blk) =>
BlockConfig blk
-> ChainDbView m blk
-> STM m (Map peer (AnchoredFragment (Header blk)))
-> (Header blk -> SizeInBytes)
-> SlotForgeTimeOracle m blk
-> STM m FetchMode
-> DiffusionPipeliningSupport
-> BlockFetchConsensusInterface peer (Header blk) blk m
BlockFetchClientInterface.mkBlockFetchConsensusInterface
(TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg)
(ChainDB m blk -> ChainDbView m blk
forall (m :: * -> *) blk.
IOLike m =>
ChainDB m blk -> ChainDbView m blk
BlockFetchClientInterface.defaultChainDbView ChainDB m blk
chainDB)
STM m (Map (ConnectionId addrNTN) (AnchoredFragment (Header blk)))
getCandidates
Header blk -> SizeInBytes
blockFetchSize
RealPoint blk -> STM m UTCTime
slotForgeTimeOracle
STM m FetchMode
readFetchMode
DiffusionPipeliningSupport
getDiffusionPipeliningSupport
PeerSharingRegistry addrNTN m
peerSharingRegistry <- m (PeerSharingRegistry addrNTN m)
forall (m :: * -> *) peer.
(MonadSTM m, Ord peer) =>
m (PeerSharingRegistry peer m)
newPeerSharingRegistry
InternalState m addrNTN addrNTC blk
-> m (InternalState m addrNTN addrNTC blk)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return IS {StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
StrictTVar m GsmState
TopLevelConfig blk
Mempool m blk
BlockchainTime m
ChainDB m blk
ResourceRegistry m
BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
PeerSharingRegistry addrNTN m
FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
Tracers m (ConnectionId addrNTN) addrNTC blk
$sel:blockFetchInterface:IS :: BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
$sel:fetchClientRegistry:IS :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
$sel:mempool:IS :: Mempool m blk
$sel:peerSharingRegistry:IS :: PeerSharingRegistry addrNTN m
$sel:varChainSyncHandles:IS :: StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
$sel:varGsmState:IS :: StrictTVar m GsmState
$sel:tracers:IS :: Tracers m (ConnectionId addrNTN) addrNTC blk
$sel:cfg:IS :: TopLevelConfig blk
$sel:registry:IS :: ResourceRegistry m
$sel:btime:IS :: BlockchainTime m
$sel:chainDB:IS :: ChainDB m blk
tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
chainDB :: ChainDB m blk
registry :: ResourceRegistry m
cfg :: TopLevelConfig blk
btime :: BlockchainTime m
varGsmState :: StrictTVar m GsmState
varChainSyncHandles :: StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
mempool :: Mempool m blk
fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
blockFetchInterface :: BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
peerSharingRegistry :: PeerSharingRegistry addrNTN m
..}
forkBlockForging ::
forall m addrNTN addrNTC blk.
(IOLike m, RunNode blk)
=> InternalState m addrNTN addrNTC blk
-> BlockForging m blk
-> m (Thread m Void)
forkBlockForging :: forall (m :: * -> *) addrNTN addrNTC blk.
(IOLike m, RunNode blk) =>
InternalState m addrNTN addrNTC blk
-> BlockForging m blk -> m (Thread m Void)
forkBlockForging IS{StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
StrictTVar m GsmState
TopLevelConfig blk
Mempool m blk
BlockchainTime m
ChainDB m blk
ResourceRegistry m
BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
PeerSharingRegistry addrNTN m
FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
Tracers m (ConnectionId addrNTN) addrNTC blk
$sel:blockFetchInterface:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
$sel:fetchClientRegistry:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
$sel:mempool:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> Mempool m blk
$sel:peerSharingRegistry:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> PeerSharingRegistry addrNTN m
$sel:varChainSyncHandles:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
$sel:varGsmState:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> StrictTVar m GsmState
$sel:tracers:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
$sel:cfg:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> TopLevelConfig blk
$sel:registry:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> ResourceRegistry m
$sel:btime:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> BlockchainTime m
$sel:chainDB:IS :: forall (m :: * -> *) addrNTN addrNTC blk.
InternalState m addrNTN addrNTC blk -> ChainDB m blk
tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
cfg :: TopLevelConfig blk
registry :: ResourceRegistry m
btime :: BlockchainTime m
chainDB :: ChainDB m blk
blockFetchInterface :: BlockFetchConsensusInterface
(ConnectionId addrNTN) (Header blk) blk m
fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
varChainSyncHandles :: StrictTVar
m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
varGsmState :: StrictTVar m GsmState
mempool :: Mempool m blk
peerSharingRegistry :: PeerSharingRegistry addrNTN m
..} BlockForging m blk
blockForging =
ResourceRegistry m
-> String -> Watcher m SlotNo SlotNo -> m (Thread m Void)
forall (m :: * -> *) a fp.
(IOLike m, Eq fp, HasCallStack) =>
ResourceRegistry m -> String -> Watcher m a fp -> m (Thread m Void)
forkLinkedWatcher ResourceRegistry m
registry String
threadLabel
(Watcher m SlotNo SlotNo -> m (Thread m Void))
-> Watcher m SlotNo SlotNo -> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$ BlockchainTime m -> (SlotNo -> m ()) -> Watcher m SlotNo SlotNo
forall (m :: * -> *).
IOLike m =>
BlockchainTime m -> (SlotNo -> m ()) -> Watcher m SlotNo SlotNo
knownSlotWatcher BlockchainTime m
btime
((SlotNo -> m ()) -> Watcher m SlotNo SlotNo)
-> (SlotNo -> m ()) -> Watcher m SlotNo SlotNo
forall a b. (a -> b) -> a -> b
$ WithEarlyExit m () -> m ()
forall (m :: * -> *). Functor m => WithEarlyExit m () -> m ()
withEarlyExit_ (WithEarlyExit m () -> m ())
-> (SlotNo -> WithEarlyExit m ()) -> SlotNo -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> WithEarlyExit m ()
go
where
threadLabel :: String
threadLabel :: String
threadLabel =
String
"NodeKernel.blockForging." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (BlockForging m blk -> Text
forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel BlockForging m blk
blockForging)
go :: SlotNo -> WithEarlyExit m ()
go :: SlotNo -> WithEarlyExit m ()
go SlotNo
currentSlot = do
TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> TraceForgeEvent blk
forall blk. SlotNo -> TraceForgeEvent blk
TraceStartLeadershipCheck SlotNo
currentSlot
BlockContext{BlockNo
bcBlockNo :: BlockNo
$sel:bcBlockNo:BlockContext :: forall blk. BlockContext blk -> BlockNo
bcBlockNo, Point blk
bcPrevPoint :: Point blk
$sel:bcPrevPoint:BlockContext :: forall blk. BlockContext blk -> Point blk
bcPrevPoint} <- do
Either (TraceForgeEvent blk) (BlockContext blk)
eBlkCtx <- m (Either (TraceForgeEvent blk) (BlockContext blk))
-> WithEarlyExit
m (Either (TraceForgeEvent blk) (BlockContext blk))
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either (TraceForgeEvent blk) (BlockContext blk))
-> WithEarlyExit
m (Either (TraceForgeEvent blk) (BlockContext blk)))
-> m (Either (TraceForgeEvent blk) (BlockContext blk))
-> WithEarlyExit
m (Either (TraceForgeEvent blk) (BlockContext blk))
forall a b. (a -> b) -> a -> b
$ STM m (Either (TraceForgeEvent blk) (BlockContext blk))
-> m (Either (TraceForgeEvent blk) (BlockContext blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Either (TraceForgeEvent blk) (BlockContext blk))
-> m (Either (TraceForgeEvent blk) (BlockContext blk)))
-> STM m (Either (TraceForgeEvent blk) (BlockContext blk))
-> m (Either (TraceForgeEvent blk) (BlockContext blk))
forall a b. (a -> b) -> a -> b
$
SlotNo
-> AnchoredFragment (Header blk)
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall blk.
RunNode blk =>
SlotNo
-> AnchoredFragment (Header blk)
-> Either (TraceForgeEvent blk) (BlockContext blk)
mkCurrentBlockContext SlotNo
currentSlot
(AnchoredFragment (Header blk)
-> Either (TraceForgeEvent blk) (BlockContext blk))
-> STM m (AnchoredFragment (Header blk))
-> STM m (Either (TraceForgeEvent blk) (BlockContext blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (Header blk))
ChainDB.getCurrentChain ChainDB m blk
chainDB
case Either (TraceForgeEvent blk) (BlockContext blk)
eBlkCtx of
Right BlockContext blk
blkCtx -> BlockContext blk -> WithEarlyExit m (BlockContext blk)
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockContext blk
blkCtx
Left TraceForgeEvent blk
failure -> do
TraceForgeEvent blk -> WithEarlyExit m ()
trace TraceForgeEvent blk
failure
WithEarlyExit m (BlockContext blk)
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> BlockNo -> Point blk -> TraceForgeEvent blk
forall blk. SlotNo -> BlockNo -> Point blk -> TraceForgeEvent blk
TraceBlockContext SlotNo
currentSlot BlockNo
bcBlockNo Point blk
bcPrevPoint
ExtLedgerState blk
unticked <- do
Maybe (ExtLedgerState blk)
mExtLedger <- m (Maybe (ExtLedgerState blk))
-> WithEarlyExit m (Maybe (ExtLedgerState blk))
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe (ExtLedgerState blk))
-> WithEarlyExit m (Maybe (ExtLedgerState blk)))
-> m (Maybe (ExtLedgerState blk))
-> WithEarlyExit m (Maybe (ExtLedgerState blk))
forall a b. (a -> b) -> a -> b
$ STM m (Maybe (ExtLedgerState blk))
-> m (Maybe (ExtLedgerState blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (ExtLedgerState blk))
-> m (Maybe (ExtLedgerState blk)))
-> STM m (Maybe (ExtLedgerState blk))
-> m (Maybe (ExtLedgerState blk))
forall a b. (a -> b) -> a -> b
$ ChainDB m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk))
forall (m :: * -> *) blk.
(Monad (STM m), LedgerSupportsProtocol blk) =>
ChainDB m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk))
ChainDB.getPastLedger ChainDB m blk
chainDB Point blk
bcPrevPoint
case Maybe (ExtLedgerState blk)
mExtLedger of
Just ExtLedgerState blk
l -> ExtLedgerState blk -> WithEarlyExit m (ExtLedgerState blk)
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. Monad m => a -> m a
return ExtLedgerState blk
l
Maybe (ExtLedgerState blk)
Nothing -> do
TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> Point blk -> TraceForgeEvent blk
forall blk. SlotNo -> Point blk -> TraceForgeEvent blk
TraceNoLedgerState SlotNo
currentSlot Point blk
bcPrevPoint
WithEarlyExit m (ExtLedgerState blk)
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> Point blk -> TraceForgeEvent blk
forall blk. SlotNo -> Point blk -> TraceForgeEvent blk
TraceLedgerState SlotNo
currentSlot Point blk
bcPrevPoint
LedgerView (BlockProtocol blk)
ledgerView <-
case Except OutsideForecastRange (LedgerView (BlockProtocol blk))
-> Either OutsideForecastRange (LedgerView (BlockProtocol blk))
forall e a. Except e a -> Either e a
runExcept (Except OutsideForecastRange (LedgerView (BlockProtocol blk))
-> Either OutsideForecastRange (LedgerView (BlockProtocol blk)))
-> Except OutsideForecastRange (LedgerView (BlockProtocol blk))
-> Either OutsideForecastRange (LedgerView (BlockProtocol blk))
forall a b. (a -> b) -> a -> b
$ Forecast (LedgerView (BlockProtocol blk))
-> SlotNo
-> Except OutsideForecastRange (LedgerView (BlockProtocol blk))
forall a. Forecast a -> SlotNo -> Except OutsideForecastRange a
forecastFor
(LedgerConfig blk
-> LedgerState blk -> Forecast (LedgerView (BlockProtocol blk))
forall blk.
(LedgerSupportsProtocol blk, HasCallStack) =>
LedgerConfig blk
-> LedgerState blk -> Forecast (LedgerView (BlockProtocol blk))
ledgerViewForecastAt
(TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg)
(ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
unticked))
SlotNo
currentSlot of
Left OutsideForecastRange
err -> do
TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> OutsideForecastRange -> TraceForgeEvent blk
forall blk. SlotNo -> OutsideForecastRange -> TraceForgeEvent blk
TraceNoLedgerView SlotNo
currentSlot OutsideForecastRange
err
WithEarlyExit m (LedgerView (BlockProtocol blk))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
Right LedgerView (BlockProtocol blk)
lv ->
LedgerView (BlockProtocol blk)
-> WithEarlyExit m (LedgerView (BlockProtocol blk))
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. Monad m => a -> m a
return LedgerView (BlockProtocol blk)
lv
TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> TraceForgeEvent blk
forall blk. SlotNo -> TraceForgeEvent blk
TraceLedgerView SlotNo
currentSlot
let tickedChainDepState :: Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState :: Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState =
ConsensusConfig (BlockProtocol blk)
-> LedgerView (BlockProtocol blk)
-> SlotNo
-> ChainDepState (BlockProtocol blk)
-> Ticked (ChainDepState (BlockProtocol blk))
forall p.
ConsensusProtocol p =>
ConsensusConfig p
-> LedgerView p
-> SlotNo
-> ChainDepState p
-> Ticked (ChainDepState p)
tickChainDepState
(TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig blk
cfg)
LedgerView (BlockProtocol blk)
ledgerView
SlotNo
currentSlot
(HeaderState blk -> ChainDepState (BlockProtocol blk)
forall blk. HeaderState blk -> ChainDepState (BlockProtocol blk)
headerStateChainDep (ExtLedgerState blk -> HeaderState blk
forall blk. ExtLedgerState blk -> HeaderState blk
headerState ExtLedgerState blk
unticked))
IsLeader (BlockProtocol blk)
proof <- do
ShouldForge blk
shouldForge <- m (ShouldForge blk) -> WithEarlyExit m (ShouldForge blk)
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ShouldForge blk) -> WithEarlyExit m (ShouldForge blk))
-> m (ShouldForge blk) -> WithEarlyExit m (ShouldForge blk)
forall a b. (a -> b) -> a -> b
$
BlockForging m blk
-> Tracer m (ForgeStateInfo blk)
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ShouldForge blk)
forall (m :: * -> *) blk.
(Monad m, ConsensusProtocol (BlockProtocol blk), HasCallStack) =>
BlockForging m blk
-> Tracer m (ForgeStateInfo blk)
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ShouldForge blk)
checkShouldForge BlockForging m blk
blockForging
((ForgeStateInfo blk -> TraceLabelCreds (ForgeStateInfo blk))
-> Tracer m (TraceLabelCreds (ForgeStateInfo blk))
-> Tracer m (ForgeStateInfo blk)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (Text -> ForgeStateInfo blk -> TraceLabelCreds (ForgeStateInfo blk)
forall a. Text -> a -> TraceLabelCreds a
TraceLabelCreds (BlockForging m blk -> Text
forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel BlockForging m blk
blockForging))
(Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer m (TraceLabelCreds (ForgeStateInfo blk))
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceLabelCreds (ForgeStateInfo blk))
forgeStateInfoTracer Tracers m (ConnectionId addrNTN) addrNTC blk
tracers))
TopLevelConfig blk
cfg
SlotNo
currentSlot
Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState
case ShouldForge blk
shouldForge of
ForgeStateUpdateError ForgeStateUpdateError blk
err -> do
TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> ForgeStateUpdateError blk -> TraceForgeEvent blk
forall blk.
SlotNo -> ForgeStateUpdateError blk -> TraceForgeEvent blk
TraceForgeStateUpdateError SlotNo
currentSlot ForgeStateUpdateError blk
err
WithEarlyExit m (IsLeader (BlockProtocol blk))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
CannotForge CannotForge blk
cannotForge -> do
TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> CannotForge blk -> TraceForgeEvent blk
forall blk. SlotNo -> CannotForge blk -> TraceForgeEvent blk
TraceNodeCannotForge SlotNo
currentSlot CannotForge blk
cannotForge
WithEarlyExit m (IsLeader (BlockProtocol blk))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
ShouldForge blk
NotLeader -> do
TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> TraceForgeEvent blk
forall blk. SlotNo -> TraceForgeEvent blk
TraceNodeNotLeader SlotNo
currentSlot
WithEarlyExit m (IsLeader (BlockProtocol blk))
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
ShouldForge IsLeader (BlockProtocol blk)
p -> IsLeader (BlockProtocol blk)
-> WithEarlyExit m (IsLeader (BlockProtocol blk))
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. Monad m => a -> m a
return IsLeader (BlockProtocol blk)
p
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
let tickedLedgerState :: Ticked (LedgerState blk)
tickedLedgerState :: TickedLedgerState blk
tickedLedgerState =
LedgerConfig blk
-> SlotNo -> LedgerState blk -> TickedLedgerState blk
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick
(TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg)
SlotNo
currentSlot
(ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
unticked)
TickedLedgerState blk
_ <- TickedLedgerState blk -> WithEarlyExit m (TickedLedgerState blk)
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate TickedLedgerState blk
tickedLedgerState
TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> Point blk -> TraceForgeEvent blk
forall blk. SlotNo -> Point blk -> TraceForgeEvent blk
TraceForgeTickedLedgerState SlotNo
currentSlot Point blk
bcPrevPoint
(ChainHash blk
mempoolHash, SlotNo
mempoolSlotNo, MempoolSnapshot blk
mempoolSnapshot) <- m (ChainHash blk, SlotNo, MempoolSnapshot blk)
-> WithEarlyExit m (ChainHash blk, SlotNo, MempoolSnapshot blk)
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ChainHash blk, SlotNo, MempoolSnapshot blk)
-> WithEarlyExit m (ChainHash blk, SlotNo, MempoolSnapshot blk))
-> m (ChainHash blk, SlotNo, MempoolSnapshot blk)
-> WithEarlyExit m (ChainHash blk, SlotNo, MempoolSnapshot blk)
forall a b. (a -> b) -> a -> b
$ STM m (ChainHash blk, SlotNo, MempoolSnapshot blk)
-> m (ChainHash blk, SlotNo, MempoolSnapshot blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ChainHash blk, SlotNo, MempoolSnapshot blk)
-> m (ChainHash blk, SlotNo, MempoolSnapshot blk))
-> STM m (ChainHash blk, SlotNo, MempoolSnapshot blk)
-> m (ChainHash blk, SlotNo, MempoolSnapshot blk)
forall a b. (a -> b) -> a -> b
$ do
(ChainHash blk
mempoolHash, SlotNo
mempoolSlotNo) <- do
MempoolSnapshot blk
snap <- Mempool m blk -> STM m (MempoolSnapshot blk)
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool m blk
mempool
let h :: ChainHash blk
h :: ChainHash blk
h = ChainHash (TickedLedgerState blk) -> ChainHash blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash (ChainHash (TickedLedgerState blk) -> ChainHash blk)
-> ChainHash (TickedLedgerState blk) -> ChainHash blk
forall a b. (a -> b) -> a -> b
$ TickedLedgerState blk -> ChainHash (TickedLedgerState blk)
forall l. GetTip l => l -> ChainHash l
getTipHash (TickedLedgerState blk -> ChainHash (TickedLedgerState blk))
-> TickedLedgerState blk -> ChainHash (TickedLedgerState blk)
forall a b. (a -> b) -> a -> b
$ MempoolSnapshot blk -> TickedLedgerState blk
forall blk. MempoolSnapshot blk -> TickedLedgerState blk
snapshotLedgerState MempoolSnapshot blk
snap
(ChainHash blk, SlotNo) -> STM m (ChainHash blk, SlotNo)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainHash blk
h, MempoolSnapshot blk -> SlotNo
forall blk. MempoolSnapshot blk -> SlotNo
snapshotSlotNo MempoolSnapshot blk
snap)
MempoolSnapshot blk
snap <- Mempool m blk
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk)
forall (m :: * -> *) blk.
Mempool m blk
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk)
getSnapshotFor
Mempool m blk
mempool
(SlotNo -> TickedLedgerState blk -> ForgeLedgerState blk
forall blk. SlotNo -> TickedLedgerState blk -> ForgeLedgerState blk
ForgeInKnownSlot SlotNo
currentSlot TickedLedgerState blk
tickedLedgerState)
(ChainHash blk, SlotNo, MempoolSnapshot blk)
-> STM m (ChainHash blk, SlotNo, MempoolSnapshot blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainHash blk
mempoolHash, SlotNo
mempoolSlotNo, MempoolSnapshot blk
snap)
let txs :: [Validated (GenTx blk)]
txs =
MempoolSnapshot blk -> TxMeasure blk -> [Validated (GenTx blk)]
forall blk.
MempoolSnapshot blk -> TxMeasure blk -> [Validated (GenTx blk)]
snapshotTake MempoolSnapshot blk
mempoolSnapshot
(TxMeasure blk -> [Validated (GenTx blk)])
-> TxMeasure blk -> [Validated (GenTx blk)]
forall a b. (a -> b) -> a -> b
$ LedgerConfig blk -> TickedLedgerState blk -> TxMeasure blk
forall blk.
TxLimits blk =>
LedgerConfig blk -> TickedLedgerState blk -> TxMeasure blk
blockCapacityTxMeasure (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg) TickedLedgerState blk
tickedLedgerState
Int
_ <- Int -> WithEarlyExit m Int
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate ([Validated (GenTx blk)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Validated (GenTx blk)]
txs)
TickedLedgerState blk
_ <- TickedLedgerState blk -> WithEarlyExit m (TickedLedgerState blk)
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate (MempoolSnapshot blk -> TickedLedgerState blk
forall blk. MempoolSnapshot blk -> TickedLedgerState blk
snapshotLedgerState MempoolSnapshot blk
mempoolSnapshot)
TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo
-> Point blk -> ChainHash blk -> SlotNo -> TraceForgeEvent blk
forall blk.
SlotNo
-> Point blk -> ChainHash blk -> SlotNo -> TraceForgeEvent blk
TraceForgingMempoolSnapshot SlotNo
currentSlot Point blk
bcPrevPoint ChainHash blk
mempoolHash SlotNo
mempoolSlotNo
blk
newBlock <- m blk -> WithEarlyExit m blk
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m blk -> WithEarlyExit m blk) -> m blk -> WithEarlyExit m blk
forall a b. (a -> b) -> a -> b
$
BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
Block.forgeBlock BlockForging m blk
blockForging
TopLevelConfig blk
cfg
BlockNo
bcBlockNo
SlotNo
currentSlot
TickedLedgerState blk
tickedLedgerState
[Validated (GenTx blk)]
txs
IsLeader (BlockProtocol blk)
proof
TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> Point blk -> blk -> MempoolSize -> TraceForgeEvent blk
forall blk.
SlotNo -> Point blk -> blk -> MempoolSize -> TraceForgeEvent blk
TraceForgedBlock
SlotNo
currentSlot
(LedgerState blk -> Point blk
forall blk. UpdateLedger blk => LedgerState blk -> Point blk
ledgerTipPoint (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
unticked))
blk
newBlock
(MempoolSnapshot blk -> MempoolSize
forall blk. MempoolSnapshot blk -> MempoolSize
snapshotMempoolSize MempoolSnapshot blk
mempoolSnapshot)
let noPunish :: InvalidBlockPunishment m
noPunish = InvalidBlockPunishment m
forall (m :: * -> *). Applicative m => InvalidBlockPunishment m
InvalidBlockPunishment.noPunishment
WithEarlyExit m () -> WithEarlyExit m ()
forall a. WithEarlyExit m a -> WithEarlyExit m a
forall (m :: * -> *) a. MonadMask m => m a -> m a
uninterruptibleMask_ (WithEarlyExit m () -> WithEarlyExit m ())
-> WithEarlyExit m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ do
AddBlockPromise m blk
result <- m (AddBlockPromise m blk)
-> WithEarlyExit m (AddBlockPromise m blk)
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (AddBlockPromise m blk)
-> WithEarlyExit m (AddBlockPromise m blk))
-> m (AddBlockPromise m blk)
-> WithEarlyExit m (AddBlockPromise m blk)
forall a b. (a -> b) -> a -> b
$ ChainDB m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
forall (m :: * -> *) blk.
ChainDB m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
ChainDB.addBlockAsync ChainDB m blk
chainDB InvalidBlockPunishment m
noPunish blk
newBlock
AddBlockResult blk
mbCurTip <- m (AddBlockResult blk) -> WithEarlyExit m (AddBlockResult blk)
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (AddBlockResult blk) -> WithEarlyExit m (AddBlockResult blk))
-> m (AddBlockResult blk) -> WithEarlyExit m (AddBlockResult blk)
forall a b. (a -> b) -> a -> b
$ STM m (AddBlockResult blk) -> m (AddBlockResult blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (AddBlockResult blk) -> m (AddBlockResult blk))
-> STM m (AddBlockResult blk) -> m (AddBlockResult blk)
forall a b. (a -> b) -> a -> b
$ AddBlockPromise m blk -> STM m (AddBlockResult blk)
forall (m :: * -> *) blk.
AddBlockPromise m blk -> STM m (AddBlockResult blk)
ChainDB.blockProcessed AddBlockPromise m blk
result
Bool -> WithEarlyExit m () -> WithEarlyExit m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AddBlockResult blk
mbCurTip AddBlockResult blk -> AddBlockResult blk -> Bool
forall a. Eq a => a -> a -> Bool
/= Point blk -> AddBlockResult blk
forall blk. Point blk -> AddBlockResult blk
SuccesfullyAddedBlock (blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint blk
newBlock)) (WithEarlyExit m () -> WithEarlyExit m ())
-> WithEarlyExit m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ do
Maybe (InvalidBlockReason blk)
isInvalid <- m (Maybe (InvalidBlockReason blk))
-> WithEarlyExit m (Maybe (InvalidBlockReason blk))
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe (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 a. HasCallStack => STM m a -> m a
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
m () -> WithEarlyExit m ()
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithEarlyExit m ()) -> m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ Mempool m blk -> [GenTxId blk] -> m ()
forall (m :: * -> *) blk. Mempool m blk -> [GenTxId blk] -> m ()
removeTxs Mempool m blk
mempool ((Validated (GenTx blk) -> GenTxId blk)
-> [Validated (GenTx blk)] -> [GenTxId blk]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId (GenTx blk -> GenTxId blk)
-> (Validated (GenTx blk) -> GenTx blk)
-> Validated (GenTx blk)
-> GenTxId blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx blk) -> GenTx blk
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated) [Validated (GenTx blk)]
txs)
WithEarlyExit m ()
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
TraceForgeEvent blk -> WithEarlyExit m ()
trace (TraceForgeEvent blk -> WithEarlyExit m ())
-> TraceForgeEvent blk -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> blk -> [Validated (GenTx blk)] -> TraceForgeEvent blk
forall blk.
SlotNo -> blk -> [Validated (GenTx blk)] -> TraceForgeEvent blk
TraceAdoptedBlock SlotNo
currentSlot blk
newBlock [Validated (GenTx blk)]
txs
trace :: TraceForgeEvent blk -> WithEarlyExit m ()
trace :: TraceForgeEvent blk -> WithEarlyExit m ()
trace =
m () -> WithEarlyExit m ()
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
(m () -> WithEarlyExit m ())
-> (TraceForgeEvent blk -> m ())
-> TraceForgeEvent blk
-> WithEarlyExit m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracer m (TraceLabelCreds (TraceForgeEvent blk))
-> TraceLabelCreds (TraceForgeEvent blk) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer m (TraceLabelCreds (TraceForgeEvent blk))
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceLabelCreds (TraceForgeEvent blk))
forgeTracer Tracers m (ConnectionId addrNTN) addrNTC blk
tracers)
(TraceLabelCreds (TraceForgeEvent blk) -> m ())
-> (TraceForgeEvent blk -> TraceLabelCreds (TraceForgeEvent blk))
-> TraceForgeEvent blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> TraceForgeEvent blk -> TraceLabelCreds (TraceForgeEvent blk)
forall a. Text -> a -> TraceLabelCreds a
TraceLabelCreds (BlockForging m blk -> Text
forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel BlockForging m blk
blockForging)
data BlockContext blk = BlockContext
{ forall blk. BlockContext blk -> BlockNo
bcBlockNo :: !BlockNo
, forall blk. BlockContext blk -> Point blk
bcPrevPoint :: !(Point blk)
}
blockContextFromPrevHeader ::
HasHeader (Header blk)
=> Header blk -> BlockContext blk
Header blk
hdr =
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)
mkCurrentBlockContext ::
forall blk. RunNode blk
=> SlotNo
-> AnchoredFragment (Header blk)
-> Either (TraceForgeEvent blk) (BlockContext blk)
mkCurrentBlockContext :: forall blk.
RunNode blk =>
SlotNo
-> AnchoredFragment (Header blk)
-> Either (TraceForgeEvent blk) (BlockContext blk)
mkCurrentBlockContext SlotNo
currentSlot AnchoredFragment (Header blk)
c = case AnchoredFragment (Header blk)
c of
Empty Anchor (Header blk)
AF.AnchorGenesis ->
BlockContext blk -> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. b -> Either a b
Right (BlockContext blk
-> Either (TraceForgeEvent blk) (BlockContext blk))
-> BlockContext blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ BlockNo -> Point blk -> BlockContext blk
forall blk. BlockNo -> Point blk -> BlockContext blk
BlockContext (Proxy blk -> BlockNo
forall blk (proxy :: * -> *).
BasicEnvelopeValidation blk =>
proxy blk -> BlockNo
forall (proxy :: * -> *). proxy blk -> BlockNo
expectedFirstBlockNo (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)) Point blk
forall {k} (block :: k). Point block
GenesisPoint
Empty (AF.Anchor SlotNo
anchorSlot HeaderHash (Header blk)
anchorHash BlockNo
anchorBlockNo) ->
let Point blk
p :: Point blk = SlotNo -> HeaderHash blk -> Point blk
forall {k} (block :: k). SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
anchorSlot HeaderHash blk
HeaderHash (Header blk)
anchorHash
in if SlotNo
anchorSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
currentSlot
then BlockContext blk -> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. b -> Either a b
Right (BlockContext blk
-> Either (TraceForgeEvent blk) (BlockContext blk))
-> BlockContext blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ BlockNo -> Point blk -> BlockContext blk
forall blk. BlockNo -> Point blk -> BlockContext blk
BlockContext (BlockNo -> BlockNo
forall a. Enum a => a -> a
succ BlockNo
anchorBlockNo) Point blk
p
else TraceForgeEvent blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. a -> Either a b
Left (TraceForgeEvent blk
-> Either (TraceForgeEvent blk) (BlockContext blk))
-> TraceForgeEvent blk
-> Either (TraceForgeEvent blk) (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ SlotNo -> Point blk -> BlockNo -> TraceForgeEvent blk
forall blk. SlotNo -> Point blk -> BlockNo -> TraceForgeEvent blk
TraceSlotIsImmutable SlotNo
currentSlot Point blk
p BlockNo
anchorBlockNo
AnchoredFragment (Header blk)
c' :> Header blk
hdr -> case Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr SlotNo -> SlotNo -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` SlotNo
currentSlot of
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
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)
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)
then Header blk -> BlockContext blk
forall blk.
HasHeader (Header blk) =>
Header blk -> BlockContext blk
blockContextFromPrevHeader Header blk
hdr
else BlockNo -> Point blk -> BlockContext blk
forall blk. BlockNo -> Point blk -> BlockContext blk
BlockContext (Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr) (Point blk -> BlockContext blk) -> Point blk -> BlockContext blk
forall a b. (a -> b) -> a -> b
$ Point (Header blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> Point (Header blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
c'
getMempoolReader ::
forall m blk.
( LedgerSupportsMempool blk
, IOLike m
, HasTxId (GenTx blk)
)
=> Mempool m blk
-> TxSubmissionMempoolReader (GenTxId blk) (Validated (GenTx blk)) TicketNo m
getMempoolReader :: forall (m :: * -> *) blk.
(LedgerSupportsMempool blk, IOLike m, HasTxId (GenTx blk)) =>
Mempool m blk
-> TxSubmissionMempoolReader
(GenTxId blk) (Validated (GenTx blk)) TicketNo m
getMempoolReader Mempool m blk
mempool = MempoolReader.TxSubmissionMempoolReader
{ mempoolZeroIdx :: TicketNo
mempoolZeroIdx = TicketNo
zeroTicketNo
, mempoolGetSnapshot :: STM
m (MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo)
mempoolGetSnapshot = MempoolSnapshot blk
-> MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo
convertSnapshot (MempoolSnapshot blk
-> MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo)
-> STM m (MempoolSnapshot blk)
-> STM
m (MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mempool m blk -> STM m (MempoolSnapshot blk)
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool m blk
mempool
}
where
convertSnapshot
:: MempoolSnapshot blk
-> MempoolReader.MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo
convertSnapshot :: MempoolSnapshot blk
-> MempoolSnapshot (GenTxId blk) (Validated (GenTx blk)) TicketNo
convertSnapshot MempoolSnapshot { TicketNo -> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxsAfter :: TicketNo -> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxsAfter :: forall blk.
MempoolSnapshot blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxsAfter, TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx :: TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx :: forall blk.
MempoolSnapshot blk -> TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx,
GenTxId blk -> Bool
snapshotHasTx :: GenTxId blk -> Bool
snapshotHasTx :: forall blk. MempoolSnapshot blk -> GenTxId blk -> Bool
snapshotHasTx } =
MempoolReader.MempoolSnapshot
{ mempoolTxIdsAfter :: TicketNo -> [(GenTxId blk, TicketNo, SizeInBytes)]
mempoolTxIdsAfter = \TicketNo
idx ->
[ ( GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId (Validated (GenTx blk) -> GenTx blk
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated (GenTx blk)
tx)
, TicketNo
idx'
, Word32 -> SizeInBytes
SizeInBytes (Word32 -> SizeInBytes) -> Word32 -> SizeInBytes
forall a b. (a -> b) -> a -> b
$ ByteSize32 -> Word32
unByteSize32 ByteSize32
byteSize
)
| (Validated (GenTx blk)
tx, TicketNo
idx', ByteSize32
byteSize) <- TicketNo -> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxsAfter TicketNo
idx
]
, mempoolLookupTx :: TicketNo -> Maybe (Validated (GenTx blk))
mempoolLookupTx = TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx
, mempoolHasTx :: GenTxId blk -> Bool
mempoolHasTx = GenTxId blk -> Bool
snapshotHasTx
}
getMempoolWriter ::
( LedgerSupportsMempool blk
, IOLike m
, HasTxId (GenTx blk)
)
=> Mempool m blk
-> TxSubmissionMempoolWriter (GenTxId blk) (GenTx blk) TicketNo m
getMempoolWriter :: forall blk (m :: * -> *).
(LedgerSupportsMempool blk, IOLike m, HasTxId (GenTx blk)) =>
Mempool m blk
-> TxSubmissionMempoolWriter (GenTxId blk) (GenTx blk) TicketNo m
getMempoolWriter Mempool m blk
mempool = Inbound.TxSubmissionMempoolWriter
{ txId :: GenTx blk -> TxId (GenTx blk)
Inbound.txId = GenTx blk -> TxId (GenTx blk)
forall tx. HasTxId tx => tx -> TxId tx
txId
, mempoolAddTxs :: [GenTx blk] -> m [TxId (GenTx blk)]
mempoolAddTxs = \[GenTx blk]
txs ->
(Validated (GenTx blk) -> TxId (GenTx blk))
-> [Validated (GenTx blk)] -> [TxId (GenTx blk)]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx blk -> TxId (GenTx blk)
forall tx. HasTxId tx => tx -> TxId tx
txId (GenTx blk -> TxId (GenTx blk))
-> (Validated (GenTx blk) -> GenTx blk)
-> Validated (GenTx blk)
-> TxId (GenTx blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx blk) -> GenTx blk
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated) ([Validated (GenTx blk)] -> [TxId (GenTx blk)])
-> ([MempoolAddTxResult blk] -> [Validated (GenTx blk)])
-> [MempoolAddTxResult blk]
-> [TxId (GenTx blk)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MempoolAddTxResult blk -> Maybe (Validated (GenTx blk)))
-> [MempoolAddTxResult blk] -> [Validated (GenTx blk)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe MempoolAddTxResult blk -> Maybe (Validated (GenTx blk))
forall blk. MempoolAddTxResult blk -> Maybe (Validated (GenTx blk))
mempoolTxAddedToMaybe ([MempoolAddTxResult blk] -> [TxId (GenTx blk)])
-> m [MempoolAddTxResult blk] -> m [TxId (GenTx blk)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Mempool m blk -> [GenTx blk] -> m [MempoolAddTxResult blk]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool m blk
mempool [GenTx blk]
txs
}
getPeersFromCurrentLedger ::
(IOLike m, LedgerSupportsPeerSelection blk)
=> NodeKernel m addrNTN addrNTC blk
-> (LedgerState blk -> Bool)
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
getPeersFromCurrentLedger :: forall (m :: * -> *) blk addrNTN addrNTC.
(IOLike m, LedgerSupportsPeerSelection blk) =>
NodeKernel m addrNTN addrNTC blk
-> (LedgerState blk -> Bool)
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
getPeersFromCurrentLedger NodeKernel m addrNTN addrNTC blk
kernel LedgerState blk -> Bool
p = do
LedgerState blk
immutableLedger <-
ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> STM m (ExtLedgerState blk) -> STM m (LedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
Monad (STM m) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getImmutableLedger (NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
getChainDB NodeKernel m addrNTN addrNTC blk
kernel)
Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)]))
-> Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
forall a b. (a -> b) -> a -> b
$ do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (LedgerState blk -> Bool
p LedgerState blk
immutableLedger)
[(PoolStake, NonEmpty RelayAccessPoint)]
-> Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return
([(PoolStake, NonEmpty RelayAccessPoint)]
-> Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
forall a b. (a -> b) -> a -> b
$ ((PoolStake, NonEmpty StakePoolRelay)
-> (PoolStake, NonEmpty RelayAccessPoint))
-> [(PoolStake, NonEmpty StakePoolRelay)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall a b. (a -> b) -> [a] -> [b]
map ((NonEmpty StakePoolRelay -> NonEmpty RelayAccessPoint)
-> (PoolStake, NonEmpty StakePoolRelay)
-> (PoolStake, NonEmpty RelayAccessPoint)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((StakePoolRelay -> RelayAccessPoint)
-> NonEmpty StakePoolRelay -> NonEmpty RelayAccessPoint
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StakePoolRelay -> RelayAccessPoint
stakePoolRelayAccessPoint))
([(PoolStake, NonEmpty StakePoolRelay)]
-> [(PoolStake, NonEmpty RelayAccessPoint)])
-> [(PoolStake, NonEmpty StakePoolRelay)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall a b. (a -> b) -> a -> b
$ [(PoolStake, NonEmpty StakePoolRelay)]
-> [(PoolStake, NonEmpty StakePoolRelay)]
forall a. NFData a => a -> a
force
([(PoolStake, NonEmpty StakePoolRelay)]
-> [(PoolStake, NonEmpty StakePoolRelay)])
-> [(PoolStake, NonEmpty StakePoolRelay)]
-> [(PoolStake, NonEmpty StakePoolRelay)]
forall a b. (a -> b) -> a -> b
$ LedgerState blk -> [(PoolStake, NonEmpty StakePoolRelay)]
forall blk.
LedgerSupportsPeerSelection blk =>
LedgerState blk -> [(PoolStake, NonEmpty StakePoolRelay)]
getPeers LedgerState blk
immutableLedger
getPeersFromCurrentLedgerAfterSlot ::
forall m blk addrNTN addrNTC .
( IOLike m
, LedgerSupportsPeerSelection blk
, UpdateLedger blk
)
=> NodeKernel m addrNTN addrNTC blk
-> SlotNo
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
getPeersFromCurrentLedgerAfterSlot :: forall (m :: * -> *) blk addrNTN addrNTC.
(IOLike m, LedgerSupportsPeerSelection blk, UpdateLedger blk) =>
NodeKernel m addrNTN addrNTC blk
-> SlotNo -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
getPeersFromCurrentLedgerAfterSlot NodeKernel m addrNTN addrNTC blk
kernel SlotNo
slotNo =
NodeKernel m addrNTN addrNTC blk
-> (LedgerState blk -> Bool)
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
forall (m :: * -> *) blk addrNTN addrNTC.
(IOLike m, LedgerSupportsPeerSelection blk) =>
NodeKernel m addrNTN addrNTC blk
-> (LedgerState blk -> Bool)
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
getPeersFromCurrentLedger NodeKernel m addrNTN addrNTC blk
kernel LedgerState blk -> Bool
afterSlotNo
where
afterSlotNo :: LedgerState blk -> Bool
afterSlotNo :: LedgerState blk -> Bool
afterSlotNo LedgerState blk
st =
case LedgerState blk -> WithOrigin SlotNo
forall blk.
UpdateLedger blk =>
LedgerState blk -> WithOrigin SlotNo
ledgerTipSlot LedgerState blk
st of
WithOrigin SlotNo
Origin -> Bool
False
NotOrigin SlotNo
tip -> SlotNo
tip SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
slotNo
getImmTipSlot ::
( IOLike m
, UpdateLedger blk
)
=> NodeKernel m addrNTN addrNTC blk
-> STM m (WithOrigin SlotNo)
getImmTipSlot :: forall (m :: * -> *) blk addrNTN addrNTC.
(IOLike m, UpdateLedger blk) =>
NodeKernel m addrNTN addrNTC blk -> STM m (WithOrigin SlotNo)
getImmTipSlot NodeKernel m addrNTN addrNTC blk
kernel =
ExtLedgerState blk -> WithOrigin SlotNo
forall l. GetTip l => l -> WithOrigin SlotNo
getTipSlot
(ExtLedgerState blk -> WithOrigin SlotNo)
-> STM m (ExtLedgerState blk) -> STM m (WithOrigin SlotNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
Monad (STM m) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getImmutableLedger (NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
getChainDB NodeKernel m addrNTN addrNTC blk
kernel)