MockChainSel: switch to weighted chain selection

Author: amesgen

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs

@@ -9,9 +9,9 @@ module Ouroboros.Consensus.Protocol.MockChainSel
 import Data.List (sortOn)
 import Data.Maybe (listToMaybe, mapMaybe)
 import Data.Ord (Down (..))
+import Ouroboros.Consensus.Peras.SelectView (WeightedSelectView (..), WithEmptyFragment (..))
 import Ouroboros.Consensus.Protocol.Abstract
 import Ouroboros.Network.Mock.Chain (Chain)
-import qualified Ouroboros.Network.Mock.Chain as Chain
 
 {-------------------------------------------------------------------------------
   Chain selection
@@ -33,8 +33,9 @@ selectChain ::
   forall proxy p hdr l.
   ConsensusProtocol p =>
   proxy p ->
-  ChainOrderConfig (SelectView p) ->
-  (hdr -> SelectView p) ->
+  ChainOrderConfig (WeightedSelectView p) ->
+  -- | Compute the 'WeightedSelectView' of a chain.
+  (Chain hdr -> WithEmptyFragment (WeightedSelectView p)) ->
   -- | Our chain
   Chain hdr ->
   -- | Upstream chains
@@ -51,24 +52,19 @@ selectChain _ cfg view ours =
   -- extract the 'SelectView' of the tip of the candidate.
   selectPreferredCandidate ::
     (Chain hdr, l) ->
-    Maybe (SelectView p, (Chain hdr, l))
-  selectPreferredCandidate x@(cand, _) =
-    case (Chain.head ours, Chain.head cand) of
-      (Nothing, Just candTip) ->
-        Just (view candTip, x)
-      (Just ourTip, Just candTip)
-        | let candView = view candTip
-        , preferCandidate cfg (view ourTip) candView ->
-            Just (candView, x)
-      _otherwise ->
-        Nothing
+    Maybe (WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))
+  selectPreferredCandidate x@(cand, _)
+    | let candView = view cand
+    , preferCandidate cfg (view ours) candView =
+        Just (candView, x)
+    | otherwise = Nothing
 
 -- | Chain selection on unvalidated chains
 selectUnvalidatedChain ::
   ConsensusProtocol p =>
   proxy p ->
-  ChainOrderConfig (SelectView p) ->
-  (hdr -> SelectView p) ->
+  ChainOrderConfig (WeightedSelectView p) ->
+  (Chain hdr -> WithEmptyFragment (WeightedSelectView p)) ->
   Chain hdr ->
   [Chain hdr] ->
   Maybe (Chain hdr)

ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs

@@ -139,6 +139,8 @@ import Ouroboros.Consensus.Ledger.Tables.Utils
 import Ouroboros.Consensus.Node.NetworkProtocolVersion
 import Ouroboros.Consensus.Node.ProtocolInfo
 import Ouroboros.Consensus.NodeId
+import Ouroboros.Consensus.Peras.SelectView (weightedSelectView)
+import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot)
 import Ouroboros.Consensus.Protocol.Abstract
 import Ouroboros.Consensus.Protocol.BFT
 import Ouroboros.Consensus.Protocol.MockChainSel
@@ -859,15 +861,21 @@ treeToBlocks = Tree.flatten . blockTree
 treeToChains :: BlockTree -> [Chain TestBlock]
 treeToChains = map Chain.fromOldestFirst . allPaths . blockTree
 
-treePreferredChain :: BlockTree -> Chain TestBlock
-treePreferredChain =
+treePreferredChain ::
+  PerasWeightSnapshot TestBlock ->
+  BlockTree ->
+  Chain TestBlock
+treePreferredChain weights =
   fromMaybe Genesis
     . selectUnvalidatedChain
       (Proxy @(BlockProtocol TestBlock))
       (() :: ChainOrderConfig (SelectView (BlockProtocol TestBlock)))
-      (\hdr -> SelectView (blockNo hdr) NoTiebreaker)
+      (weightedSelectView bcfg weights . Chain.toAnchoredFragment . fmap getHeader)
       Genesis
     . treeToChains
+ where
+  -- inconsequential for this function
+  bcfg = TestBlockConfig (NumCoreNodes 0)
 
 instance Show BlockTree where
   show (BlockTree t) = Tree.drawTree (fmap show t)

ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs

@@ -37,6 +37,7 @@ import Ouroboros.Consensus.Ledger.Query (Query (..))
 import Ouroboros.Consensus.MiniProtocol.LocalStateQuery.Server
 import Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..))
 import Ouroboros.Consensus.NodeId
+import Ouroboros.Consensus.Peras.Weight (emptyPerasWeightSnapshot)
 import Ouroboros.Consensus.Protocol.BFT
 import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache as BlockCache
 import Ouroboros.Consensus.Storage.ImmutableDB.Stream hiding
@@ -100,7 +101,7 @@ prop_localStateQueryServer ::
 prop_localStateQueryServer k bt p (Positive (Small n)) = checkOutcome k chain actualOutcome
  where
   chain :: Chain TestBlock
-  chain = treePreferredChain bt
+  chain = treePreferredChain emptyPerasWeightSnapshot bt
 
   points :: [Target (Point TestBlock)]
   points =

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

@@ -108,6 +108,7 @@ import Ouroboros.Consensus.HeaderValidation
 import Ouroboros.Consensus.Ledger.Abstract
 import Ouroboros.Consensus.Ledger.Extended
 import Ouroboros.Consensus.Ledger.SupportsProtocol
+import Ouroboros.Consensus.Peras.SelectView
 import Ouroboros.Consensus.Peras.Weight
 import Ouroboros.Consensus.Protocol.Abstract
 import Ouroboros.Consensus.Protocol.MockChainSel
@@ -532,9 +533,15 @@ chainSelection cfg m =
       . selectChain
         (Proxy @(BlockProtocol blk))
         (projectChainOrderConfig (configBlock cfg))
-        (selectView (configBlock cfg) . getHeader)
+        ( weightedSelectView (configBlock cfg) weights
+            . 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
@@ -1112,7 +1119,11 @@ wipeVolatileDB cfg m =
       $ selectChain
         (Proxy @(BlockProtocol blk))
         (projectChainOrderConfig (configBlock cfg))
-        (selectView (configBlock cfg) . getHeader)
+        -- Weight is inconsequential as there is only a single candidate.
+        ( weightedSelectView (configBlock cfg) emptyPerasWeightSnapshot
+            . Chain.toAnchoredFragment
+            . fmap getHeader
+        )
         Chain.genesis
       $ snd
       $ validChains cfg m (immutableDbBlocks m)