ChainDB q-s-m: test weighted chain selection

Author: amesgen

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs

@@ -10,7 +10,7 @@ module Ouroboros.Consensus.Util.AnchoredFragment
   ( compareAnchoredFragments
   , compareHeadBlockNo
   , cross
-  , forksAtMostKBlocks
+  , forksAtMostKWeight
   , preferAnchoredCandidate
   , stripCommonPrefix
   ) where
@@ -19,7 +19,6 @@ import Data.Foldable (toList)
 import qualified Data.Foldable1 as F1
 import Data.Function (on)
 import qualified Data.List.NonEmpty as NE
-import Data.Word (Word64)
 import GHC.Stack
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Peras.SelectView
@@ -55,20 +54,32 @@ compareHeadBlockNo ::
   Ordering
 compareHeadBlockNo = compare `on` AF.headBlockNo
 
-forksAtMostKBlocks ::
-  HasHeader b =>
-  -- | How many blocks can it fork?
-  Word64 ->
-  -- | Our chain.
+-- | Check that we can switch from @ours@ to @theirs@ by rolling back our chain
+-- by at most @k@ weight.
+--
+-- If @ours@ and @cand@ do not intersect, this returns 'False'. If they do
+-- intersect, then we check that the suffix of @ours@ after the intersection has
+-- total weight at most @k@.
+forksAtMostKWeight ::
+  ( StandardHash blk
+  , HasHeader b
+  , HeaderHash blk ~ HeaderHash b
+  ) =>
+  PerasWeightSnapshot blk ->
+  -- | By how much weight can we roll back our chain at most?
+  PerasWeight ->
+  -- | Our chain @ours@.
   AnchoredFragment b ->
-  -- | Their chain
+  -- | Their chain @theirs@.
   AnchoredFragment b ->
-  -- | Indicates whether their chain forks at most the
-  -- specified number of blocks.
+  -- | Indicates whether their chain forks at most the given the amount of
+  -- weight. Returns 'False' if the two fragments do not intersect.
   Bool
-forksAtMostKBlocks k ours theirs = case ours `AF.intersect` theirs of
-  Nothing -> False
-  Just (_, _, ourSuffix, _) -> fromIntegral (AF.length ourSuffix) <= k
+forksAtMostKWeight weights maxWeight ours theirs =
+  case ours `AF.intersect` theirs of
+    Nothing -> False
+    Just (_, _, ourSuffix, _) ->
+      totalWeightOfFragment weights ourSuffix <= maxWeight
 
 -- | Compare two (potentially empty!) 'AnchoredFragment's.
 --

ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs

@@ -119,6 +119,12 @@ instance ToExpr FsError where
 
 deriving instance ToExpr a => ToExpr (LoE a)
 
+deriving anyclass instance ToExpr PerasRoundNo
+
+deriving anyclass instance ToExpr PerasWeight
+
+deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (PerasCert blk)
+
 {-------------------------------------------------------------------------------
   si-timers
 --------------------------------------------------------------------------------}

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

@@ -25,6 +25,7 @@ module Test.Ouroboros.Storage.ChainDB.Model
   , addBlock
   , addBlockPromise
   , addBlocks
+  , addPerasCert
   , empty
 
     -- * Queries
@@ -44,7 +45,7 @@ module Test.Ouroboros.Storage.ChainDB.Model
   , invalid
   , isOpen
   , isValid
-  , lastK
+  , maxPerasRoundNo
   , tipBlock
   , tipPoint
   , volatileChain
@@ -90,6 +91,7 @@ import Control.Monad.Except (runExcept)
 import Data.Bifunctor (first)
 import qualified Data.ByteString.Lazy as Lazy
 import Data.Containers.ListUtils (nubOrdOn)
+import Data.Foldable (foldMap')
 import Data.Function (on, (&))
 import Data.Functor (($>), (<&>))
 import Data.List (isInfixOf, isPrefixOf, sortBy)
@@ -100,7 +102,6 @@ import Data.Proxy
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.TreeDiff
-import Data.Word (Word64)
 import GHC.Generics (Generic)
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Config
@@ -147,6 +148,7 @@ data Model blk = Model
   -- ^ The VolatileDB
   , immutableDbChain :: Chain blk
   -- ^ The ImmutableDB
+  , perasCerts :: Map PerasRoundNo (PerasCert blk)
   , cps :: CPS.ChainProducerState blk
   , currentLedger :: ExtLedgerState blk EmptyMK
   , initLedger :: ExtLedgerState blk EmptyMK
@@ -233,72 +235,78 @@ tipPoint = maybe GenesisPoint blockPoint . tipBlock
 getMaxSlotNo :: HasHeader blk => Model blk -> MaxSlotNo
 getMaxSlotNo = foldMap (MaxSlotNo . blockSlot) . blocks
 
-lastK ::
-  HasHeader a =>
-  SecurityParam ->
-  -- | Provided since `AnchoredFragment` is not a functor
-  (blk -> a) ->
-  Model blk ->
-  AnchoredFragment a
-lastK (SecurityParam k) f =
-  Fragment.anchorNewest (unNonZero k)
-    . Chain.toAnchoredFragment
-    . fmap f
-    . currentChain
-
--- | Actual number of blocks that can be rolled back. Equal to @k@, except
--- when:
+-- | Actual amount of weight that can be rolled back. This can non-trivially
+-- smaller than @k@ in the following cases:
 --
--- * Near genesis, the chain might not be @k@ blocks long yet.
--- * After VolatileDB corruption, the whole chain might be >= @k@ blocks, but
---   the tip of the ImmutableDB might be closer than @k@ blocks away from the
---   current chain's tip.
-maxActualRollback :: HasHeader blk => SecurityParam -> Model blk -> Word64
+-- * Near genesis, the chain might not have grown sufficiently yet.
+-- * After VolatileDB corruption, the whole chain might have more than weight
+--   @k@, but the tip of the ImmutableDB might be buried under significantly
+--   less than weight @k@ worth of blocks.
+maxActualRollback :: HasHeader blk => SecurityParam -> Model blk -> PerasWeight
 maxActualRollback k m =
-  fromIntegral
-    . length
+  foldMap' (weightBoostOfPoint weights)
     . takeWhile (/= immutableTipPoint)
     . map blockPoint
     . Chain.toNewestFirst
     . currentChain
     $ m
  where
+  weights = perasWeights m
+
   immutableTipPoint = Chain.headPoint (immutableChain k m)
 
 -- | Return the immutable prefix of the current chain.
 --
 -- This is the longest of the given two chains:
 --
--- 1. The current chain with the last @k@ blocks dropped.
+-- 1. The current chain with the longest suffix of weight at most @k@ dropped.
 -- 2. The chain formed by the blocks in 'immutableDbChain', i.e., the
 --    \"ImmutableDB\". We need to take this case in consideration because the
 --    VolatileDB might have been wiped.
 --
--- We need this because we do not allow rolling back more than @k@ blocks, but
+-- We need this because we do not allow rolling back more than weight @k@, but
 -- the background thread copying blocks from the VolatileDB to the ImmutableDB
 -- might not have caught up yet. This means we cannot use the tip of the
 -- ImmutableDB to know the most recent \"immutable\" block.
 immutableChain ::
+  forall blk.
+  HasHeader blk =>
   SecurityParam ->
   Model blk ->
   Chain blk
-immutableChain (SecurityParam k) m =
+immutableChain k m =
   maxBy
+    -- As one of the two chains is a prefix of the other, Peras weight doesn't
+    -- matter here.
     Chain.length
-    (Chain.drop (fromIntegral $ unNonZero k) (currentChain m))
+    (dropAtMostWeight (maxRollbackWeight k) (currentChain m))
     (immutableDbChain m)
  where
   maxBy f a b
     | f a >= f b = a
     | otherwise = b
 
+  weights = perasWeights m
+
+  -- Drop the longest suffix with at most the given weight.
+  dropAtMostWeight :: PerasWeight -> Chain blk -> Chain blk
+  dropAtMostWeight budget = go mempty
+   where
+    go w = \case
+      Genesis -> Genesis
+      c@(c' :> b)
+        | w' <= budget -> go w' c'
+        | otherwise -> c
+       where
+        w' = w <> PerasWeight 1 <> weightBoostOfPoint weights (blockPoint b)
+
 -- | Return the volatile suffix of the current chain.
 --
 -- The opposite of 'immutableChain'.
 --
 -- This is the shortest of the given two chain fragments:
 --
--- 1. The last @k@ blocks of the current chain.
+-- 1. The longest suffix of the current chain with weight at most @k@.
 -- 2. The suffix of the current chain not part of the 'immutableDbChain', i.e.,
 --    the \"ImmutableDB\".
 volatileChain ::
@@ -370,6 +378,17 @@ isValid = flip getIsValid
 getLoEFragment :: Model blk -> LoE (AnchoredFragment blk)
 getLoEFragment = loeFragment
 
+perasWeights :: StandardHash blk => Model blk -> PerasWeightSnapshot blk
+perasWeights =
+  mkPerasWeightSnapshot
+    -- TODO make boost per cert configurable
+    . fmap (\c -> (perasCertBoostedBlock c, boostPerCert))
+    . Map.elems
+    . perasCerts
+
+maxPerasRoundNo :: Model blk -> Maybe PerasRoundNo
+maxPerasRoundNo m = fst <$> Map.lookupMax (perasCerts m)
+
 {-------------------------------------------------------------------------------
   Construction
 -------------------------------------------------------------------------------}
@@ -383,6 +402,7 @@ empty loe initLedger =
   Model
     { volatileDbBlocks = Map.empty
     , immutableDbChain = Chain.Genesis
+    , perasCerts = Map.empty
     , cps = CPS.initChainProducerState Chain.Genesis
     , currentLedger = initLedger
     , initLedger = initLedger
@@ -422,6 +442,23 @@ addBlock cfg blk m
       -- If it's an invalid block we've seen before, ignore it.
       Map.member (blockHash blk) (invalid m)
 
+addPerasCert ::
+  forall blk.
+  (LedgerSupportsProtocol blk, LedgerTablesAreTrivial (ExtLedgerState blk)) =>
+  TopLevelConfig blk ->
+  PerasCert blk ->
+  Model blk ->
+  Model blk
+addPerasCert cfg cert m
+  -- Do not alter the model when a certificate for that round already exists.
+  | Map.member certRound (perasCerts m) = m
+  | otherwise =
+      chainSelection
+        cfg
+        m{perasCerts = Map.insert certRound cert (perasCerts m)}
+ where
+  certRound = perasCertRound cert
+
 chainSelection ::
   forall blk.
   ( LedgerTablesAreTrivial (ExtLedgerState blk)
@@ -434,6 +471,7 @@ chainSelection cfg m =
   Model
     { volatileDbBlocks = volatileDbBlocks m
     , immutableDbChain = immutableDbChain m
+    , perasCerts = perasCerts m
     , cps = CPS.switchFork newChain (cps m)
     , currentLedger = newLedger
     , initLedger = initLedger m
@@ -533,15 +571,12 @@ chainSelection cfg m =
       . selectChain
         (Proxy @(BlockProtocol blk))
         (projectChainOrderConfig (configBlock cfg))
-        ( weightedSelectView (configBlock cfg) weights
+        ( weightedSelectView (configBlock cfg) (perasWeights m)
             . Chain.toAnchoredFragment
             . fmap getHeader
         )
         (currentChain m)
       $ consideredCandidates
-   where
-    -- TODO enrich with Peras weights/certs
-    weights = emptyPerasWeightSnapshot
 
   -- We update the set of valid blocks with all valid blocks on all candidate
   -- chains that are considered by the modeled chain selection. This ensures
@@ -871,12 +906,9 @@ validChains cfg m bs =
   sortChains =
     sortBy $
       flip
-        ( Fragment.compareAnchoredFragments (configBlock cfg) weights
+        ( Fragment.compareAnchoredFragments (configBlock cfg) (perasWeights m)
             `on` (Chain.toAnchoredFragment . fmap getHeader)
         )
-   where
-    -- TODO enrich with Peras weights/certs
-    weights = emptyPerasWeightSnapshot
 
   classify ::
     ValidatedChain blk ->
@@ -910,7 +942,11 @@ between k from to m = do
   fork <- errFork
   -- See #871.
   if partOfCurrentChain fork
-    || Fragment.forksAtMostKBlocks (maxActualRollback k m) currentFrag fork
+    || Fragment.forksAtMostKWeight
+      (perasWeights m)
+      (maxActualRollback k m)
+      currentFrag
+      fork
     then return $ Fragment.toOldestFirst fork
     -- We cannot stream from an old fork
     else Left $ ForkTooOld from
@@ -1050,6 +1086,7 @@ garbageCollect ::
 garbageCollect secParam m@Model{..} =
   m
     { volatileDbBlocks = Map.filter (not . collectable) volatileDbBlocks
+    -- TODO garbage collection Peras certs?
     }
  where
   -- TODO what about iterators that will stream garbage collected blocks?
@@ -1101,6 +1138,14 @@ wipeVolatileDB cfg m =
   m' =
     (closeDB m)
       { volatileDbBlocks = Map.empty
+      , -- TODO: Currently, the SUT has no persistence of Peras certs across
+        -- restarts, but this will change. There are at least two options:
+        --
+        --  * Change this command to mean "wipe volatile state" (including
+        --    volatile certificates)
+        --
+        --  * Add a separate "Wipe volatile certs".
+        perasCerts = Map.empty
       , cps = CPS.switchFork newChain (cps m)
       , currentLedger = newLedger
       , invalid = Map.empty

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

@@ -22,7 +22,6 @@
 -- chain DB, we always pick the most preferred chain.
 module Test.Ouroboros.Storage.ChainDB.Model.Test (tests) where
 
-import Cardano.Ledger.BaseTypes (unNonZero)
 import GHC.Stack
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Config
@@ -97,13 +96,13 @@ prop_alwaysPickPreferredChain bt p =
 
   curFragment = Chain.toAnchoredFragment (getHeader <$> current)
 
-  SecurityParam k = configSecurityParam singleNodeTestConfig
+  k = configSecurityParam singleNodeTestConfig
 
   bcfg = configBlock singleNodeTestConfig
 
   preferCandidate' candidate =
     AF.preferAnchoredCandidate bcfg weights curFragment candFragment
-      && AF.forksAtMostKBlocks (unNonZero k) curFragment candFragment
+      && AF.forksAtMostKWeight weights (maxRollbackWeight k) curFragment candFragment
    where
     candFragment = Chain.toAnchoredFragment (getHeader <$> candidate)