Avoid pipelining of future blocks

ouroboros-consensus-test/src/Test/Util/ChainDB.hs

@@ -19,8 +19,7 @@ import           Ouroboros.Consensus.Block.Abstract
 import           Ouroboros.Consensus.Config
                      (TopLevelConfig (topLevelConfigLedger),
                      configSecurityParam)
-import           Ouroboros.Consensus.Fragment.InFuture (CheckInFuture (..))
-import qualified Ouroboros.Consensus.Fragment.Validated as VF
+import           Ouroboros.Consensus.Fragment.InFuture (dontCheck)
 import           Ouroboros.Consensus.HardFork.History.EraParams (EraParams,
                      eraEpochSize)
 import           Ouroboros.Consensus.Ledger.Basics (LedgerConfig)
@@ -103,7 +102,7 @@ fromMinimalChainDbArgs MinimalChainDbArgs {..} = ChainDbArgs {
   -- ImmutableDB, as the VolatileDB. This is done in @extractBlockComponent@ in the iterator for the
   -- ImmutableDB, and in @getBlockComponent@ for the VolatileDB.
   , cdbGenesis                = return mcdbInitLedger
-  , cdbCheckInFuture          = CheckInFuture $ \vf -> pure (VF.validatedFragment vf, [])
+  , cdbCheckInFuture          = dontCheck
   -- Blocks are never in the future.
   , cdbImmutableDbCacheConfig = ImmutableDB.CacheConfig 2 60
   -- Cache at most 2 chunks and expire each chunk after 60 seconds of being unused.

ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE BlockArguments      #-}
 {-# LANGUAGE DerivingStrategies  #-}
 {-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE MultiWayIf          #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -25,6 +26,7 @@ import           Control.Tracer (Tracer (..), contramapM, traceWith)
 import           Data.Foldable (for_)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
+import           Data.Maybe (mapMaybe)
 import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Time.Clock (secondsToDiffTime)
@@ -37,6 +39,7 @@ import qualified Ouroboros.Network.Mock.Chain as Chain
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
+import           Ouroboros.Consensus.Fragment.InFuture (miracle)
 import           Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
 import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
 import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as Punishment
@@ -60,17 +63,45 @@ tests = testGroup "FollowerPromptness"
 
 prop_followerPromptness :: FollowerPromptnessTestSetup -> Property
 prop_followerPromptness fpts =
+    label (bucket (length futureBlocks) (length allBlocks)) $
     counterexample ("Trace:\n" <> unlines (ppTrace <$> traceByTime)) $
     counterexample (condense fpts) $
     counterexample ("Instruction timings: " <> condense followerInstrTimings) $
            counterexample ("Failed to pipeline: " <> condense notPipelined)
            (null notPipelined)
       .&&. counterexample ("Not processed: " <> condense unprocessed)
            (null unprocessed)
+      .&&. counterexample ("Future blocks pipelined: " <> condense futureBlocksPipelined)
+           (null futureBlocksPipelined)
   where
     FollowerPromptnessOutcome{..} =
       runSimOrThrow $ runFollowerPromptnessTest fpts
 
+    bucket x y =
+      if | x == 0    -> "0%"
+         | x == y    -> "100%"
+         | otherwise -> "(0%, 100%)"
+
+    allBlocks = getAllBlocks $ chainUpdates fpts
+
+    futureBlocks = [ headerFieldHash hf
+                   | hf <- allBlocks,
+                     headerFieldSlot hf > staticNow fpts
+                   ]
+
+    -- Hashes of future blocks that were emitted as a follower
+    -- instruction. This should be empty since the future check is static. If
+    -- it weren't it might be the case that once-future blocks are pipelined
+    -- when they are adopted as part of the chain.
+    futureBlocksPipelined = futureBlocksFollowedUp followerInstrTimings
+
+    -- Hashes of future blocks that were followed up on in the
+    -- `followUpTimings` argument.
+    futureBlocksFollowedUp :: Map Time (Set TestHash) -> [TestHash]
+    futureBlocksFollowedUp followUpTimings =
+      let followUps = Set.unions followUpTimings
+      in filter (`Set.member` followUps) futureBlocks
+
     -- Hashes of tentative headers which were not immediately emitted as a
     -- follower instruction.
     notPipelined =
@@ -178,7 +209,10 @@ runFollowerPromptnessTest FollowerPromptnessTestSetup{..} = withRegistry \regist
               mcdbRegistry       = registry
           mcdbNodeDBs <- emptyNodeDBs
           let cdbArgs = fromMinimalChainDbArgs MinimalChainDbArgs{..}
-          pure $ cdbArgs { cdbTracer = cdbTracer }
+          pure $ cdbArgs {
+              cdbTracer = cdbTracer
+            , cdbCheckInFuture = miracle (pure staticNow) 10
+            }
         (_, (chainDB, ChainDBImpl.Internal{intAddBlockRunner})) <-
           allocate
             registry
@@ -198,6 +232,7 @@ data FollowerPromptnessTestSetup = FollowerPromptnessTestSetup {
     securityParam   :: SecurityParam
   , chainUpdates    :: [ChainUpdate]
   , artificialDelay :: DiffTime
+  , staticNow       :: SlotNo
   }
   deriving stock (Show)
 
@@ -214,12 +249,20 @@ instance Arbitrary FollowerPromptnessTestSetup where
       -- sufficiently often.
       chainUpdates    <- genChainUpdates TentativeChainBehavior securityParam 20
       artificialDelay <- secondsToDiffTime <$> chooseInteger (1, 10)
+      staticNow <- elements (headerFieldSlot <$> getAllBlocks chainUpdates)
       pure FollowerPromptnessTestSetup {..}
 
+
   shrink FollowerPromptnessTestSetup{..} =
       [ FollowerPromptnessTestSetup {
             chainUpdates = init chainUpdates
+          , staticNow = maximum (headerFieldSlot <$> getAllBlocks chainUpdates) - 1
           , ..
           }
       | not $ null chainUpdates
       ]
+
+getAllBlocks :: [ChainUpdate] -> [HeaderFields TestBlock]
+getAllBlocks = mapMaybe $ \case
+  (AddBlock blk) -> Just $ getHeaderFields blk
+  _              -> Nothing

ouroboros-consensus/changelog.d/20230130_144430_nick.frisby_no_pipelining_of_future_blocks.md

@@ -0,0 +1,3 @@
+### Patch
+
+- Do not pipeline future blocks.

ouroboros-consensus/src/Ouroboros/Consensus/Fragment/InFuture.hs

@@ -52,6 +52,9 @@ data CheckInFuture m blk = CheckInFuture {
        -- >   validatedFragment vf == af <=> null fut
        checkInFuture :: ValidatedFragment (Header blk) (LedgerState blk)
                      -> m (AnchoredFragment (Header blk), [InFuture m blk])
+
+    ,  checkDefinitelyNotInFuture :: m (LedgerState blk -> SlotNo -> Bool)
+
     }
   deriving NoThunks
        via OnlyCheckWhnfNamed "CheckInFuture" (CheckInFuture m blk)
@@ -124,6 +127,14 @@ reference cfg (ClockSkew clockSkew) SystemTime{..} = CheckInFuture {
             (hardForkSummary cfg (VF.validatedLedger validated))
             now
             (VF.validatedFragment validated)
+    , checkDefinitelyNotInFuture = do
+        now <- systemTimeCurrent
+
+        pure $ \ledgerState slot -> case HF.runQuery
+               (HF.slotToWallclock slot)
+               (hardForkSummary cfg ledgerState) of
+          Left _err          -> False
+          Right (hdrTime, _) -> hdrTime < now
     }
   where
     checkFragment :: HF.Summary (HardForkIndices blk)
@@ -166,7 +177,8 @@ reference cfg (ClockSkew clockSkew) SystemTime{..} = CheckInFuture {
 -- This is useful for testing and tools such as the DB converter.
 dontCheck :: Monad m => CheckInFuture m blk
 dontCheck = CheckInFuture {
-      checkInFuture = \validated -> return (VF.validatedFragment validated, [])
+      checkInFuture              = \validated -> return (VF.validatedFragment validated, [])
+    , checkDefinitelyNotInFuture = return $ \_ledgerState _slot -> True
     }
 
 -- | If by some miracle we have a function that can always tell us what the
@@ -182,6 +194,10 @@ miracle oracle clockSkew = CheckInFuture {
       checkInFuture = \validated -> do
         now <- atomically $ oracle
         return $ checkFragment now (VF.validatedFragment validated)
+    , checkDefinitelyNotInFuture = do
+        now <- atomically $ oracle
+
+        pure $ \_ledgerState slot -> slot <= now
     }
   where
     checkFragment :: SlotNo

ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs

@@ -942,8 +942,17 @@ chainSelection chainSelEnv chainDiffs =
         -- the tentative followers.
         setTentativeHeader :: m (StrictMaybe (Header blk))
         setTentativeHeader = do
+            gate <- do
+                let ledger :: LedgerState blk
+                    ledger =
+                        ledgerState
+                      $ LgrDB.ledgerDbCurrent
+                      $ VF.validatedLedger
+                      $ curChainAndLedger
+                f <- checkDefinitelyNotInFuture futureCheck
+                pure $ f $ ledger
             mTentativeHeader <-
-                  (\ts -> isPipelineable bcfg ts candidate)
+                  (\ts -> isPipelineable bcfg ts gate candidate)
               <$> readTVarIO varTentativeState
             whenJust (strictMaybeToMaybe mTentativeHeader) $ \tentativeHeader -> do
               let setTentative = SetTentativeHeader tentativeHeader
@@ -1258,14 +1267,16 @@ isPipelineable ::
      LedgerSupportsProtocol blk
   => BlockConfig blk
   -> TentativeState blk
+  -> (SlotNo -> Bool)
   -> ChainDiff (Header blk)
   -> StrictMaybe (Header blk)
-isPipelineable bcfg tentativeState ChainDiff {..}
+isPipelineable bcfg tentativeState isDefinitelyNotInFuture ChainDiff {..}
   | -- we apply exactly one header
     AF.Empty _ :> hdr <- getSuffix
   , preferToLastInvalidTentative bcfg tentativeState hdr
     -- ensure that the diff is applied to the chain tip
   , getRollback == 0
+  , isDefinitelyNotInFuture (blockSlot hdr)
   = SJust hdr
   | otherwise = SNothing