Merge #2323

2323: ChainDB: optimise chain selection for forks r=mrBliss a=mrBliss

Fixes #1223.

When a block fits onto a fork, we construct the fragment all the way going
back to the immutable tip instead of just a `ChainDiff` to the most recent
intersection with the current chain. For example, when switching to a fork
that requires rolling back 2 blocks, previously, we'd construct a fragment
containing `k` headers. Now, we'll construct a `ChainDiff` with rollback = 2
and a fragment of 2 headers.

* `VolDB`: introduce `ReversePath` and `computeReversePath` which lazily
  computes a path through the VolatileDB. By using these paths everywhere, we
  no longer have to think about looking things up in the VolatileDB.

* `VolDB`: let `isReachable` return a `ChainDiff` of `HeaderFields` instead of
  a list of hashes going all the way back to the immutable tip. This
  `ChainDiff` of `HeaderFields` can later be translated to a `ChainDiff` of
  `Header`s.

* `VolDB`: add `extendWithSuccessors` that will extend a `ChainDiff` of
  `HeaderFields` with its successors, using `candidates`.

* Add property tests for `isReachable`, which helped catch a tricky corner
  case involving EBBs.

* `VolDB`: rewrite `computePath` using `computeReversePath`.

* We can now use `RealPoint`s instead of `HeaderHash`s in many functions and
  types: `IteratorBlockGCed`, `ChainDB.Iterator`s, `VolDB.Path`, some trace
  events, etc.

We don't yet take advantage of the `RealPoint` in the implementation of
`ChainDB.Iterator`s.

Co-authored-by: Thomas Winant <[email protected]>

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Ledger.hs

@@ -89,6 +89,15 @@ instance IsLedger (LedgerState ByronBlock) where
                                       byronLedgerState
         }
 
+  ledgerTipPoint (ByronLedgerState state _) =
+      case CC.cvsPreviousHash state of
+        -- In this case there are no blocks in the ledger state. The genesis
+        -- block does not occupy a slot, so its point is Origin.
+        Left _genHash -> GenesisPoint
+        Right hdrHash -> BlockPoint slot (ByronHash hdrHash)
+          where
+            slot = fromByronSlotNo (CC.cvsLastSlot state)
+
 instance ApplyBlock (LedgerState ByronBlock) ByronBlock where
   applyLedgerBlock = applyByronBlock validationMode
     where
@@ -100,15 +109,6 @@ instance ApplyBlock (LedgerState ByronBlock) ByronBlock where
     where
       validationMode = CC.fromBlockValidationMode CC.NoBlockValidation
 
-  ledgerTipPoint (ByronLedgerState state _) =
-      case CC.cvsPreviousHash state of
-        -- In this case there are no blocks in the ledger state. The genesis
-        -- block does not occupy a slot, so its point is Origin.
-        Left _genHash -> GenesisPoint
-        Right hdrHash -> BlockPoint slot (ByronHash hdrHash)
-          where
-            slot = fromByronSlotNo (CC.cvsLastSlot state)
-
 data instance LedgerState ByronBlock = ByronLedgerState {
       byronLedgerState       :: !CC.ChainValidationState
     , byronDelegationHistory :: !DelegationHistory

ouroboros-consensus-byronspec/src/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs

@@ -56,6 +56,13 @@ instance IsLedger (LedgerState ByronSpecBlock) where
           (toByronSpecSlotNo       slot)
           (byronSpecLedgerState    state)
 
+  ledgerTipPoint state =
+      case byronSpecLedgerTip state of
+        Nothing   -> GenesisPoint
+        Just slot -> BlockPoint
+                       slot
+                       (getChainStateHash (byronSpecLedgerState state))
+
 instance ApplyBlock (LedgerState ByronSpecBlock) ByronSpecBlock where
   applyLedgerBlock cfg block (Ticked slot state) =
     withExcept ByronSpecLedgerError $
@@ -79,13 +86,6 @@ instance ApplyBlock (LedgerState ByronSpecBlock) ByronSpecBlock where
         Left  _ -> error "reapplyLedgerBlock: unexpected error"
         Right b -> b
 
-  ledgerTipPoint state =
-      case byronSpecLedgerTip state of
-        Nothing   -> GenesisPoint
-        Just slot -> BlockPoint
-                       slot
-                       (getChainStateHash (byronSpecLedgerState state))
-
 data instance LedgerState ByronSpecBlock = ByronSpecLedgerState {
       -- | Tip of the ledger (most recently applied block, if any)
       --

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs

@@ -182,6 +182,8 @@ instance TPraosCrypto c => IsLedger (LedgerState (ShelleyBlock c)) where
         . ShelleyLedgerState pt history
         $ SL.applyTickTransition (shelleyLedgerGlobals cfg) bhState slotNo
 
+  ledgerTipPoint = castPoint . ledgerTip
+
 instance TPraosCrypto c
       => ApplyBlock (LedgerState (ShelleyBlock c)) (ShelleyBlock c) where
   -- Note: in the Shelley ledger, the @CHAIN@ rule is used to apply a whole
@@ -235,8 +237,6 @@ instance TPraosCrypto c
       Left  err          -> error $
         "Reapplication of Shelley ledger block failed: " <> show err
 
-  ledgerTipPoint = ledgerTip
-
 data instance LedgerState (ShelleyBlock c) = ShelleyLedgerState {
       ledgerTip    :: !(Point (ShelleyBlock c))
     , history      :: !(History.LedgerViewHistory c)

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs

@@ -308,6 +308,7 @@ instance MockProtocolSpecific c ext
   type LedgerErr (LedgerState (SimpleBlock c ext)) = MockError (SimpleBlock c ext)
 
   applyChainTick _ = Ticked
+  ledgerTipPoint (SimpleLedgerState st) = castPoint $ mockTip st
 
 instance MockProtocolSpecific c ext
       => ApplyBlock (LedgerState (SimpleBlock c ext)) (SimpleBlock c ext) where
@@ -316,7 +317,6 @@ instance MockProtocolSpecific c ext
     where
       mustSucceed (Left  err) = error ("reapplyLedgerBlock: unexpected error: " <> show err)
       mustSucceed (Right st)  = st
-  ledgerTipPoint (SimpleLedgerState st) = mockTip st
 
 newtype instance LedgerState (SimpleBlock c ext) = SimpleLedgerState {
       simpleLedgerState :: MockState (SimpleBlock c ext)
@@ -415,7 +415,7 @@ instance MockProtocolSpecific c ext => QueryLedger (SimpleBlock c ext) where
   data Query (SimpleBlock c ext) result where
       QueryLedgerTip :: Query (SimpleBlock c ext) (Point (SimpleBlock c ext))
 
-  answerQuery _cfg QueryLedgerTip = ledgerTipPoint
+  answerQuery _cfg QueryLedgerTip = castPoint . ledgerTipPoint
 
   eqQuery QueryLedgerTip QueryLedgerTip = Just Refl
 

ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/ThreadNet/Network.hs

@@ -721,7 +721,7 @@ runThreadNetwork systemTime ThreadNetworkArgs
                   where
                     EpochNo   x = currentEpoch
                     EpochSize y = epochSize0
-            let p = ledgerTipPoint $ tickedLedgerState tickedLdgSt
+            let p = ledgerTipPoint' (Proxy @blk) $ tickedLedgerState tickedLdgSt
 
             let needEBB = inFirstEra && NotOrigin ebbSlot > pointSlot p
             case mbForgeEbbEnv <* guard needEBB of

ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/TestBlock.hs

@@ -281,6 +281,8 @@ instance IsLedger (LedgerState TestBlock) where
 
   applyChainTick _ = Ticked
 
+  ledgerTipPoint = castPoint . lastAppliedPoint
+
 instance ApplyBlock (LedgerState TestBlock) TestBlock where
   applyLedgerBlock _ tb@TestBlock{..} (Ticked _ TestLedger{..})
     | blockPrevHash tb /= pointHash lastAppliedPoint
@@ -292,8 +294,6 @@ instance ApplyBlock (LedgerState TestBlock) TestBlock where
 
   reapplyLedgerBlock _ tb _ = TestLedger (Chain.blockPoint tb)
 
-  ledgerTipPoint = lastAppliedPoint
-
 newtype instance LedgerState TestBlock =
     TestLedger {
         -- The ledger state simply consists of the last applied block

ouroboros-consensus/ouroboros-consensus.cabal

@@ -473,6 +473,7 @@ test-suite test-storage
                        Test.Ouroboros.Storage.ChainDB.Model
                        Test.Ouroboros.Storage.ChainDB.Model.Test
                        Test.Ouroboros.Storage.ChainDB.StateMachine
+                       Test.Ouroboros.Storage.ChainDB.VolDB
                        Test.Ouroboros.Storage.FS
                        Test.Ouroboros.Storage.FS.StateMachine
                        Test.Ouroboros.Storage.ImmutableDB

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

@@ -1,29 +1,32 @@
 {-# LANGUAGE FlexibleContexts     #-}
-{-# LANGUAGE PatternSynonyms      #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE StandaloneDeriving   #-}
+{-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE UndecidableInstances #-}
 -- | Intended for qualified import
 --
 -- > import Ouroboros.Consensus.Fragment.Diff (ChainDiff (..))
 -- > import qualified Ouroboros.Consensus.Fragment.Diff as Diff
 module Ouroboros.Consensus.Fragment.Diff
-  ( ChainDiff(ChainDiff)
+  ( ChainDiff(..)
     -- * Queries
-  , getRollback
-  , getSuffix
   , getTip
   , getAnchorPoint
+  , rollbackExceedsSuffix
     -- * Constructors
   , extend
   , diff
     -- * Application
   , apply
     -- * Manipulation
+  , append
   , truncate
   , takeWhileOldest
+  , mapM
   ) where
 
-import           Prelude hiding (truncate)
+import           Prelude hiding (mapM, truncate)
+import qualified Prelude
 
 import           Data.Word (Word64)
 import           GHC.Stack (HasCallStack)
@@ -36,62 +39,48 @@ import           Ouroboros.Consensus.Block
 
 -- | A diff of a chain (fragment).
 --
--- INVARIANT: the length of the suffix must always be >= the rollback
+-- Typical instantiations of the type argument @b@: a block type @blk@,
+-- @Header blk@, @HeaderFields@, ..., anything that supports 'HasHeader'.
 --
--- Note: we allow the suffix with new headers to be empty, even though it is
--- rather pointless. Allowing empty ones makes working with them easier: fewer
--- cases to deal with. Without any headers, the rollback must be 0, so such a
--- diff would be an empty diff.
-data ChainDiff blk = UnsafeChainDiff
+-- Note: we allow the suffix to be shorter than the number of blocks to roll
+-- back. In other words, applying a 'ChainDiff' can result in a chain shorter
+-- than the chain to which the diff was applied.
+data ChainDiff b = ChainDiff
     { getRollback :: !Word64
-      -- ^ The number of headers to roll back the current chain
-    , getSuffix   :: !(AnchoredFragment (Header blk))
-      -- ^ The new headers to add after rolling back the current chain.
+      -- ^ The number of blocks/headers to roll back the current chain
+    , getSuffix   :: !(AnchoredFragment b)
+      -- ^ The new blocks/headers to add after rolling back the current chain.
     }
 
-deriving instance (HasHeader blk, Eq (Header blk))
-               => Eq   (ChainDiff blk)
-deriving instance (HasHeader blk, Show (Header blk))
-               => Show (ChainDiff blk)
-
--- | Allow for pattern matching on a 'ChainDiff' without exposing the (unsafe)
--- constructor. Use 'extend' and 'diff' to construct a 'ChainDiff'.
-pattern ChainDiff
-  :: Word64 -> AnchoredFragment (Header blk) -> ChainDiff blk
-pattern ChainDiff r s <- UnsafeChainDiff r s
-{-# COMPLETE ChainDiff #-}
-
--- | Internal. Return 'Nothing' if the length of the suffix < the rollback.
-mkRollback
-  :: HasHeader (Header blk)
-  => Word64
-  -> AnchoredFragment (Header blk)
-  -> Maybe (ChainDiff blk)
-mkRollback nbRollback suffix
-    | fromIntegral (AF.length suffix) >= nbRollback
-    = Just $ UnsafeChainDiff nbRollback suffix
-    | otherwise
-    = Nothing
+deriving instance (StandardHash b, Eq   b) => Eq   (ChainDiff b)
+deriving instance (StandardHash b, Show b) => Show (ChainDiff b)
 
 {-------------------------------------------------------------------------------
   Queries
 -------------------------------------------------------------------------------}
 
 -- | Return the tip of the new suffix
-getTip :: HasHeader (Header blk) => ChainDiff blk -> Point blk
+getTip :: HasHeader b => ChainDiff b -> Point b
 getTip = castPoint . AF.headPoint . getSuffix
 
 -- | Return the anchor point of the new suffix
-getAnchorPoint :: ChainDiff blk -> Point blk
+getAnchorPoint :: ChainDiff b -> Point b
 getAnchorPoint = castPoint . AF.anchorPoint . getSuffix
 
+-- | Return 'True' iff applying the 'ChainDiff' to a chain @C@ will result in
+-- a chain shorter than @C@, i.e., the number of blocks to roll back is
+-- greater than the length of the new elements in the suffix to add.
+rollbackExceedsSuffix :: HasHeader b => ChainDiff b -> Bool
+rollbackExceedsSuffix (ChainDiff nbRollback suffix) =
+    nbRollback > fromIntegral (AF.length suffix)
+
 {-------------------------------------------------------------------------------
   Constructors
 -------------------------------------------------------------------------------}
 
 -- | Make an extension-only (no rollback) 'ChainDiff'.
-extend :: AnchoredFragment (Header blk) -> ChainDiff blk
-extend = UnsafeChainDiff 0
+extend :: AnchoredFragment b -> ChainDiff b
+extend = ChainDiff 0
 
 -- | Diff a candidate chain with the current chain.
 --
@@ -101,14 +90,14 @@ extend = UnsafeChainDiff 0
 -- PRECONDITION: the candidate fragment must intersect with the current chain
 -- fragment.
 diff
-  :: (HasHeader (Header blk), HasCallStack)
-  => AnchoredFragment (Header blk)  -- ^ Current chain
-  -> AnchoredFragment (Header blk)  -- ^ Candidate chain
-  -> Maybe (ChainDiff blk)
+  :: (HasHeader b, HasCallStack)
+  => AnchoredFragment b  -- ^ Current chain
+  -> AnchoredFragment b  -- ^ Candidate chain
+  -> ChainDiff b
 diff curChain candChain =
   case AF.intersect curChain candChain of
     Just (_curChainPrefix, _candPrefix, curChainSuffix, candSuffix)
-      -> mkRollback
+      -> ChainDiff
            (fromIntegral (AF.length curChainSuffix))
            candSuffix
     -- Precondition violated.
@@ -129,33 +118,39 @@ diff curChain candChain =
 -- The returned fragment will have the same anchor point as the given
 -- fragment.
 apply
-  :: HasHeader (Header blk)
-  => AnchoredFragment (Header blk)
-  -> ChainDiff blk
-  -> Maybe (AnchoredFragment (Header blk))
+  :: HasHeader b
+  => AnchoredFragment b
+  -> ChainDiff b
+  -> Maybe (AnchoredFragment b)
 apply curChain (ChainDiff nbRollback suffix) =
     AF.join (AF.dropNewest (fromIntegral nbRollback) curChain) suffix
 
 {-------------------------------------------------------------------------------
   Manipulation
 -------------------------------------------------------------------------------}
 
+-- | Append a @b@ to a 'ChainDiff'.
+--
+-- PRECONDITION: it must fit onto the end of the suffix.
+append :: HasHeader b => ChainDiff b -> b -> ChainDiff b
+append (ChainDiff nbRollback suffix) b = (ChainDiff nbRollback (suffix :> b))
+
 -- | Truncate the diff by rolling back the new suffix to the given point.
 --
--- PRECONDITION: the given point must correspond to one of the new headers of
--- the new suffix or its anchor (i.e, @'AF.withinFragmentBounds' pt (getSuffix
--- diff)@).
+-- PRECONDITION: the given point must correspond to one of the new
+-- blocks/headers of the new suffix or its anchor (i.e,
+-- @'AF.withinFragmentBounds' pt (getSuffix diff)@).
 --
 -- If the length of the truncated suffix is shorter than the rollback,
 -- 'Nothing' is returned.
 truncate
-  :: (HasHeader (Header blk), HasCallStack, HasHeader blk)
-  => Point blk
-  -> ChainDiff blk
-  -> Maybe (ChainDiff blk)
+  :: (HasHeader b, HasCallStack)
+  => Point b
+  -> ChainDiff b
+  -> ChainDiff b
 truncate pt (ChainDiff nbRollback suffix)
     | Just suffix' <- AF.rollback (castPoint pt) suffix
-    = mkRollback nbRollback suffix'
+    = ChainDiff nbRollback suffix'
     | otherwise
     = error $ "rollback point not on the candidate suffix: " <> show pt
 
@@ -164,9 +159,23 @@ truncate pt (ChainDiff nbRollback suffix)
 --
 -- If the new suffix is shorter than the diff's rollback, return 'Nothing'.
 takeWhileOldest
-  :: HasHeader (Header blk)
-  => (Header blk -> Bool)
-  -> ChainDiff blk
-  -> Maybe (ChainDiff blk)
+  :: HasHeader b
+  => (b -> Bool)
+  -> ChainDiff b
+  -> ChainDiff b
 takeWhileOldest accept (ChainDiff nbRollback suffix) =
-    mkRollback nbRollback (AF.takeWhileOldest accept suffix)
+    ChainDiff nbRollback (AF.takeWhileOldest accept suffix)
+
+mapM
+  :: forall a b m.
+     ( HasHeader b
+     , HeaderHash a ~ HeaderHash b
+     , Monad m
+     )
+  => (a -> m b)
+  -> ChainDiff a
+  -> m (ChainDiff b)
+mapM f (ChainDiff rollback suffix) =
+       ChainDiff rollback
+    .  AF.fromOldestFirst (AF.castAnchor (AF.anchor suffix))
+   <$> Prelude.mapM f (AF.toOldestFirst suffix)

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

@@ -46,7 +46,7 @@ data CheckInFuture m blk = CheckInFuture {
        -- | POSTCONDITION:
        -- > checkInFuture vf >>= \(af, fut) ->
        -- >   validatedFragment vf == af <=> null fut
-       checkInFuture :: ValidatedFragment blk (LedgerState blk)
+       checkInFuture :: ValidatedFragment (Header blk) (LedgerState blk)
                      -> m (AnchoredFragment (Header blk), [InFuture blk])
     }
   deriving NoUnexpectedThunks