{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-strictness #-} -- NOTE: With @-fstrictness@ optimisation (enabled by default for -O1), we get -- an unexplained thunk in 'KnownIntersectionState' and thus a space leak. See -- #1356. module Ouroboros.Consensus.MiniProtocol.ChainSync.Client ( ChainDbView (..) , ChainSyncClientException (..) , ChainSyncClientResult (..) , Consensus , Our (..) , Their (..) , bracketChainSyncClient , chainSyncClient , defaultChainDbView -- * Trace events , InvalidBlockReason , TraceChainSyncClientEvent (..) ) where import Control.Monad import Control.Monad.Except import Control.Tracer import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy import Data.Typeable import Data.Word (Word64) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Network.TypedProtocol.Pipelined import NoThunks.Class (unsafeNoThunks) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Forecast import Ouroboros.Consensus.HeaderStateHistory (HeaderStateHistory (..), validateHeader) import qualified Ouroboros.Consensus.HeaderStateHistory as HeaderStateHistory import Ouroboros.Consensus.HeaderValidation hiding (validateHeader) import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB (ChainDB, InvalidBlockReason) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.Assert (assertWithMsg) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.STM (Fingerprint, Watcher (..), WithFingerprint (..), withWatcher) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq (..)) import qualified Ouroboros.Network.AnchoredFragment as AF import qualified Ouroboros.Network.AnchoredSeq as AS import Ouroboros.Network.Block (Tip, getTipBlockNo) import Ouroboros.Network.BlockFetch.ConsensusInterface (WhetherReceivingTentativeBlocks (..)) import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM) import Ouroboros.Network.NodeToNode.Version (isPipeliningEnabled) import Ouroboros.Network.PeerSelection.PeerMetric.Type (HeaderMetricsTracer) import Ouroboros.Network.Protocol.ChainSync.ClientPipelined import Ouroboros.Network.Protocol.ChainSync.PipelineDecision type Consensus (client :: Type -> Type -> Type -> (Type -> Type) -> Type -> Type) blk m = client (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -- | Abstract over the ChainDB data ChainDbView m blk = ChainDbView { ChainDbView m blk -> STM m (AnchoredFragment (Header blk)) getCurrentChain :: STM m (AnchoredFragment (Header blk)) , ChainDbView m blk -> STM m (HeaderStateHistory blk) getHeaderStateHistory :: STM m (HeaderStateHistory blk) , ChainDbView m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk)) getPastLedger :: Point blk -> STM m (Maybe (ExtLedgerState blk)) , ChainDbView m blk -> STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) getIsInvalidBlock :: STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) } defaultChainDbView :: (IOLike m, LedgerSupportsProtocol blk) => ChainDB m blk -> ChainDbView m blk defaultChainDbView :: ChainDB m blk -> ChainDbView m blk defaultChainDbView ChainDB m blk chainDB = ChainDbView :: forall (m :: * -> *) blk. STM m (AnchoredFragment (Header blk)) -> STM m (HeaderStateHistory blk) -> (Point blk -> STM m (Maybe (ExtLedgerState blk))) -> STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) -> ChainDbView m blk ChainDbView { $sel:getCurrentChain:ChainDbView :: STM m (AnchoredFragment (Header blk)) getCurrentChain = 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 , $sel:getHeaderStateHistory:ChainDbView :: STM m (HeaderStateHistory blk) getHeaderStateHistory = ChainDB m blk -> STM m (HeaderStateHistory blk) forall (m :: * -> *) blk. Monad (STM m) => ChainDB m blk -> STM m (HeaderStateHistory blk) ChainDB.getHeaderStateHistory ChainDB m blk chainDB , $sel:getPastLedger:ChainDbView :: Point blk -> STM m (Maybe (ExtLedgerState blk)) getPastLedger = 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 , $sel:getIsInvalidBlock:ChainDbView :: STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) getIsInvalidBlock = 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 } -- newtype wrappers to avoid confusing our tip with their tip. newtype Their a = Their { Their a -> a unTheir :: a } deriving stock (Their a -> Their a -> Bool (Their a -> Their a -> Bool) -> (Their a -> Their a -> Bool) -> Eq (Their a) forall a. Eq a => Their a -> Their a -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Their a -> Their a -> Bool $c/= :: forall a. Eq a => Their a -> Their a -> Bool == :: Their a -> Their a -> Bool $c== :: forall a. Eq a => Their a -> Their a -> Bool Eq) deriving newtype (Int -> Their a -> ShowS [Their a] -> ShowS Their a -> String (Int -> Their a -> ShowS) -> (Their a -> String) -> ([Their a] -> ShowS) -> Show (Their a) forall a. Show a => Int -> Their a -> ShowS forall a. Show a => [Their a] -> ShowS forall a. Show a => Their a -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Their a] -> ShowS $cshowList :: forall a. Show a => [Their a] -> ShowS show :: Their a -> String $cshow :: forall a. Show a => Their a -> String showsPrec :: Int -> Their a -> ShowS $cshowsPrec :: forall a. Show a => Int -> Their a -> ShowS Show, Context -> Their a -> IO (Maybe ThunkInfo) Proxy (Their a) -> String (Context -> Their a -> IO (Maybe ThunkInfo)) -> (Context -> Their a -> IO (Maybe ThunkInfo)) -> (Proxy (Their a) -> String) -> NoThunks (Their a) forall a. NoThunks a => Context -> Their a -> IO (Maybe ThunkInfo) forall a. NoThunks a => Proxy (Their a) -> String forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a showTypeOf :: Proxy (Their a) -> String $cshowTypeOf :: forall a. NoThunks a => Proxy (Their a) -> String wNoThunks :: Context -> Their a -> IO (Maybe ThunkInfo) $cwNoThunks :: forall a. NoThunks a => Context -> Their a -> IO (Maybe ThunkInfo) noThunks :: Context -> Their a -> IO (Maybe ThunkInfo) $cnoThunks :: forall a. NoThunks a => Context -> Their a -> IO (Maybe ThunkInfo) NoThunks) newtype Our a = Our { Our a -> a unOur :: a } deriving stock (Our a -> Our a -> Bool (Our a -> Our a -> Bool) -> (Our a -> Our a -> Bool) -> Eq (Our a) forall a. Eq a => Our a -> Our a -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Our a -> Our a -> Bool $c/= :: forall a. Eq a => Our a -> Our a -> Bool == :: Our a -> Our a -> Bool $c== :: forall a. Eq a => Our a -> Our a -> Bool Eq) deriving newtype (Int -> Our a -> ShowS [Our a] -> ShowS Our a -> String (Int -> Our a -> ShowS) -> (Our a -> String) -> ([Our a] -> ShowS) -> Show (Our a) forall a. Show a => Int -> Our a -> ShowS forall a. Show a => [Our a] -> ShowS forall a. Show a => Our a -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Our a] -> ShowS $cshowList :: forall a. Show a => [Our a] -> ShowS show :: Our a -> String $cshow :: forall a. Show a => Our a -> String showsPrec :: Int -> Our a -> ShowS $cshowsPrec :: forall a. Show a => Int -> Our a -> ShowS Show, Context -> Our a -> IO (Maybe ThunkInfo) Proxy (Our a) -> String (Context -> Our a -> IO (Maybe ThunkInfo)) -> (Context -> Our a -> IO (Maybe ThunkInfo)) -> (Proxy (Our a) -> String) -> NoThunks (Our a) forall a. NoThunks a => Context -> Our a -> IO (Maybe ThunkInfo) forall a. NoThunks a => Proxy (Our a) -> String forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a showTypeOf :: Proxy (Our a) -> String $cshowTypeOf :: forall a. NoThunks a => Proxy (Our a) -> String wNoThunks :: Context -> Our a -> IO (Maybe ThunkInfo) $cwNoThunks :: forall a. NoThunks a => Context -> Our a -> IO (Maybe ThunkInfo) noThunks :: Context -> Our a -> IO (Maybe ThunkInfo) $cnoThunks :: forall a. NoThunks a => Context -> Our a -> IO (Maybe ThunkInfo) NoThunks) bracketChainSyncClient :: ( IOLike m , Ord peer , LedgerSupportsProtocol blk ) => Tracer m (TraceChainSyncClientEvent blk) -> ChainDbView m blk -> StrictTVar m (Map peer (StrictTVar m (AnchoredFragment (Header blk)))) -- ^ The candidate chains, we need the whole map because we -- (de)register nodes (@peer@). -> peer -> NodeToNodeVersion -> ( StrictTVar m (AnchoredFragment (Header blk)) -> m a ) -> m a bracketChainSyncClient :: Tracer m (TraceChainSyncClientEvent blk) -> ChainDbView m blk -> StrictTVar m (Map peer (StrictTVar m (AnchoredFragment (Header blk)))) -> peer -> NodeToNodeVersion -> (StrictTVar m (AnchoredFragment (Header blk)) -> m a) -> m a bracketChainSyncClient Tracer m (TraceChainSyncClientEvent blk) tracer ChainDbView { STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) getIsInvalidBlock :: STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) $sel:getIsInvalidBlock:ChainDbView :: forall (m :: * -> *) blk. ChainDbView m blk -> STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) getIsInvalidBlock } StrictTVar m (Map peer (StrictTVar m (AnchoredFragment (Header blk)))) varCandidates peer peer NodeToNodeVersion version StrictTVar m (AnchoredFragment (Header blk)) -> m a body = m (StrictTVar m (AnchoredFragment (Header blk))) -> (StrictTVar m (AnchoredFragment (Header blk)) -> m ()) -> (StrictTVar m (AnchoredFragment (Header blk)) -> m a) -> m a forall (m :: * -> *) a b c. MonadThrow m => m a -> (a -> m b) -> (a -> m c) -> m c bracket m (StrictTVar m (AnchoredFragment (Header blk))) newCandidateVar StrictTVar m (AnchoredFragment (Header blk)) -> m () releaseCandidateVar ((StrictTVar m (AnchoredFragment (Header blk)) -> m a) -> m a) -> (StrictTVar m (AnchoredFragment (Header blk)) -> m a) -> m a forall a b. (a -> b) -> a -> b $ \StrictTVar m (AnchoredFragment (Header blk)) varCandidate -> String -> Watcher m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) Fingerprint -> m a -> m a forall (m :: * -> *) a fp r. (IOLike m, Eq fp, HasCallStack) => String -> Watcher m a fp -> m r -> m r withWatcher String "ChainSync.Client.rejectInvalidBlocks" (StrictTVar m (AnchoredFragment (Header blk)) -> Watcher m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) Fingerprint invalidBlockWatcher StrictTVar m (AnchoredFragment (Header blk)) varCandidate) (m a -> m a) -> m a -> m a forall a b. (a -> b) -> a -> b $ StrictTVar m (AnchoredFragment (Header blk)) -> m a body StrictTVar m (AnchoredFragment (Header blk)) varCandidate where newCandidateVar :: m (StrictTVar m (AnchoredFragment (Header blk))) newCandidateVar = do StrictTVar m (AnchoredFragment (Header blk)) varCandidate <- AnchoredFragment (Header blk) -> m (StrictTVar m (AnchoredFragment (Header blk))) forall (m :: * -> *) a. (MonadSTM m, HasCallStack, NoThunks a) => a -> m (StrictTVar m a) newTVarIO (AnchoredFragment (Header blk) -> m (StrictTVar m (AnchoredFragment (Header blk)))) -> AnchoredFragment (Header blk) -> m (StrictTVar m (AnchoredFragment (Header blk))) forall a b. (a -> b) -> a -> b $ Anchor (Header blk) -> AnchoredFragment (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 () -> m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m () -> m ()) -> STM m () -> m () forall a b. (a -> b) -> a -> b $ StrictTVar m (Map peer (StrictTVar m (AnchoredFragment (Header blk)))) -> (Map peer (StrictTVar m (AnchoredFragment (Header blk))) -> Map peer (StrictTVar m (AnchoredFragment (Header blk)))) -> STM m () forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> (a -> a) -> STM m () modifyTVar StrictTVar m (Map peer (StrictTVar m (AnchoredFragment (Header blk)))) varCandidates ((Map peer (StrictTVar m (AnchoredFragment (Header blk))) -> Map peer (StrictTVar m (AnchoredFragment (Header blk)))) -> STM m ()) -> (Map peer (StrictTVar m (AnchoredFragment (Header blk))) -> Map peer (StrictTVar m (AnchoredFragment (Header blk)))) -> STM m () forall a b. (a -> b) -> a -> b $ peer -> StrictTVar m (AnchoredFragment (Header blk)) -> Map peer (StrictTVar m (AnchoredFragment (Header blk))) -> Map peer (StrictTVar m (AnchoredFragment (Header blk))) forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert peer peer StrictTVar m (AnchoredFragment (Header blk)) varCandidate StrictTVar m (AnchoredFragment (Header blk)) -> m (StrictTVar m (AnchoredFragment (Header blk))) forall (m :: * -> *) a. Monad m => a -> m a return StrictTVar m (AnchoredFragment (Header blk)) varCandidate releaseCandidateVar :: StrictTVar m (AnchoredFragment (Header blk)) -> m () releaseCandidateVar StrictTVar m (AnchoredFragment (Header blk)) _ = do STM m () -> m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m () -> m ()) -> STM m () -> m () forall a b. (a -> b) -> a -> b $ StrictTVar m (Map peer (StrictTVar m (AnchoredFragment (Header blk)))) -> (Map peer (StrictTVar m (AnchoredFragment (Header blk))) -> Map peer (StrictTVar m (AnchoredFragment (Header blk)))) -> STM m () forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> (a -> a) -> STM m () modifyTVar StrictTVar m (Map peer (StrictTVar m (AnchoredFragment (Header blk)))) varCandidates ((Map peer (StrictTVar m (AnchoredFragment (Header blk))) -> Map peer (StrictTVar m (AnchoredFragment (Header blk)))) -> STM m ()) -> (Map peer (StrictTVar m (AnchoredFragment (Header blk))) -> Map peer (StrictTVar m (AnchoredFragment (Header blk)))) -> STM m () forall a b. (a -> b) -> a -> b $ peer -> Map peer (StrictTVar m (AnchoredFragment (Header blk))) -> Map peer (StrictTVar m (AnchoredFragment (Header blk))) forall k a. Ord k => k -> Map k a -> Map k a Map.delete peer peer invalidBlockWatcher :: StrictTVar m (AnchoredFragment (Header blk)) -> Watcher m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) Fingerprint invalidBlockWatcher StrictTVar m (AnchoredFragment (Header blk)) varCandidate = Tracer m (TraceChainSyncClientEvent blk) -> NodeToNodeVersion -> STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) -> STM m (AnchoredFragment (Header blk)) -> Watcher m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) Fingerprint forall (m :: * -> *) blk. (IOLike m, LedgerSupportsProtocol blk) => Tracer m (TraceChainSyncClientEvent blk) -> NodeToNodeVersion -> STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) -> STM m (AnchoredFragment (Header blk)) -> Watcher m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) Fingerprint invalidBlockRejector Tracer m (TraceChainSyncClientEvent blk) tracer NodeToNodeVersion version STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) getIsInvalidBlock (StrictTVar m (AnchoredFragment (Header blk)) -> STM m (AnchoredFragment (Header blk)) forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a readTVar StrictTVar m (AnchoredFragment (Header blk)) varCandidate) -- Our task: after connecting to an upstream node, try to maintain an -- up-to-date header-only fragment representing their chain. We maintain -- such candidate chains in a map with upstream nodes as keys. -- -- The block fetch logic will use these candidate chains to download -- blocks from, prioritising certain candidate chains over others using -- the consensus protocol. Whenever such a block has been downloaded and -- added to the local 'ChainDB', the 'ChainDB' will perform chain -- selection. -- -- We also validate the headers of a candidate chain by advancing the -- 'ChainDepState' with the headers, which returns an error when validation -- failed. Thus, in addition to the chain fragment of each candidate, we also -- store a 'ChainDepState' corresponding to the head of the candidate chain. -- -- We must keep the candidate chain synchronised with the corresponding -- upstream chain. The upstream node's chain might roll forward or -- backwards, and they will inform us about this. When we get these -- messages, we will replicate these actions on our candidate chain. -- -- INVARIANT: -- -- > our tip -- > v -- > /--* .... * -- > | -- > --* -- > | -- > \--* .... * -- > fragment tip -- -- The distance from our tip to the intersection between our chain and the -- fragment maintained for the upstream node cannot exceed @k@ blocks. When -- this invariant cannot be maintained, the upstream node is on a fork that -- is too distant and we should disconnect. -- -- TODO #423 rate-limit switching chains, otherwise we can't place blame (we -- don't know which candidate's chain included the point that was -- poisoned). E.g. two rollbacks per time slot -> make it configurable -> -- just a simple argument for now. -- -- TODO #467 if the 'theirTip' that they sent us is on our chain, just -- switch to it. -- = Candidate fragment size -- ------------------------- -- -- The size of the downloaded candidate fragment ('theirFrag') and the -- corresponding header state history ('theirHeaderStateHistory', which has the -- same size as 'theirFrag') is limited by how far in the future the ledger view -- can forecast. -- -- For PBFT (Byron), we can forecast up to @2k@ slots ahead. Assuming a chain -- density of 100%, this means the look-ahead is @2k@ headers. For mainnet this -- means @2 * 2160 = 4320@ headers. -- -- For TPraos (Shelley), we can forecast up to @3k/f@ slots ahead. Assuming a -- density of @f@, this means the look-ahead is @3k@ headers. For mainnet, this -- means @3 * 2160 = 6480@ headers. -- -- The figure below shows the relation between 'ourFrag' and 'theirFrag': -- -- > k headers or less, when A is genesis -- > <---------------------> -- > anchor header tip -- > | | | -- > V V V -- > 'ourFrag': A-H-H-H-H-H-H-H-H-...-H -- > \ -- > 'theirFrag': H-H-H-H-... ... ... -- > ^ -- > | -- > most recent intersection (between A and the tip) -- -- Note that the 'ourFrag' and 'theirFrag' share anchors /at all times/. In the -- figure above, the first three headers on 'ourFrag' are thus also on -- 'theirFrag'. The further away the most recent intersection is from the anchor -- point, the more headers 'theirFrag' and 'ourFrag' will have in common. -- -- In the \"worst\" case 'theirFrag' has the following length: -- -- > k -- > <---------------------> -- > 'ourFrag': A-H-H-H-H-H-H-H-H-...-H -- > \ -- > 'theirFrag': H-H-H-H-H-H-H-H-H-H-H-H-H-H-H...-H -- > <--------------------------------> -- > max look-ahead -- > max length <-------------------------------------------------------> -- > of 'theirFrag' k + max look-ahead -- -- For PBFT this is @2160 + 4320 = 6480@ headers, for TPraos this is @2160 + -- 6480 = 8640@ headers. The header state history will have the same length. -- -- This worst case can happen when: -- * We are more than 6480 or respectively 8640 blocks behind, bulk syncing, and -- the BlockFetch client and/or the ChainDB can't keep up with the ChainSync -- client. -- * When our clock is running behind such that we are not adopting the -- corresponding blocks because we think they are from the future. -- * When an attacker is serving us headers from the future. -- -- When we are in sync with the network, the fragment will typically be @k@ to -- @k + 1@ headers long. -- | State used when the intersection between the candidate and the current -- chain is unknown. data UnknownIntersectionState blk = UnknownIntersectionState { UnknownIntersectionState blk -> AnchoredFragment (Header blk) ourFrag :: !(AnchoredFragment (Header blk)) -- ^ A view of the current chain fragment. Note that this might be -- temporarily out of date w.r.t. the actual current chain until we update -- it again. -- -- This fragment is used to select points from to find an intersection -- with the candidate. -- -- INVARIANT: 'ourFrag' contains @k@ headers, unless close to genesis. , UnknownIntersectionState blk -> HeaderStateHistory blk ourHeaderStateHistory :: !(HeaderStateHistory blk) -- ^ 'HeaderStateHistory' corresponding to the tip (most recent block) of -- 'ourFrag'. } deriving ((forall x. UnknownIntersectionState blk -> Rep (UnknownIntersectionState blk) x) -> (forall x. Rep (UnknownIntersectionState blk) x -> UnknownIntersectionState blk) -> Generic (UnknownIntersectionState blk) forall x. Rep (UnknownIntersectionState blk) x -> UnknownIntersectionState blk forall x. UnknownIntersectionState blk -> Rep (UnknownIntersectionState blk) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall blk x. Rep (UnknownIntersectionState blk) x -> UnknownIntersectionState blk forall blk x. UnknownIntersectionState blk -> Rep (UnknownIntersectionState blk) x $cto :: forall blk x. Rep (UnknownIntersectionState blk) x -> UnknownIntersectionState blk $cfrom :: forall blk x. UnknownIntersectionState blk -> Rep (UnknownIntersectionState blk) x Generic) instance ( LedgerSupportsProtocol blk ) => NoThunks (UnknownIntersectionState blk) where showTypeOf :: Proxy (UnknownIntersectionState blk) -> String showTypeOf Proxy (UnknownIntersectionState blk) _ = TypeRep -> String forall a. Show a => a -> String show (TypeRep -> String) -> TypeRep -> String forall a b. (a -> b) -> a -> b $ Proxy (UnknownIntersectionState blk) -> TypeRep forall k (proxy :: k -> *) (a :: k). Typeable a => proxy a -> TypeRep typeRep (Proxy (UnknownIntersectionState blk) forall k (t :: k). Proxy t Proxy @(UnknownIntersectionState blk)) -- | State used when the intersection between the candidate and the current -- chain is known. data KnownIntersectionState blk = KnownIntersectionState { KnownIntersectionState blk -> AnchoredFragment (Header blk) theirFrag :: !(AnchoredFragment (Header blk)) -- ^ The candidate, the synched fragment of their chain. -- -- See the \"Candidate fragment size\" note above. , KnownIntersectionState blk -> HeaderStateHistory blk theirHeaderStateHistory :: !(HeaderStateHistory blk) -- ^ 'HeaderStateHistory' corresponding to the tip (most recent block) of -- 'theirFrag'. -- -- INVARIANT: the tips in 'theirHeaderStateHistory' correspond to the -- headers in 'theirFrag', including the anchor. -- -- See the \"Candidate fragment size\" note above. , KnownIntersectionState blk -> AnchoredFragment (Header blk) ourFrag :: !(AnchoredFragment (Header blk)) -- ^ A view of the current chain fragment used to maintain the invariants -- with. Note that this might be temporarily out of date w.r.t. the actual -- current chain until we update it again. -- -- INVARIANT: 'ourFrag' contains @k@ headers, unless close to genesis. -- -- INVARIANT: 'theirFrag' and 'ourFrag' have the same anchor point. From -- this follows that both fragments intersect. This also means that -- 'theirFrag' forks off within the last @k@ headers/blocks of the -- 'ourFrag'. , KnownIntersectionState blk -> Point blk mostRecentIntersection :: !(Point blk) -- ^ The most recent intersection point between 'theirFrag' and 'ourFrag'. -- Note that this is not necessarily the anchor point of both 'theirFrag' -- and 'ourFrag', they might have many more headers in common. -- -- INVARIANT: -- > Just 'mostRecentIntersection' == 'AF.intersectionPoint' 'theirFrag' 'ourFrag' -- -- It follows from the invariants on 'ourFrag' that this point is within -- the last @k@ headers of the current chain fragment, at time of -- computing the 'KnownIntersectionState'. } deriving ((forall x. KnownIntersectionState blk -> Rep (KnownIntersectionState blk) x) -> (forall x. Rep (KnownIntersectionState blk) x -> KnownIntersectionState blk) -> Generic (KnownIntersectionState blk) forall x. Rep (KnownIntersectionState blk) x -> KnownIntersectionState blk forall x. KnownIntersectionState blk -> Rep (KnownIntersectionState blk) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall blk x. Rep (KnownIntersectionState blk) x -> KnownIntersectionState blk forall blk x. KnownIntersectionState blk -> Rep (KnownIntersectionState blk) x $cto :: forall blk x. Rep (KnownIntersectionState blk) x -> KnownIntersectionState blk $cfrom :: forall blk x. KnownIntersectionState blk -> Rep (KnownIntersectionState blk) x Generic) instance ( LedgerSupportsProtocol blk ) => NoThunks (KnownIntersectionState blk) where showTypeOf :: Proxy (KnownIntersectionState blk) -> String showTypeOf Proxy (KnownIntersectionState blk) _ = TypeRep -> String forall a. Show a => a -> String show (TypeRep -> String) -> TypeRep -> String forall a b. (a -> b) -> a -> b $ Proxy (KnownIntersectionState blk) -> TypeRep forall k (proxy :: k -> *) (a :: k). Typeable a => proxy a -> TypeRep typeRep (Proxy (KnownIntersectionState blk) forall k (t :: k). Proxy t Proxy @(KnownIntersectionState blk)) checkKnownIntersectionInvariants :: ( HasHeader blk , HasHeader (Header blk) , HasAnnTip blk , ConsensusProtocol (BlockProtocol blk) ) => ConsensusConfig (BlockProtocol blk) -> KnownIntersectionState blk -> Either String () checkKnownIntersectionInvariants :: ConsensusConfig (BlockProtocol blk) -> KnownIntersectionState blk -> Either String () checkKnownIntersectionInvariants ConsensusConfig (BlockProtocol blk) cfg KnownIntersectionState { AnchoredFragment (Header blk) ourFrag :: AnchoredFragment (Header blk) $sel:ourFrag:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> AnchoredFragment (Header blk) ourFrag , AnchoredFragment (Header blk) theirFrag :: AnchoredFragment (Header blk) $sel:theirFrag:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> AnchoredFragment (Header blk) theirFrag , HeaderStateHistory blk theirHeaderStateHistory :: HeaderStateHistory blk $sel:theirHeaderStateHistory:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> HeaderStateHistory blk theirHeaderStateHistory , Point blk mostRecentIntersection :: Point blk $sel:mostRecentIntersection:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> Point blk mostRecentIntersection } -- 'theirHeaderStateHistory' invariant | let HeaderStateHistory AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk) snapshots = HeaderStateHistory blk theirHeaderStateHistory historyTips :: [WithOrigin (AnnTip blk)] historyTips = HeaderState blk -> WithOrigin (AnnTip blk) forall blk. HeaderState blk -> WithOrigin (AnnTip blk) headerStateTip (HeaderState blk -> WithOrigin (AnnTip blk)) -> [HeaderState blk] -> [WithOrigin (AnnTip blk)] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk) -> [HeaderState blk] forall v a b. AnchoredSeq v a b -> [b] AS.toOldestFirst AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk) snapshots fragmentTips :: [WithOrigin (AnnTip blk)] fragmentTips = AnnTip blk -> WithOrigin (AnnTip blk) forall t. t -> WithOrigin t NotOrigin (AnnTip blk -> WithOrigin (AnnTip blk)) -> (Header blk -> AnnTip blk) -> Header blk -> WithOrigin (AnnTip blk) forall b c a. (b -> c) -> (a -> b) -> a -> c . Header blk -> AnnTip blk forall blk. (HasHeader (Header blk), HasAnnTip blk) => Header blk -> AnnTip blk getAnnTip (Header blk -> WithOrigin (AnnTip blk)) -> [Header blk] -> [WithOrigin (AnnTip blk)] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> AnchoredFragment (Header blk) -> [Header blk] forall v a b. AnchoredSeq v a b -> [b] AF.toOldestFirst AnchoredFragment (Header blk) theirFrag historyAnchorPoint :: Point blk historyAnchorPoint = WithOrigin (RealPoint blk) -> Point blk forall blk. WithOrigin (RealPoint blk) -> Point blk withOriginRealPointToPoint (WithOrigin (RealPoint blk) -> Point blk) -> WithOrigin (RealPoint blk) -> Point blk forall a b. (a -> b) -> a -> b $ AnnTip blk -> RealPoint blk forall blk. HasAnnTip blk => AnnTip blk -> RealPoint blk annTipRealPoint (AnnTip blk -> RealPoint blk) -> WithOrigin (AnnTip blk) -> WithOrigin (RealPoint blk) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> HeaderState blk -> WithOrigin (AnnTip blk) forall blk. HeaderState blk -> WithOrigin (AnnTip blk) headerStateTip (AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk) -> HeaderState blk forall v a b. AnchoredSeq v a b -> a AS.anchor AnchoredSeq (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk) snapshots) fragmentAnchorPoint :: Point blk fragmentAnchorPoint = Point (Header blk) -> Point blk forall b b'. Coercible (HeaderHash b) (HeaderHash b') => Point b -> Point b' castPoint (Point (Header blk) -> Point blk) -> Point (Header blk) -> Point blk forall a b. (a -> b) -> a -> b $ AnchoredFragment (Header blk) -> Point (Header blk) forall block. AnchoredFragment block -> Point block AF.anchorPoint AnchoredFragment (Header blk) theirFrag , [WithOrigin (AnnTip blk)] historyTips [WithOrigin (AnnTip blk)] -> [WithOrigin (AnnTip blk)] -> Bool forall a. Eq a => a -> a -> Bool /= [WithOrigin (AnnTip blk)] fragmentTips Bool -> Bool -> Bool || Point blk historyAnchorPoint Point blk -> Point blk -> Bool forall a. Eq a => a -> a -> Bool /= Point blk fragmentAnchorPoint = String -> Either String () forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (String -> Either String ()) -> String -> Either String () forall a b. (a -> b) -> a -> b $ Context -> String unwords [ String "The tips in theirHeaderStateHistory didn't match the headers in theirFrag:" , [WithOrigin (AnnTip blk)] -> String forall a. Show a => a -> String show [WithOrigin (AnnTip blk)] historyTips , String "vs" , [WithOrigin (AnnTip blk)] -> String forall a. Show a => a -> String show [WithOrigin (AnnTip blk)] fragmentTips , String "with anchors" , Point blk -> String forall a. Show a => a -> String show Point blk historyAnchorPoint , String "vs" , Point blk -> String forall a. Show a => a -> String show Point blk fragmentAnchorPoint ] -- 'ourFrag' invariants | let nbHeaders :: Int nbHeaders = AnchoredFragment (Header blk) -> Int forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int AF.length AnchoredFragment (Header blk) ourFrag ourAnchorPoint :: Point (Header blk) ourAnchorPoint = AnchoredFragment (Header blk) -> Point (Header blk) forall block. AnchoredFragment block -> Point block AF.anchorPoint AnchoredFragment (Header blk) ourFrag , Int nbHeaders Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Word64 -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral Word64 k , Point (Header blk) ourAnchorPoint Point (Header blk) -> Point (Header blk) -> Bool forall a. Eq a => a -> a -> Bool /= Point (Header blk) forall block. Point block GenesisPoint = String -> Either String () forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (String -> Either String ()) -> String -> Either String () forall a b. (a -> b) -> a -> b $ Context -> String unwords [ String "ourFrag contains fewer than k headers and not close to genesis:" , Int -> String forall a. Show a => a -> String show Int nbHeaders , String "vs" , Word64 -> String forall a. Show a => a -> String show Word64 k , String "with anchor" , Point (Header blk) -> String forall a. Show a => a -> String show Point (Header blk) ourAnchorPoint ] | let ourFragAnchor :: Point (Header blk) ourFragAnchor = AnchoredFragment (Header blk) -> Point (Header blk) forall block. AnchoredFragment block -> Point block AF.anchorPoint AnchoredFragment (Header blk) ourFrag theirFragAnchor :: Point (Header blk) theirFragAnchor = AnchoredFragment (Header blk) -> Point (Header blk) forall block. AnchoredFragment block -> Point block AF.anchorPoint AnchoredFragment (Header blk) theirFrag , Point (Header blk) ourFragAnchor Point (Header blk) -> Point (Header blk) -> Bool forall a. Eq a => a -> a -> Bool /= Point (Header blk) theirFragAnchor = String -> Either String () forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (String -> Either String ()) -> String -> Either String () forall a b. (a -> b) -> a -> b $ Context -> String unwords [ String "ourFrag and theirFrag have different anchor points:" , Point (Header blk) -> String forall a. Show a => a -> String show Point (Header blk) ourFragAnchor , String "vs" , Point (Header blk) -> String forall a. Show a => a -> String show Point (Header blk) theirFragAnchor ] -- 'mostRecentIntersection' invariant | let actualMostRecentIntersection :: Maybe (Point blk) actualMostRecentIntersection = Point (Header blk) -> Point blk forall b b'. Coercible (HeaderHash b) (HeaderHash b') => Point b -> Point b' castPoint (Point (Header blk) -> Point blk) -> Maybe (Point (Header blk)) -> Maybe (Point blk) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> AnchoredFragment (Header blk) -> AnchoredFragment (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 AnchoredFragment (Header blk) theirFrag AnchoredFragment (Header blk) ourFrag , Point blk -> Maybe (Point blk) forall a. a -> Maybe a Just Point blk mostRecentIntersection Maybe (Point blk) -> Maybe (Point blk) -> Bool forall a. Eq a => a -> a -> Bool /= Maybe (Point blk) actualMostRecentIntersection = String -> Either String () forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (String -> Either String ()) -> String -> Either String () forall a b. (a -> b) -> a -> b $ Context -> String unwords [ String "mostRecentIntersection not the most recent intersection" , String "of theirFrag and ourFrag:" , Point blk -> String forall a. Show a => a -> String show Point blk mostRecentIntersection , String "vs" , Maybe (Point blk) -> String forall a. Show a => a -> String show Maybe (Point blk) actualMostRecentIntersection ] | Bool otherwise = () -> Either String () forall (m :: * -> *) a. Monad m => a -> m a return () where SecurityParam Word64 k = ConsensusConfig (BlockProtocol blk) -> SecurityParam forall p. ConsensusProtocol p => ConsensusConfig p -> SecurityParam protocolSecurityParam ConsensusConfig (BlockProtocol blk) cfg assertKnownIntersectionInvariants :: ( HasHeader blk , HasHeader (Header blk) , HasAnnTip blk , ConsensusProtocol (BlockProtocol blk) , HasCallStack ) => ConsensusConfig (BlockProtocol blk) -> KnownIntersectionState blk -> KnownIntersectionState blk assertKnownIntersectionInvariants :: ConsensusConfig (BlockProtocol blk) -> KnownIntersectionState blk -> KnownIntersectionState blk assertKnownIntersectionInvariants ConsensusConfig (BlockProtocol blk) cfg KnownIntersectionState blk kis = Either String () -> KnownIntersectionState blk -> KnownIntersectionState blk forall a. HasCallStack => Either String () -> a -> a assertWithMsg (ConsensusConfig (BlockProtocol blk) -> KnownIntersectionState blk -> Either String () forall blk. (HasHeader blk, HasHeader (Header blk), HasAnnTip blk, ConsensusProtocol (BlockProtocol blk)) => ConsensusConfig (BlockProtocol blk) -> KnownIntersectionState blk -> Either String () checkKnownIntersectionInvariants ConsensusConfig (BlockProtocol blk) cfg KnownIntersectionState blk kis) KnownIntersectionState blk kis -- | Chain sync client -- -- This never terminates. In case of a failure, a 'ChainSyncClientException' -- is thrown. The network layer classifies exception such that the -- corresponding peer will never be chosen again. chainSyncClient :: forall m blk. ( IOLike m , LedgerSupportsProtocol blk ) => MkPipelineDecision -> Tracer m (TraceChainSyncClientEvent blk) -> TopLevelConfig blk -> ChainDbView m blk -> NodeToNodeVersion -> ControlMessageSTM m -> HeaderMetricsTracer m -> StrictTVar m (AnchoredFragment (Header blk)) -> Consensus ChainSyncClientPipelined blk m chainSyncClient :: MkPipelineDecision -> Tracer m (TraceChainSyncClientEvent blk) -> TopLevelConfig blk -> ChainDbView m blk -> NodeToNodeVersion -> ControlMessageSTM m -> HeaderMetricsTracer m -> StrictTVar m (AnchoredFragment (Header blk)) -> Consensus ChainSyncClientPipelined blk m chainSyncClient MkPipelineDecision mkPipelineDecision0 Tracer m (TraceChainSyncClientEvent blk) tracer TopLevelConfig blk cfg ChainDbView { STM m (AnchoredFragment (Header blk)) getCurrentChain :: STM m (AnchoredFragment (Header blk)) $sel:getCurrentChain:ChainDbView :: forall (m :: * -> *) blk. ChainDbView m blk -> STM m (AnchoredFragment (Header blk)) getCurrentChain , STM m (HeaderStateHistory blk) getHeaderStateHistory :: STM m (HeaderStateHistory blk) $sel:getHeaderStateHistory:ChainDbView :: forall (m :: * -> *) blk. ChainDbView m blk -> STM m (HeaderStateHistory blk) getHeaderStateHistory , Point blk -> STM m (Maybe (ExtLedgerState blk)) getPastLedger :: Point blk -> STM m (Maybe (ExtLedgerState blk)) $sel:getPastLedger:ChainDbView :: forall (m :: * -> *) blk. ChainDbView m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk)) getPastLedger , STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) getIsInvalidBlock :: STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) $sel:getIsInvalidBlock:ChainDbView :: forall (m :: * -> *) blk. ChainDbView m blk -> STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) getIsInvalidBlock } NodeToNodeVersion version ControlMessageSTM m controlMessageSTM HeaderMetricsTracer m headerMetricsTracer StrictTVar m (AnchoredFragment (Header blk)) varCandidate = m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> Consensus ChainSyncClientPipelined blk m forall header point tip (m :: * -> *) a. m (ClientPipelinedStIdle 'Z header point tip m a) -> ChainSyncClientPipelined header point tip m a ChainSyncClientPipelined (m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> Consensus ChainSyncClientPipelined blk m) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> Consensus ChainSyncClientPipelined blk m forall a b. (a -> b) -> a -> b $ () -> Stateful m blk () (ClientPipelinedStIdle 'Z) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). NoThunks s => s -> Stateful m blk s st -> m (Consensus st blk m) continueWithState () (Stateful m blk () (ClientPipelinedStIdle 'Z) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> Stateful m blk () (ClientPipelinedStIdle 'Z) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall a b. (a -> b) -> a -> b $ Stateful m blk () (ClientPipelinedStIdle 'Z) initialise where -- | Start ChainSync by looking for an intersection between our current -- chain fragment and their chain. initialise :: Stateful m blk () (ClientPipelinedStIdle 'Z) initialise :: Stateful m blk () (ClientPipelinedStIdle 'Z) initialise = (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult) -> Stateful m blk () (ClientPipelinedStIdle 'Z) findIntersection (Point blk -> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult forall blk. BlockSupportsProtocol blk => Point blk -> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult ForkTooDeep Point blk forall block. Point block GenesisPoint) -- | Try to find an intersection by sending points of our current chain to -- the server, if any of them intersect with their chain, roll back our -- chain to that point and start synching using that fragment. If none -- intersect, disconnect by throwing the exception obtained by calling the -- passed function. findIntersection :: (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult) -- ^ Exception to throw when no intersection is found. -> Stateful m blk () (ClientPipelinedStIdle 'Z) findIntersection :: (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult) -> Stateful m blk () (ClientPipelinedStIdle 'Z) findIntersection Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult mkResult = (() -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> Stateful m blk () (ClientPipelinedStIdle 'Z) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). (s -> m (Consensus st blk m)) -> Stateful m blk s st Stateful ((() -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> Stateful m blk () (ClientPipelinedStIdle 'Z)) -> (() -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> Stateful m blk () (ClientPipelinedStIdle 'Z) forall a b. (a -> b) -> a -> b $ \() -> do (AnchoredFragment (Header blk) ourFrag, HeaderStateHistory blk ourHeaderStateHistory) <- STM m (AnchoredFragment (Header blk), HeaderStateHistory blk) -> m (AnchoredFragment (Header blk), HeaderStateHistory blk) forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m (AnchoredFragment (Header blk), HeaderStateHistory blk) -> m (AnchoredFragment (Header blk), HeaderStateHistory blk)) -> STM m (AnchoredFragment (Header blk), HeaderStateHistory blk) -> m (AnchoredFragment (Header blk), HeaderStateHistory blk) forall a b. (a -> b) -> a -> b $ (,) (AnchoredFragment (Header blk) -> HeaderStateHistory blk -> (AnchoredFragment (Header blk), HeaderStateHistory blk)) -> STM m (AnchoredFragment (Header blk)) -> STM m (HeaderStateHistory blk -> (AnchoredFragment (Header blk), HeaderStateHistory blk)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> STM m (AnchoredFragment (Header blk)) getCurrentChain STM m (HeaderStateHistory blk -> (AnchoredFragment (Header blk), HeaderStateHistory blk)) -> STM m (HeaderStateHistory blk) -> STM m (AnchoredFragment (Header blk), HeaderStateHistory blk) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> STM m (HeaderStateHistory blk) getHeaderStateHistory -- We select points from the last @k@ headers of our current chain. This -- means that if an intersection is found for one of these points, it -- was an intersection within the last @k@ blocks of our current chain. -- If not, we could never switch to this candidate chain anyway. let maxOffset :: Word64 maxOffset = Int -> Word64 forall a b. (Integral a, Num b) => a -> b fromIntegral (AnchoredFragment (Header blk) -> Int forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int AF.length AnchoredFragment (Header blk) ourFrag) points :: [Point blk] points = (Point (Header blk) -> Point blk) -> [Point (Header blk)] -> [Point blk] forall a b. (a -> b) -> [a] -> [b] map Point (Header blk) -> Point blk forall b b'. Coercible (HeaderHash b) (HeaderHash b') => Point b -> Point b' castPoint ([Point (Header blk)] -> [Point blk]) -> [Point (Header blk)] -> [Point blk] forall a b. (a -> b) -> a -> b $ [Int] -> AnchoredFragment (Header blk) -> [Point (Header blk)] forall block. HasHeader block => [Int] -> AnchoredFragment block -> [Point block] AF.selectPoints ((Word64 -> Int) -> [Word64] -> [Int] forall a b. (a -> b) -> [a] -> [b] map Word64 -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral (Word64 -> [Word64] offsets Word64 maxOffset)) AnchoredFragment (Header blk) ourFrag uis :: UnknownIntersectionState blk uis = UnknownIntersectionState :: forall blk. AnchoredFragment (Header blk) -> HeaderStateHistory blk -> UnknownIntersectionState blk UnknownIntersectionState { $sel:ourFrag:UnknownIntersectionState :: AnchoredFragment (Header blk) ourFrag = AnchoredFragment (Header blk) ourFrag , $sel:ourHeaderStateHistory:UnknownIntersectionState :: HeaderStateHistory blk ourHeaderStateHistory = HeaderStateHistory blk ourHeaderStateHistory } ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall (m :: * -> *) a. Monad m => a -> m a return (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall a b. (a -> b) -> a -> b $ [Point blk] -> ClientPipelinedStIntersect (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall point header tip (m :: * -> *) a. [point] -> ClientPipelinedStIntersect header point tip m a -> ClientPipelinedStIdle 'Z header point tip m a SendMsgFindIntersect [Point blk] points (ClientPipelinedStIntersect (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> ClientPipelinedStIntersect (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall a b. (a -> b) -> a -> b $ ClientPipelinedStIntersect :: forall header point tip (m :: * -> *) a. (point -> tip -> m (ClientPipelinedStIdle 'Z header point tip m a)) -> (tip -> m (ClientPipelinedStIdle 'Z header point tip m a)) -> ClientPipelinedStIntersect header point tip m a ClientPipelinedStIntersect { recvMsgIntersectFound :: Point blk -> Tip blk -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) recvMsgIntersectFound = \Point blk i Tip blk theirTip' -> UnknownIntersectionState blk -> Stateful m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). NoThunks s => s -> Stateful m blk s st -> m (Consensus st blk m) continueWithState UnknownIntersectionState blk uis (Stateful m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> Stateful m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall a b. (a -> b) -> a -> b $ Point blk -> Their (Tip blk) -> Stateful m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z) intersectFound (Point blk -> Point blk forall b b'. Coercible (HeaderHash b) (HeaderHash b') => Point b -> Point b' castPoint Point blk i) (Tip blk -> Their (Tip blk) forall a. a -> Their a Their Tip blk theirTip') , recvMsgIntersectNotFound :: Tip blk -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) recvMsgIntersectNotFound = \Tip blk theirTip' -> ChainSyncClientResult -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) terminate (ChainSyncClientResult -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> ChainSyncClientResult -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall a b. (a -> b) -> a -> b $ Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult mkResult (AnchoredFragment (Header blk) -> Our (Tip blk) ourTipFromChain AnchoredFragment (Header blk) ourFrag) (Tip blk -> Their (Tip blk) forall a. a -> Their a Their Tip blk theirTip') } -- | One of the points we sent intersected our chain. This intersection -- point will become the new tip of the candidate chain. intersectFound :: Point blk -- ^ Intersection -> Their (Tip blk) -> Stateful m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z) intersectFound :: Point blk -> Their (Tip blk) -> Stateful m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z) intersectFound Point blk intersection Their (Tip blk) theirTip = (UnknownIntersectionState blk -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> Stateful m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). (s -> m (Consensus st blk m)) -> Stateful m blk s st Stateful ((UnknownIntersectionState blk -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> Stateful m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z)) -> (UnknownIntersectionState blk -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> Stateful m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z) forall a b. (a -> b) -> a -> b $ \UnknownIntersectionState { AnchoredFragment (Header blk) ourFrag :: AnchoredFragment (Header blk) $sel:ourFrag:UnknownIntersectionState :: forall blk. UnknownIntersectionState blk -> AnchoredFragment (Header blk) ourFrag , HeaderStateHistory blk ourHeaderStateHistory :: HeaderStateHistory blk $sel:ourHeaderStateHistory:UnknownIntersectionState :: forall blk. UnknownIntersectionState blk -> HeaderStateHistory blk ourHeaderStateHistory } -> do Tracer m (TraceChainSyncClientEvent blk) -> TraceChainSyncClientEvent blk -> m () forall (m :: * -> *) a. Tracer m a -> a -> m () traceWith Tracer m (TraceChainSyncClientEvent blk) tracer (TraceChainSyncClientEvent blk -> m ()) -> TraceChainSyncClientEvent blk -> m () forall a b. (a -> b) -> a -> b $ Point blk -> Our (Tip blk) -> Their (Tip blk) -> TraceChainSyncClientEvent blk forall blk. Point blk -> Our (Tip blk) -> Their (Tip blk) -> TraceChainSyncClientEvent blk TraceFoundIntersection Point blk intersection (AnchoredFragment (Header blk) -> Our (Tip blk) ourTipFromChain AnchoredFragment (Header blk) ourFrag) Their (Tip blk) theirTip m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall a. m a -> m a traceException (m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall a b. (a -> b) -> a -> b $ do -- Roll back the current chain fragment to the @intersection@. -- -- While the primitives in the ChainSync protocol are "roll back", -- "roll forward (apply block)", etc. The /real/ primitive is "switch -- to fork", which means that a roll back is always followed by -- applying at least as many blocks that we rolled back. -- -- This is important for 'rewindHeaderStateHistory', which can only roll -- back up to @k@ blocks, /once/, i.e., we cannot keep rolling back the -- same chain state multiple times, because that would mean that we -- store the chain state for the /whole chain/, all the way to genesis. -- -- So the rewind below is fine when we are switching to a fork (i.e. -- it is followed by rolling forward again), but we need some -- guarantees that the ChainSync protocol /does/ in fact give us a -- switch-to-fork instead of a true rollback. (AnchoredFragment (Header blk) theirFrag, HeaderStateHistory blk theirHeaderStateHistory) <- do case Point blk -> (AnchoredFragment (Header blk), HeaderStateHistory blk) -> Maybe (AnchoredFragment (Header blk), HeaderStateHistory blk) forall blk. (BlockSupportsProtocol blk, HasAnnTip blk) => Point blk -> (AnchoredFragment (Header blk), HeaderStateHistory blk) -> Maybe (AnchoredFragment (Header blk), HeaderStateHistory blk) attemptRollback Point blk intersection (AnchoredFragment (Header blk) ourFrag, HeaderStateHistory blk ourHeaderStateHistory) of Just (AnchoredFragment (Header blk) c, HeaderStateHistory blk d) -> (AnchoredFragment (Header blk), HeaderStateHistory blk) -> m (AnchoredFragment (Header blk), HeaderStateHistory blk) forall (m :: * -> *) a. Monad m => a -> m a return (AnchoredFragment (Header blk) c, HeaderStateHistory blk d) -- The @intersection@ is not on the candidate chain, even though -- we sent only points from the candidate chain to find an -- intersection with. The node must have sent us an invalid -- intersection point. Maybe (AnchoredFragment (Header blk), HeaderStateHistory blk) Nothing -> ChainSyncClientException -> m (AnchoredFragment (Header blk), HeaderStateHistory blk) forall (m' :: * -> *) x'. MonadThrow m' => ChainSyncClientException -> m' x' disconnect (ChainSyncClientException -> m (AnchoredFragment (Header blk), HeaderStateHistory blk)) -> ChainSyncClientException -> m (AnchoredFragment (Header blk), HeaderStateHistory blk) forall a b. (a -> b) -> a -> b $ Point blk -> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientException forall blk. BlockSupportsProtocol blk => Point blk -> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientException InvalidIntersection Point blk intersection (AnchoredFragment (Header blk) -> Our (Tip blk) ourTipFromChain AnchoredFragment (Header blk) ourFrag) Their (Tip blk) theirTip STM m () -> m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m () -> m ()) -> STM m () -> m () forall a b. (a -> b) -> a -> b $ StrictTVar m (AnchoredFragment (Header blk)) -> AnchoredFragment (Header blk) -> STM m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => StrictTVar m a -> a -> STM m () writeTVar StrictTVar m (AnchoredFragment (Header blk)) varCandidate AnchoredFragment (Header blk) theirFrag let kis :: KnownIntersectionState blk kis = ConsensusConfig (BlockProtocol blk) -> KnownIntersectionState blk -> KnownIntersectionState blk forall blk. (HasHeader blk, HasHeader (Header blk), HasAnnTip blk, ConsensusProtocol (BlockProtocol blk), HasCallStack) => ConsensusConfig (BlockProtocol blk) -> KnownIntersectionState blk -> KnownIntersectionState blk assertKnownIntersectionInvariants (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk) forall blk. TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk) configConsensus TopLevelConfig blk cfg) (KnownIntersectionState blk -> KnownIntersectionState blk) -> KnownIntersectionState blk -> KnownIntersectionState blk forall a b. (a -> b) -> a -> b $ KnownIntersectionState :: forall blk. AnchoredFragment (Header blk) -> HeaderStateHistory blk -> AnchoredFragment (Header blk) -> Point blk -> KnownIntersectionState blk KnownIntersectionState { $sel:theirFrag:KnownIntersectionState :: AnchoredFragment (Header blk) theirFrag = AnchoredFragment (Header blk) theirFrag , $sel:theirHeaderStateHistory:KnownIntersectionState :: HeaderStateHistory blk theirHeaderStateHistory = HeaderStateHistory blk theirHeaderStateHistory , $sel:ourFrag:KnownIntersectionState :: AnchoredFragment (Header blk) ourFrag = AnchoredFragment (Header blk) ourFrag , $sel:mostRecentIntersection:KnownIntersectionState :: Point blk mostRecentIntersection = Point blk intersection } KnownIntersectionState blk -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). NoThunks s => s -> Stateful m blk s st -> m (Consensus st blk m) continueWithState KnownIntersectionState blk kis (Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall a b. (a -> b) -> a -> b $ MkPipelineDecision -> Nat 'Z -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z) forall (n :: N). MkPipelineDecision -> Nat n -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) nextStep MkPipelineDecision mkPipelineDecision0 Nat 'Z forall (n :: N). ('Z ~ n) => Nat n Zero Their (Tip blk) theirTip -- | Look at the current chain fragment that may have been updated in the -- background. Check whether the candidate fragment still intersects with -- it. If so, update the 'KnownIntersectionState' and trim the candidate -- fragment to the new current chain fragment's anchor point. If not, -- return 'Nothing'. intersectsWithCurrentChain :: KnownIntersectionState blk -> STM m (Maybe (KnownIntersectionState blk)) intersectsWithCurrentChain :: KnownIntersectionState blk -> STM m (Maybe (KnownIntersectionState blk)) intersectsWithCurrentChain kis :: KnownIntersectionState blk kis@KnownIntersectionState { AnchoredFragment (Header blk) theirFrag :: AnchoredFragment (Header blk) $sel:theirFrag:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> AnchoredFragment (Header blk) theirFrag , HeaderStateHistory blk theirHeaderStateHistory :: HeaderStateHistory blk $sel:theirHeaderStateHistory:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> HeaderStateHistory blk theirHeaderStateHistory , AnchoredFragment (Header blk) ourFrag :: AnchoredFragment (Header blk) $sel:ourFrag:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> AnchoredFragment (Header blk) ourFrag } = do AnchoredFragment (Header blk) ourFrag' <- STM m (AnchoredFragment (Header blk)) getCurrentChain if | AnchoredFragment (Header blk) -> Point (Header blk) forall block. HasHeader block => AnchoredFragment block -> Point block AF.headPoint AnchoredFragment (Header blk) ourFrag Point (Header blk) -> Point (Header blk) -> Bool forall a. Eq a => a -> a -> Bool == AnchoredFragment (Header blk) -> Point (Header blk) forall block. HasHeader block => AnchoredFragment block -> Point block AF.headPoint AnchoredFragment (Header blk) ourFrag' -> -- Our current chain didn't change, and changes to their chain that -- might affect the intersection point are handled elsewhere -- ('rollBackward'), so we have nothing to do. Maybe (KnownIntersectionState blk) -> STM m (Maybe (KnownIntersectionState blk)) forall (m :: * -> *) a. Monad m => a -> m a return (Maybe (KnownIntersectionState blk) -> STM m (Maybe (KnownIntersectionState blk))) -> Maybe (KnownIntersectionState blk) -> STM m (Maybe (KnownIntersectionState blk)) forall a b. (a -> b) -> a -> b $ KnownIntersectionState blk -> Maybe (KnownIntersectionState blk) forall a. a -> Maybe a Just KnownIntersectionState blk kis | Just Point (Header blk) intersection <- AnchoredFragment (Header blk) -> AnchoredFragment (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 AnchoredFragment (Header blk) ourFrag' AnchoredFragment (Header blk) theirFrag -> -- Our current chain changed, but it still intersects with candidate -- fragment, so update the 'ourFrag' field and trim to the -- candidate fragment to the same anchor point. -- -- Note that this is the only place we need to trim. Headers on -- their chain can only become unnecessary (eligible for trimming) -- in two ways: 1. we adopted them, i.e., our chain changed (handled -- in this function); 2. we will /never/ adopt them, which is -- handled in the "no more intersection case". case AnchoredFragment (Header blk) -> Point (Header blk) -> Maybe (AnchoredFragment (Header blk), AnchoredFragment (Header blk)) forall block1 block2. (HasHeader block1, HeaderHash block1 ~ HeaderHash block2) => AnchoredFragment block1 -> Point block2 -> Maybe (AnchoredFragment block1, AnchoredFragment block1) AF.splitAfterPoint AnchoredFragment (Header blk) theirFrag (AnchoredFragment (Header blk) -> Point (Header blk) forall block. AnchoredFragment block -> Point block AF.anchorPoint AnchoredFragment (Header blk) ourFrag') of -- + Before the update to our fragment, both fragments were -- anchored at the same anchor. -- + We still have an intersection. -- + The number of blocks after the intersection cannot have -- shrunk, but could have increased. -- + If it did increase, the anchor point will have shifted up. -- + It can't have moved up past the intersection point (because -- then there would be no intersection anymore). -- + This means the new anchor point must be between the old anchor -- point and the new intersection point. -- + Since we know both the old anchor point and the new -- intersection point exist on their fragment, the new anchor -- point must also. Maybe (AnchoredFragment (Header blk), AnchoredFragment (Header blk)) Nothing -> String -> STM m (Maybe (KnownIntersectionState blk)) forall a. HasCallStack => String -> a error String "anchor point must be on candidate fragment if they intersect" Just (AnchoredFragment (Header blk) _, AnchoredFragment (Header blk) trimmedCandidateFrag) -> Maybe (KnownIntersectionState blk) -> STM m (Maybe (KnownIntersectionState blk)) forall (m :: * -> *) a. Monad m => a -> m a return (Maybe (KnownIntersectionState blk) -> STM m (Maybe (KnownIntersectionState blk))) -> Maybe (KnownIntersectionState blk) -> STM m (Maybe (KnownIntersectionState blk)) forall a b. (a -> b) -> a -> b $ KnownIntersectionState blk -> Maybe (KnownIntersectionState blk) forall a. a -> Maybe a Just (KnownIntersectionState blk -> Maybe (KnownIntersectionState blk)) -> KnownIntersectionState blk -> Maybe (KnownIntersectionState blk) forall a b. (a -> b) -> a -> b $ ConsensusConfig (BlockProtocol blk) -> KnownIntersectionState blk -> KnownIntersectionState blk forall blk. (HasHeader blk, HasHeader (Header blk), HasAnnTip blk, ConsensusProtocol (BlockProtocol blk), HasCallStack) => ConsensusConfig (BlockProtocol blk) -> KnownIntersectionState blk -> KnownIntersectionState blk assertKnownIntersectionInvariants (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk) forall blk. TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk) configConsensus TopLevelConfig blk cfg) (KnownIntersectionState blk -> KnownIntersectionState blk) -> KnownIntersectionState blk -> KnownIntersectionState blk forall a b. (a -> b) -> a -> b $ KnownIntersectionState :: forall blk. AnchoredFragment (Header blk) -> HeaderStateHistory blk -> AnchoredFragment (Header blk) -> Point blk -> KnownIntersectionState blk KnownIntersectionState { $sel:ourFrag:KnownIntersectionState :: AnchoredFragment (Header blk) ourFrag = AnchoredFragment (Header blk) ourFrag' , $sel:theirFrag:KnownIntersectionState :: AnchoredFragment (Header blk) theirFrag = AnchoredFragment (Header blk) trimmedCandidateFrag , $sel:theirHeaderStateHistory:KnownIntersectionState :: HeaderStateHistory blk theirHeaderStateHistory = HeaderStateHistory blk trimmedHeaderStateHistory' , $sel:mostRecentIntersection:KnownIntersectionState :: Point blk mostRecentIntersection = Point (Header blk) -> Point blk forall b b'. Coercible (HeaderHash b) (HeaderHash b') => Point b -> Point b' castPoint Point (Header blk) intersection } where -- We trim the 'HeaderStateHistory' to the same size as our -- fragment so they keep in sync. trimmedHeaderStateHistory' :: HeaderStateHistory blk trimmedHeaderStateHistory' = Int -> HeaderStateHistory blk -> HeaderStateHistory blk forall blk. Int -> HeaderStateHistory blk -> HeaderStateHistory blk HeaderStateHistory.trim (AnchoredFragment (Header blk) -> Int forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int AF.length AnchoredFragment (Header blk) trimmedCandidateFrag) HeaderStateHistory blk theirHeaderStateHistory | Bool otherwise -> -- No more intersection with the current chain Maybe (KnownIntersectionState blk) -> STM m (Maybe (KnownIntersectionState blk)) forall (m :: * -> *) a. Monad m => a -> m a return Maybe (KnownIntersectionState blk) forall a. Maybe a Nothing -- | Request the next message (roll forward or backward), unless our chain -- has changed such that it no longer intersects with the candidate, in -- which case we initiate the intersection finding part of the protocol. -- -- This is the main place we check whether our current chain has changed. -- We also check it in 'rollForward' to make sure we have an up-to-date -- intersection before calling 'getLedgerView'. -- -- This is also the place where we checked whether we're asked to terminate -- by the mux layer. nextStep :: MkPipelineDecision -> Nat n -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) nextStep :: MkPipelineDecision -> Nat n -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) nextStep MkPipelineDecision mkPipelineDecision Nat n n Their (Tip blk) theirTip = (KnownIntersectionState blk -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). (s -> m (Consensus st blk m)) -> Stateful m blk s st Stateful ((KnownIntersectionState blk -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)) -> (KnownIntersectionState blk -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) forall a b. (a -> b) -> a -> b $ \KnownIntersectionState blk kis -> do ControlMessageSTM m -> m ControlMessage forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically ControlMessageSTM m controlMessageSTM m ControlMessage -> (ControlMessage -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> m (Consensus (ClientPipelinedStIdle n) blk m) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case -- We have been asked to terminate the client ControlMessage Terminate -> Nat n -> ChainSyncClientResult -> m (Consensus (ClientPipelinedStIdle n) blk m) forall (n :: N). Nat n -> ChainSyncClientResult -> m (Consensus (ClientPipelinedStIdle n) blk m) terminateAfterDrain Nat n n (ChainSyncClientResult -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> ChainSyncClientResult -> m (Consensus (ClientPipelinedStIdle n) blk m) forall a b. (a -> b) -> a -> b $ ChainSyncClientResult AskedToTerminate ControlMessage _continue -> do Maybe (KnownIntersectionState blk) mKis' <- STM m (Maybe (KnownIntersectionState blk)) -> m (Maybe (KnownIntersectionState blk)) forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m (Maybe (KnownIntersectionState blk)) -> m (Maybe (KnownIntersectionState blk))) -> STM m (Maybe (KnownIntersectionState blk)) -> m (Maybe (KnownIntersectionState blk)) forall a b. (a -> b) -> a -> b $ KnownIntersectionState blk -> STM m (Maybe (KnownIntersectionState blk)) intersectsWithCurrentChain KnownIntersectionState blk kis case Maybe (KnownIntersectionState blk) mKis' of Just kis' :: KnownIntersectionState blk kis'@KnownIntersectionState { AnchoredFragment (Header blk) theirFrag :: AnchoredFragment (Header blk) $sel:theirFrag:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> AnchoredFragment (Header blk) theirFrag } -> do -- Our chain (tip) didn't change or if it did, it still intersects -- with the candidate fragment, so we can continue requesting the -- next block. STM m () -> m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m () -> m ()) -> STM m () -> m () forall a b. (a -> b) -> a -> b $ StrictTVar m (AnchoredFragment (Header blk)) -> AnchoredFragment (Header blk) -> STM m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => StrictTVar m a -> a -> STM m () writeTVar StrictTVar m (AnchoredFragment (Header blk)) varCandidate AnchoredFragment (Header blk) theirFrag let candTipBlockNo :: WithOrigin BlockNo candTipBlockNo = AnchoredFragment (Header blk) -> WithOrigin BlockNo forall block. HasHeader block => AnchoredFragment block -> WithOrigin BlockNo AF.headBlockNo AnchoredFragment (Header blk) theirFrag Consensus (ClientPipelinedStIdle n) blk m -> m (Consensus (ClientPipelinedStIdle n) blk m) forall (m :: * -> *) a. Monad m => a -> m a return (Consensus (ClientPipelinedStIdle n) blk m -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Consensus (ClientPipelinedStIdle n) blk m -> m (Consensus (ClientPipelinedStIdle n) blk m) forall a b. (a -> b) -> a -> b $ KnownIntersectionState blk -> MkPipelineDecision -> Nat n -> Their (Tip blk) -> WithOrigin BlockNo -> Consensus (ClientPipelinedStIdle n) blk m forall (n :: N). KnownIntersectionState blk -> MkPipelineDecision -> Nat n -> Their (Tip blk) -> WithOrigin BlockNo -> Consensus (ClientPipelinedStIdle n) blk m requestNext KnownIntersectionState blk kis' MkPipelineDecision mkPipelineDecision Nat n n Their (Tip blk) theirTip WithOrigin BlockNo candTipBlockNo Maybe (KnownIntersectionState blk) Nothing -> -- Our chain (tip) has changed and it no longer intersects with -- the candidate fragment, so we have to find a new intersection, -- but first drain the pipe. () -> Stateful m blk () (ClientPipelinedStIdle n) -> m (Consensus (ClientPipelinedStIdle n) blk m) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). NoThunks s => s -> Stateful m blk s st -> m (Consensus st blk m) continueWithState () (Stateful m blk () (ClientPipelinedStIdle n) -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk () (ClientPipelinedStIdle n) -> m (Consensus (ClientPipelinedStIdle n) blk m) forall a b. (a -> b) -> a -> b $ Nat n -> Stateful m blk () (ClientPipelinedStIdle 'Z) -> Stateful m blk () (ClientPipelinedStIdle n) forall s (n :: N). NoThunks s => Nat n -> Stateful m blk s (ClientPipelinedStIdle 'Z) -> Stateful m blk s (ClientPipelinedStIdle n) drainThePipe Nat n n (Stateful m blk () (ClientPipelinedStIdle 'Z) -> Stateful m blk () (ClientPipelinedStIdle n)) -> Stateful m blk () (ClientPipelinedStIdle 'Z) -> Stateful m blk () (ClientPipelinedStIdle n) forall a b. (a -> b) -> a -> b $ (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult) -> Stateful m blk () (ClientPipelinedStIdle 'Z) findIntersection Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult forall blk. BlockSupportsProtocol blk => Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult NoMoreIntersection -- | "Drain the pipe": collect and discard all in-flight responses and -- finally execute the given action. drainThePipe :: forall s n. NoThunks s => Nat n -> Stateful m blk s (ClientPipelinedStIdle 'Z) -> Stateful m blk s (ClientPipelinedStIdle n) drainThePipe :: Nat n -> Stateful m blk s (ClientPipelinedStIdle 'Z) -> Stateful m blk s (ClientPipelinedStIdle n) drainThePipe Nat n n0 Stateful m blk s (ClientPipelinedStIdle 'Z) m = (s -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk s (ClientPipelinedStIdle n) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). (s -> m (Consensus st blk m)) -> Stateful m blk s st Stateful ((s -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk s (ClientPipelinedStIdle n)) -> (s -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk s (ClientPipelinedStIdle n) forall a b. (a -> b) -> a -> b $ Nat n -> s -> m (Consensus (ClientPipelinedStIdle n) blk m) forall (n' :: N). Nat n' -> s -> m (Consensus (ClientPipelinedStIdle n') blk m) go Nat n n0 where go :: forall n'. Nat n' -> s -> m (Consensus (ClientPipelinedStIdle n') blk m) go :: Nat n' -> s -> m (Consensus (ClientPipelinedStIdle n') blk m) go Nat n' n s s = case Nat n' n of Nat n' Zero -> s -> Stateful m blk s (ClientPipelinedStIdle 'Z) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). NoThunks s => s -> Stateful m blk s st -> m (Consensus st blk m) continueWithState s s Stateful m blk s (ClientPipelinedStIdle 'Z) m Succ Nat n n' -> ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall (m :: * -> *) a. Monad m => a -> m a return (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall a b. (a -> b) -> a -> b $ Maybe (m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> ClientStNext n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall (m :: * -> *) (n1 :: N) header point tip a. Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a)) -> ClientStNext n1 header point tip m a -> ClientPipelinedStIdle ('S n1) header point tip m a CollectResponse Maybe (m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) forall a. Maybe a Nothing (ClientStNext n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> ClientStNext n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall a b. (a -> b) -> a -> b $ ClientStNext :: forall (n :: N) header point tip (m :: * -> *) a. (header -> tip -> m (ClientPipelinedStIdle n header point tip m a)) -> (point -> tip -> m (ClientPipelinedStIdle n header point tip m a)) -> ClientStNext n header point tip m a ClientStNext { recvMsgRollForward :: Header blk -> Tip blk -> m (ClientPipelinedStIdle n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) recvMsgRollForward = \Header blk _hdr Tip blk _tip -> Nat n -> s -> m (ClientPipelinedStIdle n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall (n' :: N). Nat n' -> s -> m (Consensus (ClientPipelinedStIdle n') blk m) go Nat n n' s s , recvMsgRollBackward :: Point blk -> Tip blk -> m (ClientPipelinedStIdle n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) recvMsgRollBackward = \Point blk _pt Tip blk _tip -> Nat n -> s -> m (ClientPipelinedStIdle n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall (n' :: N). Nat n' -> s -> m (Consensus (ClientPipelinedStIdle n') blk m) go Nat n n' s s } requestNext :: KnownIntersectionState blk -> MkPipelineDecision -> Nat n -> Their (Tip blk) -> WithOrigin BlockNo -> Consensus (ClientPipelinedStIdle n) blk m requestNext :: KnownIntersectionState blk -> MkPipelineDecision -> Nat n -> Their (Tip blk) -> WithOrigin BlockNo -> Consensus (ClientPipelinedStIdle n) blk m requestNext KnownIntersectionState blk kis MkPipelineDecision mkPipelineDecision Nat n n Their (Tip blk) theirTip WithOrigin BlockNo candTipBlockNo = case (Nat n n, (PipelineDecision n, MkPipelineDecision) decision) of (Nat n Zero, (PipelineDecision n Request, MkPipelineDecision mkPipelineDecision')) -> ClientStNext 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> m (ClientStNext 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall header point tip (m :: * -> *) a. ClientStNext 'Z header point tip m a -> m (ClientStNext 'Z header point tip m a) -> ClientPipelinedStIdle 'Z header point tip m a SendMsgRequestNext (KnownIntersectionState blk -> MkPipelineDecision -> Nat 'Z -> ClientStNext 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall (n :: N). KnownIntersectionState blk -> MkPipelineDecision -> Nat n -> Consensus (ClientStNext n) blk m handleNext KnownIntersectionState blk kis MkPipelineDecision mkPipelineDecision' Nat 'Z forall (n :: N). ('Z ~ n) => Nat n Zero) (ClientStNext 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> m (ClientStNext 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall (m :: * -> *) a. Monad m => a -> m a return (ClientStNext 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> m (ClientStNext 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> ClientStNext 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> m (ClientStNext 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall a b. (a -> b) -> a -> b $ KnownIntersectionState blk -> MkPipelineDecision -> Nat 'Z -> ClientStNext 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall (n :: N). KnownIntersectionState blk -> MkPipelineDecision -> Nat n -> Consensus (ClientStNext n) blk m handleNext KnownIntersectionState blk kis MkPipelineDecision mkPipelineDecision' Nat 'Z forall (n :: N). ('Z ~ n) => Nat n Zero) -- when we have to wait (Nat n _, (PipelineDecision n Pipeline, MkPipelineDecision mkPipelineDecision')) -> ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> Consensus (ClientPipelinedStIdle n) blk m forall (n :: N) header point tip (m :: * -> *) a. ClientPipelinedStIdle ('S n) header point tip m a -> ClientPipelinedStIdle n header point tip m a SendMsgRequestNextPipelined (KnownIntersectionState blk -> MkPipelineDecision -> Nat ('S n) -> Their (Tip blk) -> WithOrigin BlockNo -> ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall (n :: N). KnownIntersectionState blk -> MkPipelineDecision -> Nat n -> Their (Tip blk) -> WithOrigin BlockNo -> Consensus (ClientPipelinedStIdle n) blk m requestNext KnownIntersectionState blk kis MkPipelineDecision mkPipelineDecision' (Nat n -> Nat ('S n) forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m Succ Nat n n) Their (Tip blk) theirTip WithOrigin BlockNo candTipBlockNo) (Succ Nat n n', (PipelineDecision n CollectOrPipeline, MkPipelineDecision mkPipelineDecision')) -> Maybe (m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> ClientStNext n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall (m :: * -> *) (n1 :: N) header point tip a. Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a)) -> ClientStNext n1 header point tip m a -> ClientPipelinedStIdle ('S n1) header point tip m a CollectResponse (m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> Maybe (m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) forall a. a -> Maybe a Just (m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> Maybe (m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult))) -> m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> Maybe (m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) forall a b. (a -> b) -> a -> b $ ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall (f :: * -> *) a. Applicative f => a -> f a pure (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall a b. (a -> b) -> a -> b $ ClientPipelinedStIdle ('S ('S n)) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall (n :: N) header point tip (m :: * -> *) a. ClientPipelinedStIdle ('S n) header point tip m a -> ClientPipelinedStIdle n header point tip m a SendMsgRequestNextPipelined (ClientPipelinedStIdle ('S ('S n)) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> ClientPipelinedStIdle ('S ('S n)) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall a b. (a -> b) -> a -> b $ KnownIntersectionState blk -> MkPipelineDecision -> Nat ('S ('S n)) -> Their (Tip blk) -> WithOrigin BlockNo -> ClientPipelinedStIdle ('S ('S n)) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall (n :: N). KnownIntersectionState blk -> MkPipelineDecision -> Nat n -> Their (Tip blk) -> WithOrigin BlockNo -> Consensus (ClientPipelinedStIdle n) blk m requestNext KnownIntersectionState blk kis MkPipelineDecision mkPipelineDecision' (Nat n -> Nat ('S ('S n)) forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m Succ Nat n n) Their (Tip blk) theirTip WithOrigin BlockNo candTipBlockNo) (KnownIntersectionState blk -> MkPipelineDecision -> Nat n -> ClientStNext n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall (n :: N). KnownIntersectionState blk -> MkPipelineDecision -> Nat n -> Consensus (ClientStNext n) blk m handleNext KnownIntersectionState blk kis MkPipelineDecision mkPipelineDecision' Nat n n') (Succ Nat n n', (PipelineDecision n Collect, MkPipelineDecision mkPipelineDecision')) -> Maybe (m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> ClientStNext n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall (m :: * -> *) (n1 :: N) header point tip a. Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a)) -> ClientStNext n1 header point tip m a -> ClientPipelinedStIdle ('S n1) header point tip m a CollectResponse Maybe (m (ClientPipelinedStIdle ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) forall a. Maybe a Nothing (KnownIntersectionState blk -> MkPipelineDecision -> Nat n -> ClientStNext n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall (n :: N). KnownIntersectionState blk -> MkPipelineDecision -> Nat n -> Consensus (ClientStNext n) blk m handleNext KnownIntersectionState blk kis MkPipelineDecision mkPipelineDecision' Nat n n') where theirTipBlockNo :: WithOrigin BlockNo theirTipBlockNo = Tip blk -> WithOrigin BlockNo forall b. Tip b -> WithOrigin BlockNo getTipBlockNo (Their (Tip blk) -> Tip blk forall a. Their a -> a unTheir Their (Tip blk) theirTip) decision :: (PipelineDecision n, MkPipelineDecision) decision = MkPipelineDecision -> Nat n -> WithOrigin BlockNo -> WithOrigin BlockNo -> (PipelineDecision n, MkPipelineDecision) forall (n :: N). MkPipelineDecision -> Nat n -> WithOrigin BlockNo -> WithOrigin BlockNo -> (PipelineDecision n, MkPipelineDecision) runPipelineDecision MkPipelineDecision mkPipelineDecision Nat n n WithOrigin BlockNo candTipBlockNo WithOrigin BlockNo theirTipBlockNo handleNext :: KnownIntersectionState blk -> MkPipelineDecision -> Nat n -> Consensus (ClientStNext n) blk m handleNext :: KnownIntersectionState blk -> MkPipelineDecision -> Nat n -> Consensus (ClientStNext n) blk m handleNext KnownIntersectionState blk kis MkPipelineDecision mkPipelineDecision Nat n n = ClientStNext :: forall (n :: N) header point tip (m :: * -> *) a. (header -> tip -> m (ClientPipelinedStIdle n header point tip m a)) -> (point -> tip -> m (ClientPipelinedStIdle n header point tip m a)) -> ClientStNext n header point tip m a ClientStNext { recvMsgRollForward :: Header blk -> Tip blk -> m (ClientPipelinedStIdle n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) recvMsgRollForward = \Header blk hdr Tip blk theirTip -> do Tracer m (TraceChainSyncClientEvent blk) -> TraceChainSyncClientEvent blk -> m () forall (m :: * -> *) a. Tracer m a -> a -> m () traceWith Tracer m (TraceChainSyncClientEvent blk) tracer (TraceChainSyncClientEvent blk -> m ()) -> TraceChainSyncClientEvent blk -> m () forall a b. (a -> b) -> a -> b $ Header blk -> TraceChainSyncClientEvent blk forall blk. Header blk -> TraceChainSyncClientEvent blk TraceDownloadedHeader Header blk hdr KnownIntersectionState blk -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) -> m (ClientPipelinedStIdle n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). NoThunks s => s -> Stateful m blk s st -> m (Consensus st blk m) continueWithState KnownIntersectionState blk kis (Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) -> m (ClientPipelinedStIdle n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) -> m (ClientPipelinedStIdle n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall a b. (a -> b) -> a -> b $ MkPipelineDecision -> Nat n -> Header blk -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) forall (n :: N). MkPipelineDecision -> Nat n -> Header blk -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) rollForward MkPipelineDecision mkPipelineDecision Nat n n Header blk hdr (Tip blk -> Their (Tip blk) forall a. a -> Their a Their Tip blk theirTip) , recvMsgRollBackward :: Point blk -> Tip blk -> m (ClientPipelinedStIdle n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) recvMsgRollBackward = \Point blk intersection Tip blk theirTip -> do let intersection' :: Point blk intersection' :: Point blk intersection' = Point blk -> Point blk forall b b'. Coercible (HeaderHash b) (HeaderHash b') => Point b -> Point b' castPoint Point blk intersection Tracer m (TraceChainSyncClientEvent blk) -> TraceChainSyncClientEvent blk -> m () forall (m :: * -> *) a. Tracer m a -> a -> m () traceWith Tracer m (TraceChainSyncClientEvent blk) tracer (TraceChainSyncClientEvent blk -> m ()) -> TraceChainSyncClientEvent blk -> m () forall a b. (a -> b) -> a -> b $ Point blk -> TraceChainSyncClientEvent blk forall blk. Point blk -> TraceChainSyncClientEvent blk TraceRolledBack Point blk intersection' KnownIntersectionState blk -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) -> m (ClientPipelinedStIdle n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). NoThunks s => s -> Stateful m blk s st -> m (Consensus st blk m) continueWithState KnownIntersectionState blk kis (Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) -> m (ClientPipelinedStIdle n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) -> m (ClientPipelinedStIdle n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall a b. (a -> b) -> a -> b $ MkPipelineDecision -> Nat n -> Point blk -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) forall (n :: N). MkPipelineDecision -> Nat n -> Point blk -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) rollBackward MkPipelineDecision mkPipelineDecision Nat n n Point blk intersection' (Tip blk -> Their (Tip blk) forall a. a -> Their a Their Tip blk theirTip) } rollForward :: MkPipelineDecision -> Nat n -> Header blk -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) rollForward :: MkPipelineDecision -> Nat n -> Header blk -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) rollForward MkPipelineDecision mkPipelineDecision Nat n n Header blk hdr Their (Tip blk) theirTip = (KnownIntersectionState blk -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). (s -> m (Consensus st blk m)) -> Stateful m blk s st Stateful ((KnownIntersectionState blk -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)) -> (KnownIntersectionState blk -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) forall a b. (a -> b) -> a -> b $ \KnownIntersectionState blk kis -> m (Consensus (ClientPipelinedStIdle n) blk m) -> m (Consensus (ClientPipelinedStIdle n) blk m) forall a. m a -> m a traceException (m (Consensus (ClientPipelinedStIdle n) blk m) -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> m (Consensus (ClientPipelinedStIdle n) blk m) -> m (Consensus (ClientPipelinedStIdle n) blk m) forall a b. (a -> b) -> a -> b $ do Time now <- m Time forall (m :: * -> *). MonadMonotonicTime m => m Time getMonotonicTime let hdrPoint :: Point blk hdrPoint = Header blk -> Point blk forall blk. HasHeader (Header blk) => Header blk -> Point blk headerPoint Header blk hdr HeaderHash blk -> Maybe (InvalidBlockReason blk) isInvalidBlock <- STM m (HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> m (HeaderHash blk -> Maybe (InvalidBlockReason blk)) forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m (HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> m (HeaderHash blk -> Maybe (InvalidBlockReason blk))) -> STM m (HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> m (HeaderHash blk -> Maybe (InvalidBlockReason blk)) forall a b. (a -> b) -> a -> b $ WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> HeaderHash blk -> Maybe (InvalidBlockReason blk) forall a. WithFingerprint a -> a forgetFingerprint (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) -> STM m (HeaderHash blk -> Maybe (InvalidBlockReason blk)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) getIsInvalidBlock let disconnectWhenInvalid :: ChainHash blk -> m () disconnectWhenInvalid = \case ChainHash blk GenesisHash -> () -> m () forall (f :: * -> *) a. Applicative f => a -> f a pure () BlockHash HeaderHash blk hash -> Maybe (InvalidBlockReason blk) -> (InvalidBlockReason blk -> m ()) -> m () forall (f :: * -> *) a. Applicative f => Maybe a -> (a -> f ()) -> f () whenJust (HeaderHash blk -> Maybe (InvalidBlockReason blk) isInvalidBlock HeaderHash blk hash) ((InvalidBlockReason blk -> m ()) -> m ()) -> (InvalidBlockReason blk -> m ()) -> m () forall a b. (a -> b) -> a -> b $ \InvalidBlockReason blk reason -> ChainSyncClientException -> m () forall (m' :: * -> *) x'. MonadThrow m' => ChainSyncClientException -> m' x' disconnect (ChainSyncClientException -> m ()) -> ChainSyncClientException -> m () forall a b. (a -> b) -> a -> b $ Point blk -> HeaderHash blk -> InvalidBlockReason blk -> ChainSyncClientException forall blk. LedgerSupportsProtocol blk => Point blk -> HeaderHash blk -> InvalidBlockReason blk -> ChainSyncClientException InvalidBlock Point blk hdrPoint HeaderHash blk hash InvalidBlockReason blk reason ChainHash blk -> m () disconnectWhenInvalid (ChainHash blk -> m ()) -> ChainHash blk -> m () forall a b. (a -> b) -> a -> b $ case NodeToNodeVersion -> WhetherReceivingTentativeBlocks isPipeliningEnabled NodeToNodeVersion version of -- Disconnect if the parent block of `hdr` is known to be invalid. WhetherReceivingTentativeBlocks ReceivingTentativeBlocks -> Header blk -> ChainHash blk forall blk. GetPrevHash blk => Header blk -> ChainHash blk headerPrevHash Header blk hdr WhetherReceivingTentativeBlocks NotReceivingTentativeBlocks -> HeaderHash blk -> ChainHash blk forall b. HeaderHash b -> ChainHash b BlockHash (Header blk -> HeaderHash blk forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk headerHash Header blk hdr) -- Get the ledger view required to validate the header -- NOTE: This will block if we are too far behind. IntersectCheck blk intersectCheck <- STM m (IntersectCheck blk) -> m (IntersectCheck blk) forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m (IntersectCheck blk) -> m (IntersectCheck blk)) -> STM m (IntersectCheck blk) -> m (IntersectCheck blk) forall a b. (a -> b) -> a -> b $ do -- Before obtaining a 'LedgerView', we must find the most recent -- intersection with the current chain. Note that this is cheap when -- the chain and candidate haven't changed. Maybe (KnownIntersectionState blk) mKis' <- KnownIntersectionState blk -> STM m (Maybe (KnownIntersectionState blk)) intersectsWithCurrentChain KnownIntersectionState blk kis case Maybe (KnownIntersectionState blk) mKis' of Maybe (KnownIntersectionState blk) Nothing -> IntersectCheck blk -> STM m (IntersectCheck blk) forall (m :: * -> *) a. Monad m => a -> m a return IntersectCheck blk forall blk. IntersectCheck blk NoLongerIntersects Just kis' :: KnownIntersectionState blk kis'@KnownIntersectionState { Point blk mostRecentIntersection :: Point blk $sel:mostRecentIntersection:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> Point blk mostRecentIntersection } -> do -- We're calling 'ledgerViewForecastAt' in the same STM transaction -- as 'intersectsWithCurrentChain'. This guarantees the former's -- precondition: the intersection is within the last @k@ blocks of -- the current chain. Forecast (LedgerView (BlockProtocol blk)) forecast <- Forecast (LedgerView (BlockProtocol blk)) -> (ExtLedgerState blk -> Forecast (LedgerView (BlockProtocol blk))) -> Maybe (ExtLedgerState blk) -> Forecast (LedgerView (BlockProtocol blk)) forall b a. b -> (a -> b) -> Maybe a -> b maybe (String -> Forecast (LedgerView (BlockProtocol blk)) forall a. HasCallStack => String -> a error (String -> Forecast (LedgerView (BlockProtocol blk))) -> String -> Forecast (LedgerView (BlockProtocol blk)) forall a b. (a -> b) -> a -> b $ String "intersection not within last k blocks: " String -> ShowS forall a. Semigroup a => a -> a -> a <> Point blk -> String forall a. Show a => a -> String show Point blk mostRecentIntersection) (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) (LedgerState blk -> Forecast (LedgerView (BlockProtocol blk))) -> (ExtLedgerState blk -> LedgerState blk) -> ExtLedgerState blk -> Forecast (LedgerView (BlockProtocol blk)) forall b c a. (b -> c) -> (a -> b) -> a -> c . ExtLedgerState blk -> LedgerState blk forall blk. ExtLedgerState blk -> LedgerState blk ledgerState) (Maybe (ExtLedgerState blk) -> Forecast (LedgerView (BlockProtocol blk))) -> STM m (Maybe (ExtLedgerState blk)) -> STM m (Forecast (LedgerView (BlockProtocol blk))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Point blk -> STM m (Maybe (ExtLedgerState blk)) getPastLedger Point blk mostRecentIntersection case Except OutsideForecastRange (Ticked (LedgerView (BlockProtocol blk))) -> Either OutsideForecastRange (Ticked (LedgerView (BlockProtocol blk))) forall e a. Except e a -> Either e a runExcept (Except OutsideForecastRange (Ticked (LedgerView (BlockProtocol blk))) -> Either OutsideForecastRange (Ticked (LedgerView (BlockProtocol blk)))) -> Except OutsideForecastRange (Ticked (LedgerView (BlockProtocol blk))) -> Either OutsideForecastRange (Ticked (LedgerView (BlockProtocol blk))) forall a b. (a -> b) -> a -> b $ Forecast (LedgerView (BlockProtocol blk)) -> SlotNo -> Except OutsideForecastRange (Ticked (LedgerView (BlockProtocol blk))) forall a. Forecast a -> SlotNo -> Except OutsideForecastRange (Ticked a) forecastFor Forecast (LedgerView (BlockProtocol blk)) forecast (Header blk -> SlotNo forall b. HasHeader b => b -> SlotNo blockSlot Header blk hdr) of -- The header is too far ahead of the intersection point with our -- current chain. We have to wait until our chain and the -- intersection have advanced far enough. This will wait on -- changes to the current chain via the call to -- 'intersectsWithCurrentChain' befoer it. Left OutsideForecastRange{} -> STM m (IntersectCheck blk) forall (m :: * -> *) a. MonadSTM m => STM m a retry Right Ticked (LedgerView (BlockProtocol blk)) ledgerView -> IntersectCheck blk -> STM m (IntersectCheck blk) forall (m :: * -> *) a. Monad m => a -> m a return (IntersectCheck blk -> STM m (IntersectCheck blk)) -> IntersectCheck blk -> STM m (IntersectCheck blk) forall a b. (a -> b) -> a -> b $ KnownIntersectionState blk -> Ticked (LedgerView (BlockProtocol blk)) -> IntersectCheck blk forall blk. KnownIntersectionState blk -> Ticked (LedgerView (BlockProtocol blk)) -> IntersectCheck blk Intersects KnownIntersectionState blk kis' Ticked (LedgerView (BlockProtocol blk)) ledgerView case IntersectCheck blk intersectCheck of IntersectCheck blk NoLongerIntersects -> -- Our chain (tip) has changed and it no longer intersects with the -- candidate fragment, so we have to find a new intersection, but -- first drain the pipe. () -> Stateful m blk () (ClientPipelinedStIdle n) -> m (Consensus (ClientPipelinedStIdle n) blk m) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). NoThunks s => s -> Stateful m blk s st -> m (Consensus st blk m) continueWithState () (Stateful m blk () (ClientPipelinedStIdle n) -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk () (ClientPipelinedStIdle n) -> m (Consensus (ClientPipelinedStIdle n) blk m) forall a b. (a -> b) -> a -> b $ Nat n -> Stateful m blk () (ClientPipelinedStIdle 'Z) -> Stateful m blk () (ClientPipelinedStIdle n) forall s (n :: N). NoThunks s => Nat n -> Stateful m blk s (ClientPipelinedStIdle 'Z) -> Stateful m blk s (ClientPipelinedStIdle n) drainThePipe Nat n n (Stateful m blk () (ClientPipelinedStIdle 'Z) -> Stateful m blk () (ClientPipelinedStIdle n)) -> Stateful m blk () (ClientPipelinedStIdle 'Z) -> Stateful m blk () (ClientPipelinedStIdle n) forall a b. (a -> b) -> a -> b $ (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult) -> Stateful m blk () (ClientPipelinedStIdle 'Z) findIntersection Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult forall blk. BlockSupportsProtocol blk => Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult NoMoreIntersection Intersects KnownIntersectionState blk kis' Ticked (LedgerView (BlockProtocol blk)) ledgerView -> do -- Our chain still intersects with the candidate fragment and we -- have obtained a 'LedgerView' that we can use to validate @hdr@. let KnownIntersectionState { AnchoredFragment (Header blk) ourFrag :: AnchoredFragment (Header blk) $sel:ourFrag:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> AnchoredFragment (Header blk) ourFrag , AnchoredFragment (Header blk) theirFrag :: AnchoredFragment (Header blk) $sel:theirFrag:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> AnchoredFragment (Header blk) theirFrag , HeaderStateHistory blk theirHeaderStateHistory :: HeaderStateHistory blk $sel:theirHeaderStateHistory:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> HeaderStateHistory blk theirHeaderStateHistory , Point blk mostRecentIntersection :: Point blk $sel:mostRecentIntersection:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> Point blk mostRecentIntersection } = KnownIntersectionState blk kis' -- Validate header let expectPrevHash :: ChainHash blk expectPrevHash = ChainHash (Header blk) -> ChainHash blk forall b b'. Coercible (HeaderHash b) (HeaderHash b') => ChainHash b -> ChainHash b' castHash (AnchoredFragment (Header blk) -> ChainHash (Header blk) forall block. HasHeader block => AnchoredFragment block -> ChainHash block AF.headHash AnchoredFragment (Header blk) theirFrag) actualPrevHash :: ChainHash blk actualPrevHash = Header blk -> ChainHash blk forall blk. GetPrevHash blk => Header blk -> ChainHash blk headerPrevHash Header blk hdr Bool -> m () -> m () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (ChainHash blk actualPrevHash ChainHash blk -> ChainHash blk -> Bool forall a. Eq a => a -> a -> Bool /= ChainHash blk expectPrevHash) (m () -> m ()) -> m () -> m () forall a b. (a -> b) -> a -> b $ ChainSyncClientException -> m () forall (m' :: * -> *) x'. MonadThrow m' => ChainSyncClientException -> m' x' disconnect (ChainSyncClientException -> m ()) -> ChainSyncClientException -> m () forall a b. (a -> b) -> a -> b $ ChainHash blk -> ChainHash blk -> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientException forall blk. BlockSupportsProtocol blk => ChainHash blk -> ChainHash blk -> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientException DoesntFit ChainHash blk actualPrevHash ChainHash blk expectPrevHash (AnchoredFragment (Header blk) -> Our (Tip blk) ourTipFromChain AnchoredFragment (Header blk) ourFrag) Their (Tip blk) theirTip HeaderStateHistory blk theirHeaderStateHistory' <- case Except (HeaderError blk) (HeaderStateHistory blk) -> Either (HeaderError blk) (HeaderStateHistory blk) forall e a. Except e a -> Either e a runExcept (Except (HeaderError blk) (HeaderStateHistory blk) -> Either (HeaderError blk) (HeaderStateHistory blk)) -> Except (HeaderError blk) (HeaderStateHistory blk) -> Either (HeaderError blk) (HeaderStateHistory blk) forall a b. (a -> b) -> a -> b $ TopLevelConfig blk -> Ticked (LedgerView (BlockProtocol blk)) -> Header blk -> HeaderStateHistory blk -> Except (HeaderError blk) (HeaderStateHistory blk) forall blk. (BlockSupportsProtocol blk, ValidateEnvelope blk) => TopLevelConfig blk -> Ticked (LedgerView (BlockProtocol blk)) -> Header blk -> HeaderStateHistory blk -> Except (HeaderError blk) (HeaderStateHistory blk) validateHeader TopLevelConfig blk cfg Ticked (LedgerView (BlockProtocol blk)) ledgerView Header blk hdr HeaderStateHistory blk theirHeaderStateHistory of Right HeaderStateHistory blk theirHeaderStateHistory' -> HeaderStateHistory blk -> m (HeaderStateHistory blk) forall (m :: * -> *) a. Monad m => a -> m a return HeaderStateHistory blk theirHeaderStateHistory' Left HeaderError blk vErr -> ChainSyncClientException -> m (HeaderStateHistory blk) forall (m' :: * -> *) x'. MonadThrow m' => ChainSyncClientException -> m' x' disconnect (ChainSyncClientException -> m (HeaderStateHistory blk)) -> ChainSyncClientException -> m (HeaderStateHistory blk) forall a b. (a -> b) -> a -> b $ Point blk -> HeaderError blk -> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientException forall blk. (BlockSupportsProtocol blk, ValidateEnvelope blk) => Point blk -> HeaderError blk -> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientException HeaderError Point blk hdrPoint HeaderError blk vErr (AnchoredFragment (Header blk) -> Our (Tip blk) ourTipFromChain AnchoredFragment (Header blk) ourFrag) Their (Tip blk) theirTip let theirFrag' :: AnchoredFragment (Header blk) theirFrag' = AnchoredFragment (Header blk) theirFrag AnchoredFragment (Header blk) -> Header blk -> AnchoredFragment (Header blk) forall v a b. Anchorable v a b => AnchoredSeq v a b -> b -> AnchoredSeq v a b :> Header blk hdr -- Advance the most recent intersection if we have the same header -- on our fragment too. This is cheaper than recomputing the -- intersection from scratch. mostRecentIntersection' :: Point blk mostRecentIntersection' | Just Header blk ourSuccessor <- Point (Header blk) -> AnchoredFragment (Header blk) -> Maybe (Header blk) forall block. HasHeader block => Point block -> AnchoredFragment block -> Maybe block AF.successorBlock (Point blk -> Point (Header blk) forall b b'. Coercible (HeaderHash b) (HeaderHash b') => Point b -> Point b' castPoint Point blk mostRecentIntersection) AnchoredFragment (Header blk) ourFrag , Header blk -> HeaderHash blk forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk headerHash Header blk ourSuccessor HeaderHash blk -> HeaderHash blk -> Bool forall a. Eq a => a -> a -> Bool == Header blk -> HeaderHash blk forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk headerHash Header blk hdr = Header blk -> Point blk forall blk. HasHeader (Header blk) => Header blk -> Point blk headerPoint Header blk hdr | Bool otherwise = Point blk mostRecentIntersection kis'' :: KnownIntersectionState blk kis'' = ConsensusConfig (BlockProtocol blk) -> KnownIntersectionState blk -> KnownIntersectionState blk forall blk. (HasHeader blk, HasHeader (Header blk), HasAnnTip blk, ConsensusProtocol (BlockProtocol blk), HasCallStack) => ConsensusConfig (BlockProtocol blk) -> KnownIntersectionState blk -> KnownIntersectionState blk assertKnownIntersectionInvariants (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk) forall blk. TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk) configConsensus TopLevelConfig blk cfg) (KnownIntersectionState blk -> KnownIntersectionState blk) -> KnownIntersectionState blk -> KnownIntersectionState blk forall a b. (a -> b) -> a -> b $ KnownIntersectionState :: forall blk. AnchoredFragment (Header blk) -> HeaderStateHistory blk -> AnchoredFragment (Header blk) -> Point blk -> KnownIntersectionState blk KnownIntersectionState { $sel:theirFrag:KnownIntersectionState :: AnchoredFragment (Header blk) theirFrag = AnchoredFragment (Header blk) theirFrag' , $sel:theirHeaderStateHistory:KnownIntersectionState :: HeaderStateHistory blk theirHeaderStateHistory = HeaderStateHistory blk theirHeaderStateHistory' , $sel:ourFrag:KnownIntersectionState :: AnchoredFragment (Header blk) ourFrag = AnchoredFragment (Header blk) ourFrag , $sel:mostRecentIntersection:KnownIntersectionState :: Point blk mostRecentIntersection = Point blk mostRecentIntersection' } STM m () -> m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m () -> m ()) -> STM m () -> m () forall a b. (a -> b) -> a -> b $ StrictTVar m (AnchoredFragment (Header blk)) -> AnchoredFragment (Header blk) -> STM m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => StrictTVar m a -> a -> STM m () writeTVar StrictTVar m (AnchoredFragment (Header blk)) varCandidate AnchoredFragment (Header blk) theirFrag' let slotNo :: SlotNo slotNo = Header blk -> SlotNo forall b. HasHeader b => b -> SlotNo blockSlot Header blk hdr STM m () -> m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m () -> m ()) -> STM m () -> m () forall a b. (a -> b) -> a -> b $ HeaderMetricsTracer m -> (SlotNo, Time) -> STM m () forall (m :: * -> *) a. Tracer m a -> a -> m () traceWith HeaderMetricsTracer m headerMetricsTracer (SlotNo slotNo, Time now) KnownIntersectionState blk -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) -> m (Consensus (ClientPipelinedStIdle n) blk m) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). NoThunks s => s -> Stateful m blk s st -> m (Consensus st blk m) continueWithState KnownIntersectionState blk kis'' (Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) -> m (Consensus (ClientPipelinedStIdle n) blk m) forall a b. (a -> b) -> a -> b $ MkPipelineDecision -> Nat n -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) forall (n :: N). MkPipelineDecision -> Nat n -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) nextStep MkPipelineDecision mkPipelineDecision Nat n n Their (Tip blk) theirTip rollBackward :: MkPipelineDecision -> Nat n -> Point blk -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) rollBackward :: MkPipelineDecision -> Nat n -> Point blk -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) rollBackward MkPipelineDecision mkPipelineDecision Nat n n Point blk rollBackPoint Their (Tip blk) theirTip = (KnownIntersectionState blk -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). (s -> m (Consensus st blk m)) -> Stateful m blk s st Stateful ((KnownIntersectionState blk -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)) -> (KnownIntersectionState blk -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) forall a b. (a -> b) -> a -> b $ \KnownIntersectionState { AnchoredFragment (Header blk) theirFrag :: AnchoredFragment (Header blk) $sel:theirFrag:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> AnchoredFragment (Header blk) theirFrag , HeaderStateHistory blk theirHeaderStateHistory :: HeaderStateHistory blk $sel:theirHeaderStateHistory:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> HeaderStateHistory blk theirHeaderStateHistory , AnchoredFragment (Header blk) ourFrag :: AnchoredFragment (Header blk) $sel:ourFrag:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> AnchoredFragment (Header blk) ourFrag , Point blk mostRecentIntersection :: Point blk $sel:mostRecentIntersection:KnownIntersectionState :: forall blk. KnownIntersectionState blk -> Point blk mostRecentIntersection } -> m (Consensus (ClientPipelinedStIdle n) blk m) -> m (Consensus (ClientPipelinedStIdle n) blk m) forall a. m a -> m a traceException (m (Consensus (ClientPipelinedStIdle n) blk m) -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> m (Consensus (ClientPipelinedStIdle n) blk m) -> m (Consensus (ClientPipelinedStIdle n) blk m) forall a b. (a -> b) -> a -> b $ do case Point blk -> (AnchoredFragment (Header blk), HeaderStateHistory blk) -> Maybe (AnchoredFragment (Header blk), HeaderStateHistory blk) forall blk. (BlockSupportsProtocol blk, HasAnnTip blk) => Point blk -> (AnchoredFragment (Header blk), HeaderStateHistory blk) -> Maybe (AnchoredFragment (Header blk), HeaderStateHistory blk) attemptRollback Point blk rollBackPoint (AnchoredFragment (Header blk) theirFrag, HeaderStateHistory blk theirHeaderStateHistory) of -- Remember that we use our current chain fragment as the starting -- point for the candidate's chain. Our fragment contained @k@ -- headers. At this point, the candidate fragment might have grown to -- more than @k@ or rolled back to less than @k@ headers. -- -- But now, it rolled back to some point that is not on the fragment, -- which means that it tried to roll back to some point before one of -- the last @k@ headers we initially started from. We could never -- switch to this fork anyway, so just disconnect. Furthermore, our -- current chain might have advanced in the meantime, so the point we -- would have to roll back to might have been much further back than -- @k@ blocks (> @k@ + the number of blocks we have advanced since -- starting syncing). -- -- INVARIANT: a candidate fragment contains @>=k@ headers (unless -- near genesis, in which case we mean the total number of blocks in -- the fragment) minus @r@ headers where @r <= k@. This ghost -- variable @r@ indicates the number of headers we temporarily -- rolled back. Such a rollback must always be followed by rolling -- forward @s@ new headers where @s >= r@. -- -- Thus, @k - r + s >= k@. Maybe (AnchoredFragment (Header blk), HeaderStateHistory blk) Nothing -> Nat n -> ChainSyncClientResult -> m (Consensus (ClientPipelinedStIdle n) blk m) forall (n :: N). Nat n -> ChainSyncClientResult -> m (Consensus (ClientPipelinedStIdle n) blk m) terminateAfterDrain Nat n n (ChainSyncClientResult -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> ChainSyncClientResult -> m (Consensus (ClientPipelinedStIdle n) blk m) forall a b. (a -> b) -> a -> b $ Point blk -> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult forall blk. BlockSupportsProtocol blk => Point blk -> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult RolledBackPastIntersection Point blk rollBackPoint (AnchoredFragment (Header blk) -> Our (Tip blk) ourTipFromChain AnchoredFragment (Header blk) ourFrag) Their (Tip blk) theirTip Just (AnchoredFragment (Header blk) theirFrag', HeaderStateHistory blk theirHeaderStateHistory') -> do -- We just rolled back to @intersection@, either our most recent -- intersection was after or at @intersection@, in which case -- @intersection@ becomes the new most recent intersection. -- -- But if the most recent intersection was /before/ @intersection@, -- then the most recent intersection doesn't change. let mostRecentIntersection' :: Point blk mostRecentIntersection' | Point (Header blk) -> AnchoredFragment (Header blk) -> Bool forall block. HasHeader block => Point block -> AnchoredFragment block -> Bool AF.withinFragmentBounds (Point blk -> Point (Header blk) forall b b'. Coercible (HeaderHash b) (HeaderHash b') => Point b -> Point b' castPoint Point blk rollBackPoint) AnchoredFragment (Header blk) ourFrag = Point blk rollBackPoint | Bool otherwise = Point blk mostRecentIntersection kis' :: KnownIntersectionState blk kis' = ConsensusConfig (BlockProtocol blk) -> KnownIntersectionState blk -> KnownIntersectionState blk forall blk. (HasHeader blk, HasHeader (Header blk), HasAnnTip blk, ConsensusProtocol (BlockProtocol blk), HasCallStack) => ConsensusConfig (BlockProtocol blk) -> KnownIntersectionState blk -> KnownIntersectionState blk assertKnownIntersectionInvariants (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk) forall blk. TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk) configConsensus TopLevelConfig blk cfg) (KnownIntersectionState blk -> KnownIntersectionState blk) -> KnownIntersectionState blk -> KnownIntersectionState blk forall a b. (a -> b) -> a -> b $ KnownIntersectionState :: forall blk. AnchoredFragment (Header blk) -> HeaderStateHistory blk -> AnchoredFragment (Header blk) -> Point blk -> KnownIntersectionState blk KnownIntersectionState { $sel:theirFrag:KnownIntersectionState :: AnchoredFragment (Header blk) theirFrag = AnchoredFragment (Header blk) theirFrag' , $sel:theirHeaderStateHistory:KnownIntersectionState :: HeaderStateHistory blk theirHeaderStateHistory = HeaderStateHistory blk theirHeaderStateHistory' , $sel:ourFrag:KnownIntersectionState :: AnchoredFragment (Header blk) ourFrag = AnchoredFragment (Header blk) ourFrag , $sel:mostRecentIntersection:KnownIntersectionState :: Point blk mostRecentIntersection = Point blk mostRecentIntersection' } STM m () -> m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m () -> m ()) -> STM m () -> m () forall a b. (a -> b) -> a -> b $ StrictTVar m (AnchoredFragment (Header blk)) -> AnchoredFragment (Header blk) -> STM m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => StrictTVar m a -> a -> STM m () writeTVar StrictTVar m (AnchoredFragment (Header blk)) varCandidate AnchoredFragment (Header blk) theirFrag' KnownIntersectionState blk -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) -> m (Consensus (ClientPipelinedStIdle n) blk m) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). NoThunks s => s -> Stateful m blk s st -> m (Consensus st blk m) continueWithState KnownIntersectionState blk kis' (Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) -> m (Consensus (ClientPipelinedStIdle n) blk m) forall a b. (a -> b) -> a -> b $ MkPipelineDecision -> Nat n -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) forall (n :: N). MkPipelineDecision -> Nat n -> Their (Tip blk) -> Stateful m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n) nextStep MkPipelineDecision mkPipelineDecision Nat n n Their (Tip blk) theirTip -- | Gracefully terminate the connection with the upstream node with the -- given result. terminate :: ChainSyncClientResult -> m (Consensus (ClientPipelinedStIdle 'Z) blk m) terminate :: ChainSyncClientResult -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) terminate ChainSyncClientResult res = do Tracer m (TraceChainSyncClientEvent blk) -> TraceChainSyncClientEvent blk -> m () forall (m :: * -> *) a. Tracer m a -> a -> m () traceWith Tracer m (TraceChainSyncClientEvent blk) tracer (ChainSyncClientResult -> TraceChainSyncClientEvent blk forall blk. ChainSyncClientResult -> TraceChainSyncClientEvent blk TraceTermination ChainSyncClientResult res) ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall (f :: * -> *) a. Applicative f => a -> f a pure (ChainSyncClientResult -> ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult forall a header point tip (m :: * -> *). a -> ClientPipelinedStIdle 'Z header point tip m a SendMsgDone ChainSyncClientResult res) -- | Same as 'terminate', but first 'drainThePipe'. terminateAfterDrain :: Nat n -> ChainSyncClientResult -> m (Consensus (ClientPipelinedStIdle n) blk m) terminateAfterDrain :: Nat n -> ChainSyncClientResult -> m (Consensus (ClientPipelinedStIdle n) blk m) terminateAfterDrain Nat n n ChainSyncClientResult result = () -> Stateful m blk () (ClientPipelinedStIdle n) -> m (Consensus (ClientPipelinedStIdle n) blk m) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). NoThunks s => s -> Stateful m blk s st -> m (Consensus st blk m) continueWithState () (Stateful m blk () (ClientPipelinedStIdle n) -> m (Consensus (ClientPipelinedStIdle n) blk m)) -> Stateful m blk () (ClientPipelinedStIdle n) -> m (Consensus (ClientPipelinedStIdle n) blk m) forall a b. (a -> b) -> a -> b $ Nat n -> Stateful m blk () (ClientPipelinedStIdle 'Z) -> Stateful m blk () (ClientPipelinedStIdle n) forall s (n :: N). NoThunks s => Nat n -> Stateful m blk s (ClientPipelinedStIdle 'Z) -> Stateful m blk s (ClientPipelinedStIdle n) drainThePipe Nat n n (Stateful m blk () (ClientPipelinedStIdle 'Z) -> Stateful m blk () (ClientPipelinedStIdle n)) -> Stateful m blk () (ClientPipelinedStIdle 'Z) -> Stateful m blk () (ClientPipelinedStIdle n) forall a b. (a -> b) -> a -> b $ (() -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> Stateful m blk () (ClientPipelinedStIdle 'Z) forall (m :: * -> *) blk s (st :: * -> * -> * -> (* -> *) -> * -> *). (s -> m (Consensus st blk m)) -> Stateful m blk s st Stateful ((() -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> Stateful m blk () (ClientPipelinedStIdle 'Z)) -> (() -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> Stateful m blk () (ClientPipelinedStIdle 'Z) forall a b. (a -> b) -> a -> b $ m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> () -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall a b. a -> b -> a const (m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> () -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)) -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) -> () -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) forall a b. (a -> b) -> a -> b $ ChainSyncClientResult -> m (ClientPipelinedStIdle 'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult) terminate ChainSyncClientResult result -- | Disconnect from the upstream node by throwing the given exception. -- The cleanup is handled in 'bracketChainSyncClient'. disconnect :: forall m' x'. MonadThrow m' => ChainSyncClientException -> m' x' disconnect :: ChainSyncClientException -> m' x' disconnect = ChainSyncClientException -> m' x' forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a throwIO -- | Trace any 'ChainSyncClientException' if thrown. traceException :: m a -> m a traceException :: m a -> m a traceException m a m = m a m m a -> (ChainSyncClientException -> m a) -> m a forall (m :: * -> *) e a. (MonadCatch m, Exception e) => m a -> (e -> m a) -> m a `catch` \(ChainSyncClientException e :: ChainSyncClientException) -> do Tracer m (TraceChainSyncClientEvent blk) -> TraceChainSyncClientEvent blk -> m () forall (m :: * -> *) a. Tracer m a -> a -> m () traceWith Tracer m (TraceChainSyncClientEvent blk) tracer (TraceChainSyncClientEvent blk -> m ()) -> TraceChainSyncClientEvent blk -> m () forall a b. (a -> b) -> a -> b $ ChainSyncClientException -> TraceChainSyncClientEvent blk forall blk. ChainSyncClientException -> TraceChainSyncClientEvent blk TraceException ChainSyncClientException e ChainSyncClientException -> m a forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a throwIO ChainSyncClientException e ourTipFromChain :: AnchoredFragment (Header blk) -> Our (Tip blk) ourTipFromChain :: AnchoredFragment (Header blk) -> Our (Tip blk) ourTipFromChain = Tip blk -> Our (Tip blk) forall a. a -> Our a Our (Tip blk -> Our (Tip blk)) -> (AnchoredFragment (Header blk) -> Tip blk) -> AnchoredFragment (Header blk) -> Our (Tip blk) forall b c a. (b -> c) -> (a -> b) -> a -> c . Anchor (Header blk) -> Tip blk forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Tip b AF.anchorToTip (Anchor (Header blk) -> Tip blk) -> (AnchoredFragment (Header blk) -> Anchor (Header blk)) -> AnchoredFragment (Header blk) -> Tip blk forall b c a. (b -> c) -> (a -> b) -> a -> c . AnchoredFragment (Header blk) -> Anchor (Header blk) forall v a b. Anchorable v a b => AnchoredSeq v a b -> a AF.headAnchor -- Recent offsets -- -- These offsets are used to find an intersection point between our chain -- and the upstream node's. We use the fibonacci sequence to try blocks -- closer to our tip, and fewer blocks further down the chain. It is -- important that this sequence constains at least a point @k@ back: if no -- intersection can be found at most @k@ back, then this is not a peer -- that we can sync with (since we will never roll back more than @k). -- -- For @k = 2160@, this evaluates to -- -- > [0,1,2,3,5,8,13,21,34,55,89,144,233,377,610,987,1597,2160] -- -- For @k = 5@ (during testing), this evaluates to -- -- > [0,1,2,3,5] -- -- In case the fragment contains less than @k@ blocks, we use the length -- of the fragment as @k@. This ensures that the oldest rollback point is -- selected. offsets :: Word64 -> [Word64] offsets :: Word64 -> [Word64] offsets Word64 maxOffset = [Word64 0] [Word64] -> [Word64] -> [Word64] forall a. [a] -> [a] -> [a] ++ (Word64 -> Bool) -> [Word64] -> [Word64] forall a. (a -> Bool) -> [a] -> [a] takeWhile (Word64 -> Word64 -> Bool forall a. Ord a => a -> a -> Bool < Word64 l) [Word64 -> Word64 fib Word64 n | Word64 n <- [Word64 2..]] [Word64] -> [Word64] -> [Word64] forall a. [a] -> [a] -> [a] ++ [Word64 l] where l :: Word64 l = Word64 k Word64 -> Word64 -> Word64 forall a. Ord a => a -> a -> a `min` Word64 maxOffset k :: Word64 k :: Word64 k = SecurityParam -> Word64 maxRollbacks (SecurityParam -> Word64) -> SecurityParam -> Word64 forall a b. (a -> b) -> a -> b $ TopLevelConfig blk -> SecurityParam forall blk. ConsensusProtocol (BlockProtocol blk) => TopLevelConfig blk -> SecurityParam configSecurityParam TopLevelConfig blk cfg attemptRollback :: ( BlockSupportsProtocol blk , HasAnnTip blk ) => Point blk -> (AnchoredFragment (Header blk), HeaderStateHistory blk) -> Maybe (AnchoredFragment (Header blk), HeaderStateHistory blk) attemptRollback :: Point blk -> (AnchoredFragment (Header blk), HeaderStateHistory blk) -> Maybe (AnchoredFragment (Header blk), HeaderStateHistory blk) attemptRollback Point blk rollBackPoint (AnchoredFragment (Header blk) frag, HeaderStateHistory blk state) = do AnchoredFragment (Header blk) frag' <- Point (Header blk) -> AnchoredFragment (Header blk) -> Maybe (AnchoredFragment (Header blk)) forall block. HasHeader block => Point block -> AnchoredFragment block -> Maybe (AnchoredFragment block) AF.rollback (Point blk -> Point (Header blk) forall b b'. Coercible (HeaderHash b) (HeaderHash b') => Point b -> Point b' castPoint Point blk rollBackPoint) AnchoredFragment (Header blk) frag HeaderStateHistory blk state' <- Point blk -> HeaderStateHistory blk -> Maybe (HeaderStateHistory blk) forall blk. HasAnnTip blk => Point blk -> HeaderStateHistory blk -> Maybe (HeaderStateHistory blk) HeaderStateHistory.rewind Point blk rollBackPoint HeaderStateHistory blk state (AnchoredFragment (Header blk), HeaderStateHistory blk) -> Maybe (AnchoredFragment (Header blk), HeaderStateHistory blk) forall (m :: * -> *) a. Monad m => a -> m a return (AnchoredFragment (Header blk) frag', HeaderStateHistory blk state') -- | Watch the invalid block checker function for changes (using its -- fingerprint). Whenever it changes, i.e., a new invalid block is detected, -- check whether the current candidate fragment contains any header that is -- invalid, if so, disconnect by throwing an 'InvalidBlock' exception. -- -- Note that it is possible, yet unlikely, that the candidate fragment -- contains a header that corresponds to an invalid block, but before we have -- discovered this (after downloading and validating the block), the upstream -- node could have rolled back such that its candidate chain no longer -- contains the invalid block, in which case we do not disconnect from it. -- -- The cost of this check is \( O(cand * check) \) where /cand/ is the size of -- the candidate fragment and /check/ is the cost of checking whether a block -- is invalid (typically \( O(\log(invalid)) \) where /invalid/ is the number -- of invalid blocks). invalidBlockRejector :: forall m blk. ( IOLike m , LedgerSupportsProtocol blk ) => Tracer m (TraceChainSyncClientEvent blk) -> NodeToNodeVersion -> STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) -- ^ Get the invalid block checker -> STM m (AnchoredFragment (Header blk)) -> Watcher m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) Fingerprint invalidBlockRejector :: Tracer m (TraceChainSyncClientEvent blk) -> NodeToNodeVersion -> STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) -> STM m (AnchoredFragment (Header blk)) -> Watcher m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) Fingerprint invalidBlockRejector Tracer m (TraceChainSyncClientEvent blk) tracer NodeToNodeVersion version STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) getIsInvalidBlock STM m (AnchoredFragment (Header blk)) getCandidate = Watcher :: forall (m :: * -> *) a fp. (a -> fp) -> Maybe fp -> (a -> m ()) -> STM m a -> Watcher m a fp Watcher { wFingerprint :: WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> Fingerprint wFingerprint = WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> Fingerprint forall a. WithFingerprint a -> Fingerprint getFingerprint , wInitial :: Maybe Fingerprint wInitial = Maybe Fingerprint forall a. Maybe a Nothing , wNotify :: WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> m () wNotify = (HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> m () checkInvalid ((HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> m ()) -> (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> m () 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 , wReader :: STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) wReader = STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) getIsInvalidBlock } where checkInvalid :: (HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> m () checkInvalid :: (HeaderHash blk -> Maybe (InvalidBlockReason blk)) -> m () checkInvalid HeaderHash blk -> Maybe (InvalidBlockReason blk) isInvalidBlock = do AnchoredFragment (Header blk) theirFrag <- STM m (AnchoredFragment (Header blk)) -> m (AnchoredFragment (Header blk)) forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically STM m (AnchoredFragment (Header blk)) getCandidate -- The invalid block is likely to be a more recent block, so check from -- newest to oldest. -- -- As of block diffusion pipelining, their tip header might be tentative. -- Since they do not yet have a way to explicitly say whether it is -- tentative, we assume it is and therefore skip their tip here. TODO once -- it's explicit, only skip it if it's annotated as tentative ((Header blk, InvalidBlockReason blk) -> m ()) -> Maybe (Header blk, InvalidBlockReason blk) -> m () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ ((Header blk -> InvalidBlockReason blk -> m ()) -> (Header blk, InvalidBlockReason blk) -> m () forall a b c. (a -> b -> c) -> (a, b) -> c uncurry Header blk -> InvalidBlockReason blk -> m () disconnect) (Maybe (Header blk, InvalidBlockReason blk) -> m ()) -> Maybe (Header blk, InvalidBlockReason blk) -> m () forall a b. (a -> b) -> a -> b $ (Header blk -> Maybe (Header blk, InvalidBlockReason blk)) -> [Header blk] -> Maybe (Header blk, InvalidBlockReason blk) forall a b (f :: * -> *). Foldable f => (a -> Maybe b) -> f a -> Maybe b firstJust (\Header blk hdr -> (Header blk hdr,) (InvalidBlockReason blk -> (Header blk, InvalidBlockReason blk)) -> Maybe (InvalidBlockReason blk) -> Maybe (Header blk, InvalidBlockReason blk) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> HeaderHash blk -> Maybe (InvalidBlockReason blk) isInvalidBlock (Header blk -> HeaderHash blk forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk headerHash Header blk hdr)) ( (case NodeToNodeVersion -> WhetherReceivingTentativeBlocks isPipeliningEnabled NodeToNodeVersion version of WhetherReceivingTentativeBlocks ReceivingTentativeBlocks -> Int -> [Header blk] -> [Header blk] forall a. Int -> [a] -> [a] drop Int 1 WhetherReceivingTentativeBlocks NotReceivingTentativeBlocks -> [Header blk] -> [Header blk] forall a. a -> a id) ([Header blk] -> [Header blk]) -> [Header blk] -> [Header blk] forall a b. (a -> b) -> a -> b $ AnchoredFragment (Header blk) -> [Header blk] forall v a b. AnchoredSeq v a b -> [b] AF.toNewestFirst AnchoredFragment (Header blk) theirFrag ) disconnect :: Header blk -> InvalidBlockReason blk -> m () disconnect :: Header blk -> InvalidBlockReason blk -> m () disconnect Header blk invalidHeader InvalidBlockReason blk reason = do let ex :: ChainSyncClientException ex = Point blk -> HeaderHash blk -> InvalidBlockReason blk -> ChainSyncClientException forall blk. LedgerSupportsProtocol blk => Point blk -> HeaderHash blk -> InvalidBlockReason blk -> ChainSyncClientException InvalidBlock (Header blk -> Point blk forall blk. HasHeader (Header blk) => Header blk -> Point blk headerPoint Header blk invalidHeader) (Header blk -> HeaderHash blk forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk headerHash Header blk invalidHeader) InvalidBlockReason blk reason Tracer m (TraceChainSyncClientEvent blk) -> TraceChainSyncClientEvent blk -> m () forall (m :: * -> *) a. Tracer m a -> a -> m () traceWith Tracer m (TraceChainSyncClientEvent blk) tracer (TraceChainSyncClientEvent blk -> m ()) -> TraceChainSyncClientEvent blk -> m () forall a b. (a -> b) -> a -> b $ ChainSyncClientException -> TraceChainSyncClientEvent blk forall blk. ChainSyncClientException -> TraceChainSyncClientEvent blk TraceException ChainSyncClientException ex ChainSyncClientException -> m () forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a throwIO ChainSyncClientException ex -- | Auxiliary data type used as an intermediary result in 'rollForward'. data IntersectCheck blk = -- | The upstream chain no longer intersects with our current chain because -- our current chain changed in the background. NoLongerIntersects -- | The upstream chain still intersects with our chain, return the -- resulting 'KnownIntersectionState' and the 'LedgerView' corresponding to -- the header 'rollForward' received. | Intersects (KnownIntersectionState blk) (Ticked (LedgerView (BlockProtocol blk))) {------------------------------------------------------------------------------- Explicit state -------------------------------------------------------------------------------} -- | Make the state maintained by the chain sync client explicit -- -- The chain sync client contains of a bunch of functions that basically look -- like "do some network stuff, compute some stuff, and then continue with -- such-and-such a new state". We want to make sure to keep that state in NF -- at all times, but since we don't use a TVar to store it, we cannot reuse -- the existing infrastructure for checking TVars for NF. Instead, we make -- the state explicit in the types and do the check in 'continueWithState'. newtype Stateful m blk s st = Stateful (s -> m (Consensus st blk m)) continueWithState :: forall m blk s st. NoThunks s => s -> Stateful m blk s st -> m (Consensus st blk m) continueWithState :: s -> Stateful m blk s st -> m (Consensus st blk m) continueWithState !s s (Stateful s -> m (Consensus st blk m) f) = Maybe String -> m (Consensus st blk m) -> m (Consensus st blk m) forall a. HasCallStack => Maybe String -> a -> a checkInvariant (ThunkInfo -> String forall a. Show a => a -> String show (ThunkInfo -> String) -> Maybe ThunkInfo -> Maybe String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> s -> Maybe ThunkInfo forall a. NoThunks a => a -> Maybe ThunkInfo unsafeNoThunks s s) (m (Consensus st blk m) -> m (Consensus st blk m)) -> m (Consensus st blk m) -> m (Consensus st blk m) forall a b. (a -> b) -> a -> b $ s -> m (Consensus st blk m) f s s {------------------------------------------------------------------------------- Return value -------------------------------------------------------------------------------} -- | The Chain sync client only _gracefully_ terminates when the upstream node's -- chain is not interesting (e.g., forked off too far in the past). By -- gracefully terminating, the network layer can keep the other mini-protocols -- connect to the same upstream node running. -- -- For example, a relay node will often receive connections from nodes syncing -- from scratch or an old chain. Since these nodes have a chain that is shorter -- than the relay node's chain, it's useless for the relay node to run the -- client-side of the chain sync protocol. However, the other direction of the -- protocol, and, e.g., the transaction submission protocol, should keep -- running. data ChainSyncClientResult = -- | The server we're connecting to forked more than @k@ blocks ago. forall blk. BlockSupportsProtocol blk => ForkTooDeep (Point blk) -- ^ Intersection (Our (Tip blk)) (Their (Tip blk)) -- | Our chain changed such that it no longer intersects with the -- candidate's fragment, and asking for a new intersection did not yield -- one. | forall blk. BlockSupportsProtocol blk => NoMoreIntersection (Our (Tip blk)) (Their (Tip blk)) -- | We were asked to roll back past the anchor point of the candidate's -- fragment. This means the candidate chain no longer forks off within -- @k@, making it impossible to switch to. | forall blk. BlockSupportsProtocol blk => RolledBackPastIntersection (Point blk) -- ^ Point asked to roll back to (Our (Tip blk)) (Their (Tip blk)) -- | We were asked to terminate via the 'ControlMessageSTM' | AskedToTerminate deriving instance Show ChainSyncClientResult instance Eq ChainSyncClientResult where ForkTooDeep (Point blk a :: Point blk) Our (Tip blk) b Their (Tip blk) c == :: ChainSyncClientResult -> ChainSyncClientResult -> Bool == ForkTooDeep (Point blk a' :: Point blk') Our (Tip blk) b' Their (Tip blk) c' = case (Typeable blk, Typeable blk) => Maybe (blk :~: blk) forall k (a :: k) (b :: k). (Typeable a, Typeable b) => Maybe (a :~: b) eqT @blk @blk' of Maybe (blk :~: blk) Nothing -> Bool False Just blk :~: blk Refl -> (Point blk a, Our (Tip blk) b, Their (Tip blk) c) (Point blk, Our (Tip blk), Their (Tip blk)) -> (Point blk, Our (Tip blk), Their (Tip blk)) -> Bool forall a. Eq a => a -> a -> Bool == (Point blk Point blk a', Our (Tip blk) Our (Tip blk) b', Their (Tip blk) Their (Tip blk) c') ForkTooDeep{} == ChainSyncClientResult _ = Bool False NoMoreIntersection (Our (Tip blk) a :: Our (Tip blk)) Their (Tip blk) b == NoMoreIntersection (Our (Tip blk) a' :: Our (Tip blk')) Their (Tip blk) b' = case (Typeable blk, Typeable blk) => Maybe (blk :~: blk) forall k (a :: k) (b :: k). (Typeable a, Typeable b) => Maybe (a :~: b) eqT @blk @blk' of Maybe (blk :~: blk) Nothing -> Bool False Just blk :~: blk Refl -> (Our (Tip blk) a, Their (Tip blk) b) (Our (Tip blk), Their (Tip blk)) -> (Our (Tip blk), Their (Tip blk)) -> Bool forall a. Eq a => a -> a -> Bool == (Our (Tip blk) Our (Tip blk) a', Their (Tip blk) Their (Tip blk) b') NoMoreIntersection{} == ChainSyncClientResult _ = Bool False RolledBackPastIntersection (Point blk a :: Point blk) Our (Tip blk) b Their (Tip blk) c == RolledBackPastIntersection (Point blk a' :: Point blk') Our (Tip blk) b' Their (Tip blk) c' = case (Typeable blk, Typeable blk) => Maybe (blk :~: blk) forall k (a :: k) (b :: k). (Typeable a, Typeable b) => Maybe (a :~: b) eqT @blk @blk' of Maybe (blk :~: blk) Nothing -> Bool False Just blk :~: blk Refl -> (Point blk a, Our (Tip blk) b, Their (Tip blk) c) (Point blk, Our (Tip blk), Their (Tip blk)) -> (Point blk, Our (Tip blk), Their (Tip blk)) -> Bool forall a. Eq a => a -> a -> Bool == (Point blk Point blk a', Our (Tip blk) Our (Tip blk) b', Their (Tip blk) Their (Tip blk) c') RolledBackPastIntersection{} == ChainSyncClientResult _ = Bool False ChainSyncClientResult AskedToTerminate == ChainSyncClientResult AskedToTerminate = Bool True ChainSyncClientResult AskedToTerminate == ChainSyncClientResult _ = Bool False {------------------------------------------------------------------------------- Exception -------------------------------------------------------------------------------} -- | When the upstream node violates the protocol or exhibits malicious -- behaviour, e.g., serving an invalid header or a header corresponding to a -- known invalid block, we throw an exception to disconnect. This will bring -- down all miniprotocols in both directions with that node. data ChainSyncClientException = -- | Header validation threw an error. forall blk. (BlockSupportsProtocol blk, ValidateEnvelope blk) => HeaderError (Point blk) -- ^ Invalid header (HeaderError blk) (Our (Tip blk)) (Their (Tip blk)) -- | We send the upstream node a bunch of points from a chain fragment and -- the upstream node responded with an intersection point that is not on -- our chain fragment, and thus not among the points we sent. -- -- We store the intersection point the upstream node sent us. | forall blk. BlockSupportsProtocol blk => InvalidIntersection (Point blk) -- ^ Intersection (Our (Tip blk)) (Their (Tip blk)) -- | The received header to roll forward doesn't fit onto the previous -- one. -- -- The first 'ChainHash' is the previous hash of the received header and -- the second 'ChainHash' is that of the previous one. | forall blk. BlockSupportsProtocol blk => DoesntFit (ChainHash blk) -- ^ Received hash (ChainHash blk) -- ^ Expected hash (Our (Tip blk)) (Their (Tip blk)) -- | The upstream node's chain contained a block that we know is invalid. | forall blk. LedgerSupportsProtocol blk => InvalidBlock (Point blk) -- ^ Block that triggered the validity check. (HeaderHash blk) -- ^ Invalid block. If pipelining was negotiated, this can be -- different from the previous argument. (InvalidBlockReason blk) deriving instance Show ChainSyncClientException instance Eq ChainSyncClientException where HeaderError (Point blk a :: Point blk) HeaderError blk b Our (Tip blk) c Their (Tip blk) d == :: ChainSyncClientException -> ChainSyncClientException -> Bool == HeaderError (Point blk a' :: Point blk') HeaderError blk b' Our (Tip blk) c' Their (Tip blk) d' = case (Typeable blk, Typeable blk) => Maybe (blk :~: blk) forall k (a :: k) (b :: k). (Typeable a, Typeable b) => Maybe (a :~: b) eqT @blk @blk' of Maybe (blk :~: blk) Nothing -> Bool False Just blk :~: blk Refl -> (Point blk a, HeaderError blk b, Our (Tip blk) c, Their (Tip blk) d) (Point blk, HeaderError blk, Our (Tip blk), Their (Tip blk)) -> (Point blk, HeaderError blk, Our (Tip blk), Their (Tip blk)) -> Bool forall a. Eq a => a -> a -> Bool == (Point blk Point blk a', HeaderError blk HeaderError blk b', Our (Tip blk) Our (Tip blk) c', Their (Tip blk) Their (Tip blk) d') HeaderError{} == ChainSyncClientException _ = Bool False InvalidIntersection (Point blk a :: Point blk) Our (Tip blk) b Their (Tip blk) c == InvalidIntersection (Point blk a' :: Point blk') Our (Tip blk) b' Their (Tip blk) c' = case (Typeable blk, Typeable blk) => Maybe (blk :~: blk) forall k (a :: k) (b :: k). (Typeable a, Typeable b) => Maybe (a :~: b) eqT @blk @blk' of Maybe (blk :~: blk) Nothing -> Bool False Just blk :~: blk Refl -> (Point blk a, Our (Tip blk) b, Their (Tip blk) c) (Point blk, Our (Tip blk), Their (Tip blk)) -> (Point blk, Our (Tip blk), Their (Tip blk)) -> Bool forall a. Eq a => a -> a -> Bool == (Point blk Point blk a', Our (Tip blk) Our (Tip blk) b', Their (Tip blk) Their (Tip blk) c') InvalidIntersection{} == ChainSyncClientException _ = Bool False DoesntFit (ChainHash blk a :: ChainHash blk) ChainHash blk b Our (Tip blk) c Their (Tip blk) d == DoesntFit (ChainHash blk a' :: ChainHash blk') ChainHash blk b' Our (Tip blk) c' Their (Tip blk) d' = case (Typeable blk, Typeable blk) => Maybe (blk :~: blk) forall k (a :: k) (b :: k). (Typeable a, Typeable b) => Maybe (a :~: b) eqT @blk @blk' of Maybe (blk :~: blk) Nothing -> Bool False Just blk :~: blk Refl -> (ChainHash blk a, ChainHash blk b, Our (Tip blk) c, Their (Tip blk) d) (ChainHash blk, ChainHash blk, Our (Tip blk), Their (Tip blk)) -> (ChainHash blk, ChainHash blk, Our (Tip blk), Their (Tip blk)) -> Bool forall a. Eq a => a -> a -> Bool == (ChainHash blk ChainHash blk a', ChainHash blk ChainHash blk b', Our (Tip blk) Our (Tip blk) c', Their (Tip blk) Their (Tip blk) d') DoesntFit{} == ChainSyncClientException _ = Bool False InvalidBlock (Point blk a :: Point blk) HeaderHash blk b InvalidBlockReason blk c == InvalidBlock (Point blk a' :: Point blk') HeaderHash blk b' InvalidBlockReason blk c' = case (Typeable blk, Typeable blk) => Maybe (blk :~: blk) forall k (a :: k) (b :: k). (Typeable a, Typeable b) => Maybe (a :~: b) eqT @blk @blk' of Maybe (blk :~: blk) Nothing -> Bool False Just blk :~: blk Refl -> (Point blk a, HeaderHash blk b, InvalidBlockReason blk c) (Point blk, HeaderHash blk, InvalidBlockReason blk) -> (Point blk, HeaderHash blk, InvalidBlockReason blk) -> Bool forall a. Eq a => a -> a -> Bool == (Point blk Point blk a', HeaderHash blk HeaderHash blk b', InvalidBlockReason blk InvalidBlockReason blk c') InvalidBlock{} == ChainSyncClientException _ = Bool False instance Exception ChainSyncClientException {------------------------------------------------------------------------------- TODO #221: Implement genesis Genesis in paper: When we compare a candidate to our own chain, and that candidate forks off more than k in the past, we compute the intersection point between that candidate and our chain, select s slots from both chains, and compare the number of blocks within those s slots. If the candidate has more blocks in those s slots, we prefer the candidate, otherwise we stick with our own chain. Genesis as we will implement it: * We decide we are in genesis mode if the head of our chain is more than @k@ blocks behind the blockchain time. We will have to approximate this as @k/f@ /slots/ behind the blockchain time time. * In this situation, we must make sure we have a sufficient number of upstream nodes "and collect chains from all of them" * We still never consider chains that would require /us/ to rollback more than k blocks. * In order to compare two candidates, we compute the intersection point of X of those two candidates and compare the density at point X. Scribbled notes during meeting with Duncan: geensis mode: compare clock to our chain do we have enough peers? still only interested in chains that don't fork more than k from our own chain downloading headers from a /single/ node, download at least s headers inform /other/ peers: "here is a point on our chain" if all agree ("intersection imporved") -- all peers agree avoid downloading tons of headers /if/ there is a difference, get s headers from the peer who disagrees, pick the denser one, and ignore the other PROBLEM: what if the denser node has invalid block bodies?? -------------------------------------------------------------------------------} {------------------------------------------------------------------------------- Trace events -------------------------------------------------------------------------------} -- | Events traced by the Chain Sync Client. data TraceChainSyncClientEvent blk = TraceDownloadedHeader (Header blk) -- ^ While following a candidate chain, we rolled forward by downloading a -- header. | TraceRolledBack (Point blk) -- ^ While following a candidate chain, we rolled back to the given point. | TraceFoundIntersection (Point blk) (Our (Tip blk)) (Their (Tip blk)) -- ^ We found an intersection between our chain fragment and the -- candidate's chain. | TraceException ChainSyncClientException -- ^ An exception was thrown by the Chain Sync Client. | TraceTermination ChainSyncClientResult -- ^ The client has terminated. deriving instance ( BlockSupportsProtocol blk , Eq (Header blk) ) => Eq (TraceChainSyncClientEvent blk) deriving instance ( BlockSupportsProtocol blk , Show (Header blk) ) => Show (TraceChainSyncClientEvent blk)