{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Ouroboros.Network.BlockFetch
( blockFetchLogic
, BlockFetchConfiguration (..)
, BlockFetchConsensusInterface (..)
, FetchDecision
, TraceFetchClientState (..)
, TraceLabelPeer (..)
, FetchClientRegistry
, newFetchClientRegistry
, bracketFetchClient
, bracketSyncWithFetchClient
, bracketKeepAliveClient
, FetchMode (..)
, FromConsensus (..)
, SizeInBytes
, WhetherReceivingTentativeBlocks (..)
) where
import Data.Hashable (Hashable)
import Data.Map.Strict (Map)
import Data.Void
import GHC.Stack (HasCallStack)
import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadTime
import Control.Monad.Class.MonadTimer
import Control.Tracer (Tracer)
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import Ouroboros.Network.Block
import Ouroboros.Network.DeltaQ (SizeInBytes)
import Ouroboros.Network.BlockFetch.ClientRegistry
(FetchClientPolicy (..), FetchClientRegistry,
bracketFetchClient, bracketKeepAliveClient,
bracketSyncWithFetchClient, newFetchClientRegistry,
readFetchClientsStateVars, readFetchClientsStatus,
readPeerGSVs, setFetchClientContext)
import Ouroboros.Network.BlockFetch.ClientState (FromConsensus (..),
WhetherReceivingTentativeBlocks (..))
import Ouroboros.Network.BlockFetch.State
data BlockFetchConsensusInterface peer header block m =
BlockFetchConsensusInterface {
BlockFetchConsensusInterface peer header block m
-> STM m (Map peer (AnchoredFragment header))
readCandidateChains :: STM m (Map peer (AnchoredFragment header)),
BlockFetchConsensusInterface peer header block m
-> STM m (AnchoredFragment header)
readCurrentChain :: STM m (AnchoredFragment header),
BlockFetchConsensusInterface peer header block m -> STM m FetchMode
readFetchMode :: STM m FetchMode,
BlockFetchConsensusInterface peer header block m
-> STM m (Point block -> Bool)
readFetchedBlocks :: STM m (Point block -> Bool),
BlockFetchConsensusInterface peer header block m
-> WhetherReceivingTentativeBlocks
-> STM m (Point block -> block -> m ())
mkAddFetchedBlock :: WhetherReceivingTentativeBlocks
-> STM m (Point block -> block -> m ()),
BlockFetchConsensusInterface peer header block m -> STM m MaxSlotNo
readFetchedMaxSlotNo :: STM m MaxSlotNo,
BlockFetchConsensusInterface peer header block m
-> HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Bool
plausibleCandidateChain :: HasCallStack
=> AnchoredFragment header
-> AnchoredFragment header -> Bool,
BlockFetchConsensusInterface peer header block m
-> HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Ordering
compareCandidateChains :: HasCallStack
=> AnchoredFragment header
-> AnchoredFragment header
-> Ordering,
BlockFetchConsensusInterface peer header block m
-> header -> SizeInBytes
blockFetchSize :: header -> SizeInBytes,
:: header -> block -> Bool,
:: FromConsensus header -> STM m UTCTime,
BlockFetchConsensusInterface peer header block m
-> FromConsensus block -> STM m UTCTime
blockForgeUTCTime :: FromConsensus block -> STM m UTCTime
}
data BlockFetchConfiguration =
BlockFetchConfiguration {
BlockFetchConfiguration -> Word
bfcMaxConcurrencyBulkSync :: !Word,
BlockFetchConfiguration -> Word
bfcMaxConcurrencyDeadline :: !Word,
BlockFetchConfiguration -> Word
bfcMaxRequestsInflight :: !Word,
BlockFetchConfiguration -> DiffTime
bfcDecisionLoopInterval :: !DiffTime,
BlockFetchConfiguration -> Int
bfcSalt :: !Int
}
blockFetchLogic :: forall peer header block m.
( HasHeader header
, HasHeader block
, HeaderHash header ~ HeaderHash block
, MonadDelay m
, MonadMonotonicTime m
, MonadSTM m
, Ord peer
, Hashable peer
)
=> Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
-> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> BlockFetchConsensusInterface peer header block m
-> FetchClientRegistry peer header block m
-> BlockFetchConfiguration
-> m Void
blockFetchLogic :: Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
-> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> BlockFetchConsensusInterface peer header block m
-> FetchClientRegistry peer header block m
-> BlockFetchConfiguration
-> m Void
blockFetchLogic Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
decisionTracer Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
clientStateTracer
BlockFetchConsensusInterface{STM m (Map peer (AnchoredFragment header))
STM m (AnchoredFragment header)
STM m MaxSlotNo
STM m FetchMode
STM m (Point block -> Bool)
header -> SizeInBytes
header -> block -> Bool
HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Bool
HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Ordering
FromConsensus header -> STM m UTCTime
FromConsensus block -> STM m UTCTime
WhetherReceivingTentativeBlocks
-> STM m (Point block -> block -> m ())
blockForgeUTCTime :: FromConsensus block -> STM m UTCTime
headerForgeUTCTime :: FromConsensus header -> STM m UTCTime
blockMatchesHeader :: header -> block -> Bool
blockFetchSize :: header -> SizeInBytes
compareCandidateChains :: HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Ordering
plausibleCandidateChain :: HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Bool
readFetchedMaxSlotNo :: STM m MaxSlotNo
mkAddFetchedBlock :: WhetherReceivingTentativeBlocks
-> STM m (Point block -> block -> m ())
readFetchedBlocks :: STM m (Point block -> Bool)
readFetchMode :: STM m FetchMode
readCurrentChain :: STM m (AnchoredFragment header)
readCandidateChains :: STM m (Map peer (AnchoredFragment header))
blockForgeUTCTime :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> FromConsensus block -> STM m UTCTime
headerForgeUTCTime :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> FromConsensus header -> STM m UTCTime
blockMatchesHeader :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> header -> block -> Bool
blockFetchSize :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> header -> SizeInBytes
compareCandidateChains :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Ordering
plausibleCandidateChain :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Bool
readFetchedMaxSlotNo :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m -> STM m MaxSlotNo
mkAddFetchedBlock :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> WhetherReceivingTentativeBlocks
-> STM m (Point block -> block -> m ())
readFetchedBlocks :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> STM m (Point block -> Bool)
readFetchMode :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m -> STM m FetchMode
readCurrentChain :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> STM m (AnchoredFragment header)
readCandidateChains :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> STM m (Map peer (AnchoredFragment header))
..}
FetchClientRegistry peer header block m
registry
BlockFetchConfiguration{Int
Word
DiffTime
bfcSalt :: Int
bfcDecisionLoopInterval :: DiffTime
bfcMaxRequestsInflight :: Word
bfcMaxConcurrencyDeadline :: Word
bfcMaxConcurrencyBulkSync :: Word
bfcSalt :: BlockFetchConfiguration -> Int
bfcDecisionLoopInterval :: BlockFetchConfiguration -> DiffTime
bfcMaxRequestsInflight :: BlockFetchConfiguration -> Word
bfcMaxConcurrencyDeadline :: BlockFetchConfiguration -> Word
bfcMaxConcurrencyBulkSync :: BlockFetchConfiguration -> Word
..} = do
FetchClientRegistry peer header block m
-> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> (WhetherReceivingTentativeBlocks
-> STM m (FetchClientPolicy header block m))
-> m ()
forall (m :: * -> *) peer header block.
MonadSTM m =>
FetchClientRegistry peer header block m
-> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> (WhetherReceivingTentativeBlocks
-> STM m (FetchClientPolicy header block m))
-> m ()
setFetchClientContext FetchClientRegistry peer header block m
registry Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
clientStateTracer WhetherReceivingTentativeBlocks
-> STM m (FetchClientPolicy header block m)
mkFetchClientPolicy
Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
-> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> FetchDecisionPolicy header
-> FetchTriggerVariables peer header m
-> FetchNonTriggerVariables peer header block m
-> m Void
forall header block (m :: * -> *) peer.
(HasHeader header, HasHeader block,
HeaderHash header ~ HeaderHash block, MonadDelay m,
MonadMonotonicTime m, MonadSTM m, Ord peer, Hashable peer) =>
Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
-> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> FetchDecisionPolicy header
-> FetchTriggerVariables peer header m
-> FetchNonTriggerVariables peer header block m
-> m Void
fetchLogicIterations
Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
decisionTracer Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
clientStateTracer
FetchDecisionPolicy header
fetchDecisionPolicy
FetchTriggerVariables peer header m
fetchTriggerVariables
FetchNonTriggerVariables peer header block m
fetchNonTriggerVariables
where
mkFetchClientPolicy :: WhetherReceivingTentativeBlocks -> STM m (FetchClientPolicy header block m)
mkFetchClientPolicy :: WhetherReceivingTentativeBlocks
-> STM m (FetchClientPolicy header block m)
mkFetchClientPolicy WhetherReceivingTentativeBlocks
receivingTentativeBlocks = do
Point block -> block -> m ()
addFetchedBlock <- WhetherReceivingTentativeBlocks
-> STM m (Point block -> block -> m ())
mkAddFetchedBlock WhetherReceivingTentativeBlocks
receivingTentativeBlocks
FetchClientPolicy header block m
-> STM m (FetchClientPolicy header block m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure FetchClientPolicy :: forall header block (m :: * -> *).
(header -> SizeInBytes)
-> (header -> block -> Bool)
-> (Point block -> block -> m ())
-> (FromConsensus block -> STM m UTCTime)
-> FetchClientPolicy header block m
FetchClientPolicy {
header -> SizeInBytes
blockFetchSize :: header -> SizeInBytes
blockFetchSize :: header -> SizeInBytes
blockFetchSize,
header -> block -> Bool
blockMatchesHeader :: header -> block -> Bool
blockMatchesHeader :: header -> block -> Bool
blockMatchesHeader,
Point block -> block -> m ()
addFetchedBlock :: Point block -> block -> m ()
addFetchedBlock :: Point block -> block -> m ()
addFetchedBlock,
FromConsensus block -> STM m UTCTime
blockForgeUTCTime :: FromConsensus block -> STM m UTCTime
blockForgeUTCTime :: FromConsensus block -> STM m UTCTime
blockForgeUTCTime
}
fetchDecisionPolicy :: FetchDecisionPolicy header
fetchDecisionPolicy :: FetchDecisionPolicy header
fetchDecisionPolicy =
FetchDecisionPolicy :: forall header.
Word
-> Word
-> Word
-> DiffTime
-> Int
-> (HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Bool)
-> (HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Ordering)
-> (header -> SizeInBytes)
-> FetchDecisionPolicy header
FetchDecisionPolicy {
maxInFlightReqsPerPeer :: Word
maxInFlightReqsPerPeer = Word
bfcMaxRequestsInflight,
maxConcurrencyBulkSync :: Word
maxConcurrencyBulkSync = Word
bfcMaxConcurrencyBulkSync,
maxConcurrencyDeadline :: Word
maxConcurrencyDeadline = Word
bfcMaxConcurrencyDeadline,
decisionLoopInterval :: DiffTime
decisionLoopInterval = DiffTime
bfcDecisionLoopInterval,
peerSalt :: Int
peerSalt = Int
bfcSalt,
HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Bool
plausibleCandidateChain :: HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Bool
plausibleCandidateChain :: HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Bool
plausibleCandidateChain,
HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Ordering
compareCandidateChains :: HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Ordering
compareCandidateChains :: HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Ordering
compareCandidateChains,
header -> SizeInBytes
blockFetchSize :: header -> SizeInBytes
blockFetchSize :: header -> SizeInBytes
blockFetchSize
}
fetchTriggerVariables :: FetchTriggerVariables peer header m
fetchTriggerVariables :: FetchTriggerVariables peer header m
fetchTriggerVariables =
FetchTriggerVariables :: forall peer header (m :: * -> *).
STM m (AnchoredFragment header)
-> STM m (Map peer (AnchoredFragment header))
-> STM m (Map peer (PeerFetchStatus header))
-> FetchTriggerVariables peer header m
FetchTriggerVariables {
readStateCurrentChain :: STM m (AnchoredFragment header)
readStateCurrentChain = STM m (AnchoredFragment header)
readCurrentChain,
readStateCandidateChains :: STM m (Map peer (AnchoredFragment header))
readStateCandidateChains = STM m (Map peer (AnchoredFragment header))
readCandidateChains,
readStatePeerStatus :: STM m (Map peer (PeerFetchStatus header))
readStatePeerStatus = FetchClientRegistry peer header block m
-> STM m (Map peer (PeerFetchStatus header))
forall (m :: * -> *) peer header block.
MonadSTM m =>
FetchClientRegistry peer header block m
-> STM m (Map peer (PeerFetchStatus header))
readFetchClientsStatus FetchClientRegistry peer header block m
registry
}
fetchNonTriggerVariables :: FetchNonTriggerVariables peer header block m
fetchNonTriggerVariables :: FetchNonTriggerVariables peer header block m
fetchNonTriggerVariables =
FetchNonTriggerVariables :: forall peer header block (m :: * -> *).
STM m (Point block -> Bool)
-> STM m (Map peer (FetchClientStateVars m header))
-> STM m (Map peer PeerGSV)
-> STM m FetchMode
-> STM m MaxSlotNo
-> FetchNonTriggerVariables peer header block m
FetchNonTriggerVariables {
readStateFetchedBlocks :: STM m (Point block -> Bool)
readStateFetchedBlocks = STM m (Point block -> Bool)
readFetchedBlocks,
readStatePeerStateVars :: STM m (Map peer (FetchClientStateVars m header))
readStatePeerStateVars = FetchClientRegistry peer header block m
-> STM m (Map peer (FetchClientStateVars m header))
forall (m :: * -> *) peer header block.
MonadSTM m =>
FetchClientRegistry peer header block m
-> STM m (Map peer (FetchClientStateVars m header))
readFetchClientsStateVars FetchClientRegistry peer header block m
registry,
readStatePeerGSVs :: STM m (Map peer PeerGSV)
readStatePeerGSVs = FetchClientRegistry peer header block m -> STM m (Map peer PeerGSV)
forall (m :: * -> *) peer header block.
MonadSTM m =>
FetchClientRegistry peer header block m -> STM m (Map peer PeerGSV)
readPeerGSVs FetchClientRegistry peer header block m
registry,
readStateFetchMode :: STM m FetchMode
readStateFetchMode = STM m FetchMode
readFetchMode,
readStateFetchedMaxSlotNo :: STM m MaxSlotNo
readStateFetchedMaxSlotNo = STM m MaxSlotNo
readFetchedMaxSlotNo
}