{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-} module Ouroboros.Network.BlockFetch.ConsensusInterface ( FetchMode (..) , BlockFetchConsensusInterface (..) , WhetherReceivingTentativeBlocks (..) , FromConsensus (..) ) where import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadTime (UTCTime) import Data.Map.Strict (Map) import GHC.Stack (HasCallStack) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block import Ouroboros.Network.SizeInBytes (SizeInBytes) data FetchMode = -- | Use this mode when we are catching up on the chain but are stil -- well behind. In this mode the fetch logic will optimise for -- throughput rather than latency. -- FetchModeBulkSync -- | Use this mode for block-producing nodes that have a known deadline -- to produce a block and need to get the best chain before that. In -- this mode the fetch logic will optimise for picking the best chain -- within the given deadline. | FetchModeDeadline -- TODO: add an additional mode for in-between: when we are a core node -- following the chain but do not have an imminent deadline, or are a -- relay forwarding chains within the network. -- -- This is a mixed mode because we have to combine the distribution of -- time to next block under praos, with the distribution of latency of -- our peers, and also the consensus preference. deriving (FetchMode -> FetchMode -> Bool (FetchMode -> FetchMode -> Bool) -> (FetchMode -> FetchMode -> Bool) -> Eq FetchMode forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a $c== :: FetchMode -> FetchMode -> Bool == :: FetchMode -> FetchMode -> Bool $c/= :: FetchMode -> FetchMode -> Bool /= :: FetchMode -> FetchMode -> Bool Eq, Int -> FetchMode -> ShowS [FetchMode] -> ShowS FetchMode -> String (Int -> FetchMode -> ShowS) -> (FetchMode -> String) -> ([FetchMode] -> ShowS) -> Show FetchMode forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> FetchMode -> ShowS showsPrec :: Int -> FetchMode -> ShowS $cshow :: FetchMode -> String show :: FetchMode -> String $cshowList :: [FetchMode] -> ShowS showList :: [FetchMode] -> ShowS Show) -- | The consensus layer functionality that the block fetch logic requires. -- -- These are provided as input to the block fetch by the consensus layer. -- data BlockFetchConsensusInterface peer header block m = BlockFetchConsensusInterface { -- | Read the K-suffixes of the candidate chains. -- -- Assumptions: -- * Their headers must be already validated. -- * They may contain /fewer/ than @K@ blocks. -- * Their anchor does not have to intersect with the current chain. forall peer header block (m :: * -> *). BlockFetchConsensusInterface peer header block m -> STM m (Map peer (AnchoredFragment header)) readCandidateChains :: STM m (Map peer (AnchoredFragment header)), -- | Read the K-suffix of the current chain. -- -- This must contain info on the last @K@ blocks (unless we're near -- the chain genesis of course). -- forall peer header block (m :: * -> *). BlockFetchConsensusInterface peer header block m -> STM m (AnchoredFragment header) readCurrentChain :: STM m (AnchoredFragment header), -- | Read the current fetch mode that the block fetch logic should use. -- -- The fetch mode is a dynamic part of the block fetch policy. In -- 'FetchModeBulkSync' it follows a policy that optimises for expected -- bandwidth over latency to fetch any particular block, whereas in -- 'FetchModeDeadline' it follows a policy optimises for the latency -- to fetch blocks, at the expense of wasting bandwidth. -- -- This mode should be set so that when the node's current chain is near -- to \"now\" it uses the deadline mode, and when it is far away it uses -- the bulk sync mode. -- forall peer header block (m :: * -> *). BlockFetchConsensusInterface peer header block m -> STM m FetchMode readFetchMode :: STM m FetchMode, -- | Recent, only within last K forall peer header block (m :: * -> *). BlockFetchConsensusInterface peer header block m -> STM m (Point block -> Bool) readFetchedBlocks :: STM m (Point block -> Bool), -- | This method allocates an @addFetchedBlock@ function per client. -- That function and 'readFetchedBlocks' are required to be linked. Upon -- successful completion of @addFetchedBlock@ it must be the case that -- 'readFetchedBlocks' reports the block. forall peer header block (m :: * -> *). BlockFetchConsensusInterface peer header block m -> WhetherReceivingTentativeBlocks -> STM m (Point block -> block -> m ()) mkAddFetchedBlock :: WhetherReceivingTentativeBlocks -> STM m (Point block -> block -> m ()), -- | The highest stored/downloaded slot number. -- -- This is used to optimise the filtering of fragments in the block -- fetch logic: when removing already downloaded blocks from a -- fragment, the filtering (with a linear cost) is stopped as soon as a -- block has a slot number higher than this slot number, as it cannot -- have been downloaded anyway. forall peer header block (m :: * -> *). BlockFetchConsensusInterface peer header block m -> STM m MaxSlotNo readFetchedMaxSlotNo :: STM m MaxSlotNo, -- | Given the current chain, is the given chain plausible as a -- candidate chain. Classically for Ouroboros this would simply -- check if the candidate is strictly longer, but for Ouroboros -- with operational key certificates there are also cases where -- we would consider a chain of equal length to the current chain. -- forall peer header block (m :: * -> *). BlockFetchConsensusInterface peer header block m -> HasCallStack => AnchoredFragment header -> AnchoredFragment header -> Bool plausibleCandidateChain :: HasCallStack => AnchoredFragment header -> AnchoredFragment header -> Bool, -- | Compare two candidate chains and return a preference ordering. -- This is used as part of selecting which chains to prioritise for -- downloading block bodies. -- forall peer header block (m :: * -> *). BlockFetchConsensusInterface peer header block m -> HasCallStack => AnchoredFragment header -> AnchoredFragment header -> Ordering compareCandidateChains :: HasCallStack => AnchoredFragment header -> AnchoredFragment header -> Ordering, -- | Much of the logic for deciding which blocks to download from which -- peer depends on making estimates based on recent performance metrics. -- These estimates of course depend on the amount of data we will be -- downloading. -- forall peer header block (m :: * -> *). BlockFetchConsensusInterface peer header block m -> header -> SizeInBytes blockFetchSize :: header -> SizeInBytes, -- | Given a block header, validate the supposed corresponding block -- body. -- forall peer header block (m :: * -> *). BlockFetchConsensusInterface peer header block m -> header -> block -> Bool blockMatchesHeader :: header -> block -> Bool, -- | Calculate when a header's block was forged. -- -- PRECONDITION: This function will succeed and give a _correct_ result -- when applied to headers obtained via this interface (ie via -- Consensus, ie via 'readCurrentChain' or 'readCandidateChains'). -- -- WARNING: This function may fail or, worse, __give an incorrect result -- (!!)__ if applied to headers obtained from sources outside of this -- interface. The 'FromConsensus' newtype wrapper is intended to make it -- difficult to make that mistake, so please pay that syntactic price -- and consider its meaning at each call to this function. Relatedly, -- preserve that argument wrapper as much as possible when deriving -- ancillary functions\/interfaces from this function. forall peer header block (m :: * -> *). BlockFetchConsensusInterface peer header block m -> FromConsensus header -> STM m UTCTime headerForgeUTCTime :: FromConsensus header -> STM m UTCTime, -- | Calculate when a block was forged. -- -- PRECONDITION: Same as 'headerForgeUTCTime'. -- -- WARNING: Same as 'headerForgeUTCTime'. forall peer header block (m :: * -> *). BlockFetchConsensusInterface peer header block m -> FromConsensus block -> STM m UTCTime blockForgeUTCTime :: FromConsensus block -> STM m UTCTime } -- | Whether the block fetch peer is sending tentative blocks, which are -- understood to possibly be invalid data WhetherReceivingTentativeBlocks = ReceivingTentativeBlocks | NotReceivingTentativeBlocks {------------------------------------------------------------------------------- Syntactic indicator of key precondition about Consensus time conversions -------------------------------------------------------------------------------} -- | A new type used to emphasize the precondition of -- 'Ouroboros.Network.BlockFetch.ConsensusInterface.headerForgeUTCTime' and -- 'Ouroboros.Network.BlockFetch.ConsensusInterface.blockForgeUTCTime' at each -- call site. -- -- At time of writing, the @a@ is either a header or a block. The headers are -- literally from Consensus (ie provided by ChainSync). Blocks, on the other -- hand, are indirectly from Consensus: they were fetched only because we -- favored the corresponding header that Consensus provided. newtype FromConsensus a = FromConsensus {forall a. FromConsensus a -> a unFromConsensus :: a} deriving ((forall a b. (a -> b) -> FromConsensus a -> FromConsensus b) -> (forall a b. a -> FromConsensus b -> FromConsensus a) -> Functor FromConsensus forall a b. a -> FromConsensus b -> FromConsensus a forall a b. (a -> b) -> FromConsensus a -> FromConsensus b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f $cfmap :: forall a b. (a -> b) -> FromConsensus a -> FromConsensus b fmap :: forall a b. (a -> b) -> FromConsensus a -> FromConsensus b $c<$ :: forall a b. a -> FromConsensus b -> FromConsensus a <$ :: forall a b. a -> FromConsensus b -> FromConsensus a Functor) instance Applicative FromConsensus where pure :: forall a. a -> FromConsensus a pure = a -> FromConsensus a forall a. a -> FromConsensus a FromConsensus FromConsensus a -> b f <*> :: forall a b. FromConsensus (a -> b) -> FromConsensus a -> FromConsensus b <*> FromConsensus a a = b -> FromConsensus b forall a. a -> FromConsensus a FromConsensus (a -> b f a a)