@@ -118,7 +118,8 @@ import Ouroboros.Consensus.Protocol.Abstract
118118import Ouroboros.Consensus.Storage.ChainDB (ChainDB )
119119import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
120120import Ouroboros.Consensus.Util
121- import Ouroboros.Consensus.Util.AnchoredFragment (cross )
121+ import Ouroboros.Consensus.Util.AnchoredFragment (cross ,
122+ preferAnchoredCandidate )
122123import Ouroboros.Consensus.Util.Assert (assertWithMsg )
123124import Ouroboros.Consensus.Util.EarlyExit (WithEarlyExit , exitEarly )
124125import qualified Ouroboros.Consensus.Util.EarlyExit as EarlyExit
@@ -1641,7 +1642,8 @@ checkKnownInvalid cfgEnv dynEnv intEnv hdr = case scrutinee of
16411642-- Finally, the client will block on the intersection a second time, if
16421643-- necessary, since it's possible for a ledger state to determine the slot's
16431644-- onset's timestamp without also determining the slot's 'LedgerView'. During
1644- -- this pause, the LoP bucket is paused.
1645+ -- this pause, the LoP bucket is paused. If we need to block and their fragment
1646+ -- is not preferrable to ours, we disconnect.
16451647checkTime ::
16461648 forall m blk arrival judgment .
16471649 ( IOLike m
@@ -1750,10 +1752,43 @@ checkTime cfgEnv dynEnv intEnv =
17501752 )
17511753 $ getPastLedger mostRecentIntersection
17521754 case prj lst of
1753- Nothing -> retry
1755+ Nothing -> do
1756+ checkPreferTheirsOverOurs kis'
1757+ retry
17541758 Just ledgerView ->
17551759 return $ return $ Intersects kis' ledgerView
17561760
1761+ -- Note [Candidate comparing beyond the forecast horizon]
1762+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1763+ --
1764+ -- When a header is beyond the forecast horizon and their fragment is not
1765+ -- preferrable to our selection (ourFrag), then we disconnect, as we will
1766+ -- never end up selecting it.
1767+ --
1768+ -- In the context of Genesis, one can think of the candidate losing a
1769+ -- density comparison against the selection. See the Genesis documentation
1770+ -- for why this check is necessary.
1771+ --
1772+ -- In particular, this means that we will disconnect from peers who offer us
1773+ -- a chain containing a slot gap larger than a forecast window.
1774+ checkPreferTheirsOverOurs :: KnownIntersectionState blk -> STM m ()
1775+ checkPreferTheirsOverOurs kis
1776+ | -- Precondition is fulfilled as ourFrag and theirFrag intersect by
1777+ -- construction.
1778+ preferAnchoredCandidate (configBlock cfg) ourFrag theirFrag
1779+ = pure ()
1780+ | otherwise
1781+ = throwSTM $ CandidateTooSparse
1782+ mostRecentIntersection
1783+ (ourTipFromChain ourFrag)
1784+ (theirTipFromChain theirFrag)
1785+ where
1786+ KnownIntersectionState {
1787+ mostRecentIntersection
1788+ , ourFrag
1789+ , theirFrag
1790+ } = kis
1791+
17571792 -- Returns 'Nothing' if the ledger state cannot forecast the ledger view
17581793 -- that far into the future.
17591794 projectLedgerView ::
@@ -1938,6 +1973,12 @@ ourTipFromChain ::
19381973 -> Our (Tip blk )
19391974ourTipFromChain = Our . AF. anchorToTip . AF. headAnchor
19401975
1976+ theirTipFromChain ::
1977+ HasHeader (Header blk )
1978+ => AnchoredFragment (Header blk )
1979+ -> Their (Tip blk )
1980+ theirTipFromChain = Their . AF. anchorToTip . AF. headAnchor
1981+
19411982-- | A type-legos auxillary function used in 'readLedgerState'.
19421983castM :: Monad m => m (WithEarlyExit m x ) -> WithEarlyExit m x
19431984castM = join . EarlyExit. lift
@@ -2161,6 +2202,14 @@ data ChainSyncClientException =
21612202 -- different from the previous argument.
21622203 (ExtValidationError blk )
21632204 -- ^ The upstream node's chain contained a block that we know is invalid.
2205+ |
2206+ forall blk . BlockSupportsProtocol blk =>
2207+ CandidateTooSparse
2208+ (Point blk ) -- ^ Intersection
2209+ (Our (Tip blk ))
2210+ (Their (Tip blk ))
2211+ -- ^ The upstream node's chain was so sparse that it was worse than our
2212+ -- selection despite being blocked on the forecast horizon.
21642213 |
21652214 InFutureHeaderExceedsClockSkew ! InFutureCheck. HeaderArrivalException
21662215 -- ^ A header arrived from the far future.
@@ -2196,6 +2245,12 @@ instance Eq ChainSyncClientException where
21962245 | Just Refl <- eqT @ blk @ blk'
21972246 = (a, b, c) == (a', b', c')
21982247
2248+ (==)
2249+ (CandidateTooSparse (a :: Point blk ) b c )
2250+ (CandidateTooSparse (a' :: Point blk' ) b' c')
2251+ | Just Refl <- eqT @ blk @ blk'
2252+ = (a, b, c) == (a', b', c')
2253+
21992254 (==)
22002255 (InFutureHeaderExceedsClockSkew a )
22012256 (InFutureHeaderExceedsClockSkew a')
@@ -2219,6 +2274,7 @@ instance Eq ChainSyncClientException where
22192274 HeaderError {} == _ = False
22202275 InvalidIntersection {} == _ = False
22212276 InvalidBlock {} == _ = False
2277+ CandidateTooSparse {} == _ = False
22222278 InFutureHeaderExceedsClockSkew {} == _ = False
22232279 HistoricityError {} == _ = False
22242280 EmptyBucket == _ = False
0 commit comments