No pipelining of blocks from the future

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

@@ -20,7 +20,6 @@ import           Ouroboros.Consensus.Config
                      (TopLevelConfig (topLevelConfigLedger),
                      configSecurityParam)
 import           Ouroboros.Consensus.Fragment.InFuture (CheckInFuture (..))
-import qualified Ouroboros.Consensus.Fragment.Validated as VF
 import           Ouroboros.Consensus.HardFork.History.EraParams (EraParams,
                      eraEpochSize)
 import           Ouroboros.Consensus.Ledger.Basics (LedgerConfig)
@@ -103,7 +102,9 @@ 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          = CheckInFuture {
+                                    checkInFuture = \_ af -> pure (af, [])
+                                  }
   -- 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/StateMachine.hs

@@ -1397,13 +1397,25 @@ genBlk chunkInfo Model{..} = frequency
         )
       ]
 
+    genSlotFromFuture :: Gen SlotNo
+    genSlotFromFuture =
+      let farFuture = Model.currentSlot dbModel + SlotNo (Model.maxClockSkew dbModel + 1)
+          nearFuture = Model.currentSlot dbModel + SlotNo 1
+      in frequency
+         [ (4, chooseSlot nearFuture farFuture),
+           (1, chooseSlot farFuture (farFuture + SlotNo 10))]
+
     -- Helper that generates a block that fits onto the given block.
     genFitsOn :: TestBlock -> Gen TestBlock
     genFitsOn b = frequency
         [ (4, do
                 slotNo <- if fromIsEBB (testBlockIsEBB b)
                   then chooseSlot (blockSlot b)     (blockSlot b + 2)
-                  else chooseSlot (blockSlot b + 1) (blockSlot b + 3)
+                  else do
+                    frequency
+                      [ (10, chooseSlot (blockSlot b + 1) (blockSlot b + 3))
+                      , (1, genSlotFromFuture)
+                      ]
                 body   <- genBody
                 return $ mkNextBlock b slotNo body)
         -- An EBB is never followed directly by another EBB, otherwise they

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

@@ -35,8 +35,6 @@ import           Ouroboros.Network.AnchoredFragment (AnchoredFragment,
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.BlockchainTime
-import           Ouroboros.Consensus.Fragment.Validated (ValidatedFragment)
-import qualified Ouroboros.Consensus.Fragment.Validated as VF
 import           Ouroboros.Consensus.HardFork.Abstract
 import qualified Ouroboros.Consensus.HardFork.History as HF
 import           Ouroboros.Consensus.Ledger.Abstract
@@ -47,10 +45,9 @@ import           Ouroboros.Consensus.Util.Time
 
 data CheckInFuture m blk = CheckInFuture {
        -- | POSTCONDITION:
-       --
-       -- > checkInFuture vf >>= \(af, fut) ->
-       -- >   validatedFragment vf == af <=> null fut
-       checkInFuture :: ValidatedFragment (Header blk) (LedgerState blk)
+       -- > checkInFuture _ af >>= \(af', fut) ->
+       -- >   af == af' <=> null fut
+       checkInFuture :: LedgerState blk -> AnchoredFragment (Header blk)
                      -> m (AnchoredFragment (Header blk), [InFuture m blk])
     }
   deriving NoThunks
@@ -115,15 +112,9 @@ reference :: forall m blk. (Monad m, UpdateLedger blk, HasHardForkHistory blk)
           -> SystemTime m
           -> CheckInFuture m blk
 reference cfg (ClockSkew clockSkew) SystemTime{..} = CheckInFuture {
-      checkInFuture = \validated -> do
-        now <- systemTimeCurrent
-        -- Since we have the ledger state /after/ the fragment, the derived
-        -- summary can be used to check all of the blocks in the fragment
-        return $
-          checkFragment
-            (hardForkSummary cfg (VF.validatedLedger validated))
-            now
-            (VF.validatedFragment validated)
+      checkInFuture = \ledgerState af -> do
+          now <- systemTimeCurrent
+          return $ checkFragment (hardForkSummary cfg ledgerState) now af
     }
   where
     checkFragment :: HF.Summary (HardForkIndices blk)
@@ -166,7 +157,7 @@ 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 = \_ af -> return (af, [])
     }
 
 -- | If by some miracle we have a function that can always tell us what the
@@ -179,9 +170,9 @@ miracle :: forall m blk. (MonadSTM m, HasHeader (Header blk))
         -> Word64                -- ^ Maximum clock skew (in terms of slots)
         -> CheckInFuture m blk
 miracle oracle clockSkew = CheckInFuture {
-      checkInFuture = \validated -> do
+      checkInFuture = \_ af -> do
         now <- atomically $ oracle
-        return $ checkFragment now (VF.validatedFragment validated)
+        return $ checkFragment now af
     }
   where
     checkFragment :: SlotNo

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

@@ -903,20 +903,24 @@ chainSelection chainSelEnv chainDiffs =
       -> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
     go []            = return Nothing
     go (candidate:candidates0) = do
-        mTentativeHeader <- setTentativeHeader
-        validateCandidate chainSelEnv candidate >>= \case
+        -- Remove future blocks from the chain, and update the ChainDB state
+        -- that keeps track of those blocks, so we can take them into account
+        -- in the decision to make blocks available for pipelining.
+        candidate' <- futureCheckCandidate chainSelEnv candidate
+        mTentativeHeader <- setTentativeHeader candidate'
+        validateCandidate chainSelEnv candidate' >>= \case
           InsufficientSuffix ->
             -- When the body of the tentative block turns out to be invalid, we
             -- have a valid *empty* prefix, as the tentative header fits on top
             -- of the current chain.
             assert (isSNothing mTentativeHeader) $ do
               candidates1 <- truncateRejectedBlocks candidates0
               go (sortCandidates candidates1)
-          FullyValid validatedCandidate@(ValidatedChainDiff candidate' _) ->
+          FullyValid validatedCandidate@(ValidatedChainDiff candidate'' _) ->
             -- The entire candidate is valid
-            assert (Diff.getTip candidate == Diff.getTip candidate') $
+            assert (Diff.getTip candidate' == Diff.getTip candidate'') $
             return $ Just validatedCandidate
-          ValidPrefix candidate' -> do
+          ValidPrefix candidate'' -> do
             whenJust (strictMaybeToMaybe mTentativeHeader) clearTentativeHeader
             -- Prefix of the candidate because it contained rejected blocks
             -- (invalid blocks and/or blocks from the future). Note that the
@@ -932,18 +936,18 @@ chainSelection chainSelEnv chainDiffs =
             -- it will be dropped here, as it will not be preferred over the
             -- current chain.
             let candidates2
-                  | preferAnchoredCandidate bcfg curChain (Diff.getSuffix candidate')
-                  = candidate':candidates1
+                  | preferAnchoredCandidate bcfg curChain (Diff.getSuffix candidate'')
+                  = candidate'':candidates1
                   | otherwise
                   = candidates1
             go (sortCandidates candidates2)
       where
         -- | Set and return the tentative header, if applicable. Also, notify
         -- the tentative followers.
-        setTentativeHeader :: m (StrictMaybe (Header blk))
-        setTentativeHeader = do
+        setTentativeHeader :: ChainDiff (Header blk) -> m (StrictMaybe (Header blk))
+        setTentativeHeader candidate' = do
             mTentativeHeader <-
-                  (\ts -> isPipelineable bcfg ts candidate)
+                  (\ts -> isPipelineable bcfg ts candidate')
               <$> readTVarIO varTentativeState
             whenJust (strictMaybeToMaybe mTentativeHeader) $ \tentativeHeader -> do
               let setTentative = SetTentativeHeader tentativeHeader
@@ -1014,12 +1018,12 @@ chainSelection chainSelEnv chainDiffs =
 
 -- | Result of 'validateCandidate'.
 data ValidationResult blk =
-      -- | The entire candidate fragment was valid. No blocks were from the
-      -- future.
+      -- | The candidate fragment, after truncating blocks from the future, was
+      -- valid.
       FullyValid (ValidatedChainDiff (Header blk) (LedgerDB' blk))
 
-      -- | The candidate fragment contained invalid blocks and/or blocks from
-      -- the future that had to be truncated from the fragment.
+      -- | The candidate fragment contained invalid blocks that had to be
+      -- truncated from the fragment.
     | ValidPrefix (ChainDiff (Header blk))
 
       -- | After truncating the invalid blocks or blocks from the future from
@@ -1132,16 +1136,16 @@ ledgerValidateCandidate chainSelEnv chainDiff@(ChainDiff rollback suffix) =
 futureCheckCandidate
   :: forall m blk. (IOLike m, LedgerSupportsProtocol blk)
   => ChainSelEnv m blk
-  -> ValidatedChainDiff (Header blk) (LedgerDB' blk)
-  -> m (Either (ChainDiff (Header blk))
-               (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
-futureCheckCandidate chainSelEnv validatedChainDiff =
-    checkInFuture futureCheck validatedSuffix >>= \case
+  -> ChainDiff (Header blk)
+  -> m (ChainDiff (Header blk))
+futureCheckCandidate chainSelEnv chainDiff = do
+    let ledgerState = getCurrentLedgerState chainSelEnv
+    checkInFuture futureCheck ledgerState suffix >>= \case
 
       (suffix', []) ->
         -- If no headers are in the future, then the fragment must be untouched
         assert (AF.headPoint suffix == AF.headPoint suffix') $
-        return $ Right validatedChainDiff
+        return $ chainDiff
 
       (suffix', inFuture) -> do
         let (exceedClockSkew, inNearFuture) =
@@ -1189,17 +1193,22 @@ futureCheckCandidate chainSelEnv validatedChainDiff =
 
         -- Truncate the original 'ChainDiff' to match the truncated
         -- 'AnchoredFragment'.
-        return $ Left $ Diff.truncate (castPoint (AF.headPoint suffix')) chainDiff
+        return $ Diff.truncate (castPoint (AF.headPoint suffix')) chainDiff
   where
+    getCurrentLedgerState :: ChainSelEnv m blk -> LedgerState blk
+    -- TODO[private-16]: Get the ledger state from the ChainSelEnv
+    getCurrentLedgerState ChainSelEnv { curChainAndLedger } =
+      ledgerState $ LgrDB.ledgerDbCurrent $ VF.validatedLedger curChainAndLedger
+
     ChainSelEnv { validationTracer, varInvalid, varFutureBlocks, futureCheck } =
       chainSelEnv
 
-    ValidatedChainDiff chainDiff@(ChainDiff _ suffix) _ = validatedChainDiff
+    (ChainDiff _ suffix) = chainDiff
 
-    validatedSuffix :: ValidatedFragment (Header blk) (LedgerState blk)
-    validatedSuffix =
-      ledgerState . LgrDB.ledgerDbCurrent <$>
-      ValidatedDiff.toValidatedFragment validatedChainDiff
+    -- validatedSuffix :: ValidatedFragment (Header blk) (LedgerState blk)
+    -- validatedSuffix =
+    --   ledgerState . LgrDB.ledgerDbCurrent <$>
+    --   ValidatedDiff.toValidatedFragment validatedChainDiff
 
 -- | Validate a candidate chain using 'ledgerValidateCandidate' and
 -- 'futureCheck'.
@@ -1213,31 +1222,13 @@ validateCandidate
   -> m (ValidationResult blk)
 validateCandidate chainSelEnv chainDiff =
     ledgerValidateCandidate chainSelEnv chainDiff >>= \case
-      validatedChainDiff
+      validatedChainDiff@(ValidatedChainDiff chainDiff' _)
         | ValidatedDiff.rollbackExceedsSuffix validatedChainDiff
         -> return InsufficientSuffix
+        | AF.length (Diff.getSuffix chainDiff) == AF.length (Diff.getSuffix chainDiff')
+        -> return $ FullyValid validatedChainDiff
         | otherwise
-        -> futureCheckCandidate chainSelEnv validatedChainDiff >>= \case
-          Left chainDiff'
-              | Diff.rollbackExceedsSuffix chainDiff'
-              -> return InsufficientSuffix
-              | otherwise
-              -> return $ ValidPrefix chainDiff'
-          Right validatedChainDiff'
-              | ValidatedDiff.rollbackExceedsSuffix validatedChainDiff'
-              -> return InsufficientSuffix
-              | AF.length (Diff.getSuffix chainDiff) ==
-                AF.length (Diff.getSuffix chainDiff')
-                -- No truncation
-              -> return $ FullyValid validatedChainDiff'
-              | otherwise
-                -- In case of invalid blocks but no blocks from the future, we
-                -- throw away the ledger corresponding to the truncated
-                -- fragment and will have to validate it again, even when it's
-                -- the sole candidate.
-              -> return $ ValidPrefix chainDiff'
-            where
-              chainDiff' = ValidatedDiff.getChainDiff validatedChainDiff'
+        -> return $ ValidPrefix chainDiff'
 
 {-------------------------------------------------------------------------------
   'ChainAndLedger'