ChainSync client: disconnect if stuck and not better than selection

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs

@@ -18,7 +18,7 @@ import           Control.Monad.IOSim (IOSim, runSimStrictShutdown)
 import           Control.Tracer (debugTracer, traceWith)
 import           Data.Maybe (mapMaybe)
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
-                     (ChainSyncClientException (DensityTooLow, EmptyBucket))
+                     (ChainSyncClientException (..))
 import           Ouroboros.Consensus.Util.Condense
 import           Ouroboros.Consensus.Util.IOLike (Exception, fromException)
 import           Ouroboros.Network.Driver.Limits
@@ -124,6 +124,7 @@ forAllGenesisTest generator schedulerConfig shrinker mkProperty =
       | Just DensityTooLow         <- e = true
       | Just (ExceededTimeLimit _) <- e = true
       | Just AsyncCancelled        <- e = true
+      | Just CandidateTooSparse{}  <- e = true
       | otherwise = counterexample
         ("Encountered unexpected exception: " ++ show exn)
         False

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Genesis/Governor.hs

@@ -358,20 +358,14 @@ densityDisconnect (GenesisWindow sgen) (SecurityParam k) states candidateSuffixe
                              , upperBound = ub0
                              , hasBlockAfter = hasBlockAfter0
                              , idling = idling0
-                             }) ->
-      -- If the density is 0, the peer should be disconnected. This affects
-      -- ChainSync jumping, where genesis windows with no headers prevent jumps
-      -- from happening.
-      if ub0 == 0 then pure peer0 else do
+                             }) -> do
       (_peer1, DensityBounds {clippedFragment = frag1, offersMoreThanK, lowerBound = lb1 }) <-
         densityBounds
       -- Don't disconnect peer0 if it sent no headers after the intersection yet
       -- and it is not idling.
       --
       -- See Note [Chain disagreement]
       --
-      -- Note: hasBlockAfter0 is False if frag0 is empty and ub0>0.
-      -- But we leave it here as a reminder that we care about it.
       guard $ idling0 || not (AF.null frag0) || hasBlockAfter0
       -- ensure that the two peer fragments don't share any
       -- headers after the LoE

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs

@@ -113,7 +113,8 @@ import           Ouroboros.Consensus.Storage.ChainDB (ChainDB,
                      InvalidBlockReason)
 import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
 import           Ouroboros.Consensus.Util
-import           Ouroboros.Consensus.Util.AnchoredFragment (cross)
+import           Ouroboros.Consensus.Util.AnchoredFragment (cross,
+                     preferAnchoredCandidate)
 import           Ouroboros.Consensus.Util.Assert (assertWithMsg)
 import           Ouroboros.Consensus.Util.EarlyExit (WithEarlyExit, exitEarly)
 import qualified Ouroboros.Consensus.Util.EarlyExit as EarlyExit
@@ -1617,7 +1618,8 @@ checkKnownInvalid cfgEnv dynEnv intEnv hdr = case scrutinee of
 -- Finally, the client will block on the intersection a second time, if
 -- necessary, since it's possible for a ledger state to determine the slot's
 -- onset's timestamp without also determining the slot's 'LedgerView'. During
--- this pause, the LoP bucket is paused.
+-- this pause, the LoP bucket is paused. If we need to block and their fragment
+-- is not preferrable to ours, we disconnect.
 checkTime ::
   forall m blk arrival judgment.
      ( IOLike m
@@ -1726,10 +1728,43 @@ checkTime cfgEnv dynEnv intEnv =
                       )
                   $ getPastLedger mostRecentIntersection
                 case prj lst of
-                    Nothing         -> retry
+                    Nothing         -> do
+                        checkPreferTheirsOverOurs kis'
+                        retry
                     Just ledgerView ->
                         return $ return $ Intersects kis' ledgerView
 
+    -- Note [Candidate comparing beyond the forecast horizon]
+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    --
+    -- When a header is beyond the forecast horizon and their fragment is not
+    -- preferrable to our selection (ourFrag), then we disconnect, as we will
+    -- never end up selecting it.
+    --
+    -- In the context of Genesis, one can think of the candidate losing a
+    -- density comparison against the selection. See the Genesis documentation
+    -- for why this check is necessary.
+    --
+    -- In particular, this means that we will disconnect from peers who offer us
+    -- a chain containing a slot gap larger than a forecast window.
+    checkPreferTheirsOverOurs :: KnownIntersectionState blk -> STM m ()
+    checkPreferTheirsOverOurs kis
+      | -- Precondition is fulfilled as ourFrag and theirFrag intersect by
+        -- construction.
+        preferAnchoredCandidate (configBlock cfg) ourFrag theirFrag
+      = pure ()
+      | otherwise
+      = throwSTM $ CandidateTooSparse
+            mostRecentIntersection
+            (ourTipFromChain ourFrag)
+            (theirTipFromChain theirFrag)
+      where
+        KnownIntersectionState {
+            mostRecentIntersection
+          , ourFrag
+          , theirFrag
+          } = kis
+
     -- Returns 'Nothing' if the ledger state cannot forecast the ledger view
     -- that far into the future.
     projectLedgerView ::
@@ -1913,6 +1948,12 @@ ourTipFromChain ::
   -> Our (Tip blk)
 ourTipFromChain = Our . AF.anchorToTip . AF.headAnchor
 
+theirTipFromChain ::
+     HasHeader (Header blk)
+  => AnchoredFragment (Header blk)
+  -> Their (Tip blk)
+theirTipFromChain = Their . AF.anchorToTip . AF.headAnchor
+
 -- | A type-legos auxillary function used in 'readLedgerState'.
 castM :: Monad m => m (WithEarlyExit m x) -> WithEarlyExit m x
 castM = join . EarlyExit.lift
@@ -2130,6 +2171,14 @@ data ChainSyncClientException =
         -- different from the previous argument.
         (InvalidBlockReason blk)
     -- ^ The upstream node's chain contained a block that we know is invalid.
+  |
+    forall blk. BlockSupportsProtocol blk =>
+    CandidateTooSparse
+        (Point blk) -- ^ Intersection
+        (Our   (Tip blk))
+        (Their (Tip blk))
+    -- ^ The upstream node's chain was so sparse that it was worse than our
+    -- selection despite being blocked on the forecast horizon.
   |
     InFutureHeaderExceedsClockSkew !InFutureCheck.HeaderArrivalException
     -- ^ A header arrived from the far future.
@@ -2163,6 +2212,12 @@ instance Eq ChainSyncClientException where
       | Just Refl <- eqT @blk @blk'
       = (a, b, c) == (a', b', c')
 
+    (==)
+        (CandidateTooSparse (a  :: Point blk ) b  c )
+        (CandidateTooSparse (a' :: Point blk') b' c')
+      | Just Refl <- eqT @blk @blk'
+      = (a, b, c) == (a', b', c')
+
     (==)
         (InFutureHeaderExceedsClockSkew a )
         (InFutureHeaderExceedsClockSkew a')
@@ -2180,6 +2235,7 @@ instance Eq ChainSyncClientException where
     HeaderError{}                    == _ = False
     InvalidIntersection{}            == _ = False
     InvalidBlock{}                   == _ = False
+    CandidateTooSparse{}             == _ = False
     InFutureHeaderExceedsClockSkew{} == _ = False
     EmptyBucket                      == _ = False
     InvalidJumpResponse              == _ = False

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs

@@ -74,6 +74,13 @@
 -- when the client should pause, download headers, or ask about agreement with
 -- a given point (jumping). See the 'Jumping' type for more details.
 --
+-- CSJ depends on the ChainSync client to disconnect dynamos that have an empty
+-- genesis window after their intersection with the selection. This is necessary
+-- because otherwise there are no points to jump to, and CSJ could would get
+-- stuck when the dynamo blocks on the forecast horizon. See
+-- Note [Candidate comparing beyond the forecast horizon] in
+-- "Ouroboros.Consensus.MiniProtocol.ChainSync.Client".
+--
 -- Interactions with the BlockFetch logic
 -- --------------------------------------
 --