Don't define preferCandidate in terms of Ord

We want to restrict the Praos VRF tiebreakers based on slot distance. Naively
adaopting the `Ord` instance will however make the chain order non-transitive.
As a solution, we allow to customize the logic of `preferCandidate`, while still
keeping a total chain order.

Author: amesgen

ouroboros-consensus-protocol/changelog.d/20240417_122550_alexander.esgen_customize_prefer_candidate.md

@@ -0,0 +1,3 @@
+### Non-Breaking
+
+- Adapted to introduction of new `ChainOrder` type class.

ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs

@@ -2,8 +2,11 @@
 {-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE DerivingVia                #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances       #-}
 
 -- | Various things common to iterations of the Praos protocol.
 module Ouroboros.Consensus.Protocol.Praos.Common (
@@ -41,15 +44,7 @@ newtype MaxMajorProtVer = MaxMajorProtVer
   deriving (Eq, Show, Generic)
   deriving newtype NoThunks
 
--- | View of the ledger tip for chain selection.
---
--- We order between chains as follows:
---
--- 1. By chain length, with longer chains always preferred.
--- 2. If the tip of each chain was issued by the same agent, then we prefer
---    the chain whose tip has the highest ocert issue number.
--- 3. By a VRF value from the chain tip, with lower values preferred. See
---    @pTieBreakVRFValue@ for which one is used.
+-- | View of the tip of a header fragment for chain selection.
 data PraosChainSelectView c = PraosChainSelectView
   { csvChainLength :: BlockNo,
     csvSlotNo      :: SlotNo,
@@ -59,6 +54,13 @@ data PraosChainSelectView c = PraosChainSelectView
   }
   deriving (Show, Eq, Generic, NoThunks)
 
+-- | We order between chains as follows:
+--
+-- 1. By chain length, with longer chains always preferred.
+-- 2. If the tip of each chain was issued by the same agent, then we prefer
+--    the chain whose tip has the highest ocert issue number.
+-- 3. By a VRF value from the chain tip, with lower values preferred. See
+--    @pTieBreakVRFValue@ for which one is used.
 instance Crypto c => Ord (PraosChainSelectView c) where
   compare =
     mconcat
@@ -80,6 +82,9 @@ instance Crypto c => Ord (PraosChainSelectView c) where
         | otherwise =
             EQ
 
+deriving via SimpleChainOrder (PraosChainSelectView c)
+  instance Crypto c => ChainOrder (PraosChainSelectView c)
+
 data PraosCanBeLeader c = PraosCanBeLeader
   { -- | Certificate delegating rights from the stake pool cold key (or
     -- genesis stakeholder delegate cold key) to the online KES key.

ouroboros-consensus/changelog.d/20240417_122327_alexander.esgen_customize_prefer_candidate.md

@@ -0,0 +1,5 @@
+### Breaking
+
+- Introduced new `ChainOrder` (with `preferCandidate`) class for `SelectView`s,
+  and add necessary instances. Adapted `preferAnchoredCandidate` to use
+  `preferCandidate` instead of relying on `preferAnchoredFragment`.

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsProtocol.hs

@@ -34,3 +34,13 @@ class ( GetHeader blk
                      => BlockConfig blk
                      -> Header blk -> SelectView (BlockProtocol blk)
   selectView _ = blockNo
+
+  projectChainOrderConfig ::
+       BlockConfig blk
+    -> ChainOrderConfig (SelectView (BlockProtocol blk))
+
+  default projectChainOrderConfig ::
+       ChainOrderConfig (SelectView (BlockProtocol blk)) ~ ()
+    => BlockConfig blk
+    -> ChainOrderConfig (SelectView (BlockProtocol blk))
+  projectChainOrderConfig _ = ()

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs

@@ -21,6 +21,7 @@
 module Ouroboros.Consensus.HardFork.Combinator.AcrossEras (
     -- * Value for /each/ era
     PerEraBlockConfig (..)
+  , PerEraChainOrderConfig (..)
   , PerEraCodecConfig (..)
   , PerEraConsensusConfig (..)
   , PerEraLedgerConfig (..)
@@ -97,13 +98,14 @@ import           Ouroboros.Consensus.Util.Condense (Condense (..))
   Value for /each/ era
 -------------------------------------------------------------------------------}
 
-newtype PerEraBlockConfig     xs = PerEraBlockConfig     { getPerEraBlockConfig     :: NP BlockConfig                xs }
-newtype PerEraCodecConfig     xs = PerEraCodecConfig     { getPerEraCodecConfig     :: NP CodecConfig                xs }
-newtype PerEraConsensusConfig xs = PerEraConsensusConfig { getPerEraConsensusConfig :: NP WrapPartialConsensusConfig xs }
-newtype PerEraLedgerConfig    xs = PerEraLedgerConfig    { getPerEraLedgerConfig    :: NP WrapPartialLedgerConfig    xs }
-newtype PerEraStorageConfig   xs = PerEraStorageConfig   { getPerEraStorageConfig   :: NP StorageConfig              xs }
+newtype PerEraBlockConfig      xs = PerEraBlockConfig      { getPerEraBlockConfig      :: NP BlockConfig                xs }
+newtype PerEraChainOrderConfig xs = PerEraChainOrderConfig { getPerEraChainOrderConfig :: NP WrapChainOrderConfig       xs }
+newtype PerEraCodecConfig      xs = PerEraCodecConfig      { getPerEraCodecConfig      :: NP CodecConfig                xs }
+newtype PerEraConsensusConfig  xs = PerEraConsensusConfig  { getPerEraConsensusConfig  :: NP WrapPartialConsensusConfig xs }
+newtype PerEraLedgerConfig     xs = PerEraLedgerConfig     { getPerEraLedgerConfig     :: NP WrapPartialLedgerConfig    xs }
+newtype PerEraStorageConfig    xs = PerEraStorageConfig    { getPerEraStorageConfig    :: NP StorageConfig              xs }
 
-newtype PerEraProtocolParams  xs = PerEraProtocolParams  { getPerEraProtocolParams  :: NP ProtocolParams             xs }
+newtype PerEraProtocolParams   xs = PerEraProtocolParams   { getPerEraProtocolParams   :: NP ProtocolParams             xs }
 
 {-------------------------------------------------------------------------------
   Values for /some/ eras

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs

@@ -71,10 +71,26 @@ newtype HardForkSelectView xs = HardForkSelectView {
 
 instance CanHardFork xs => Ord (HardForkSelectView xs) where
   compare (HardForkSelectView l) (HardForkSelectView r) =
-     acrossEraSelection
-       hardForkChainSel
-       (mapWithBlockNo getOneEraSelectView l)
-       (mapWithBlockNo getOneEraSelectView r)
+      acrossEraSelection
+        AcrossEraCompare
+        (hpure Proxy)
+        hardForkChainSel
+        (mapWithBlockNo getOneEraSelectView l)
+        (mapWithBlockNo getOneEraSelectView r)
+
+instance CanHardFork xs => ChainOrder (HardForkSelectView xs) where
+  type ChainOrderConfig (HardForkSelectView xs) = PerEraChainOrderConfig xs
+
+  preferCandidate
+    (PerEraChainOrderConfig cfg)
+    (HardForkSelectView ours)
+    (HardForkSelectView cand) =
+      acrossEraSelection
+        AcrossEraPreferCandidate
+        cfg
+        hardForkChainSel
+        (mapWithBlockNo getOneEraSelectView ours)
+        (mapWithBlockNo getOneEraSelectView cand)
 
 mkHardForkSelectView ::
      BlockNo
@@ -133,6 +149,12 @@ instance CanHardFork xs => BlockSupportsProtocol (HardForkBlock xs) where
     where
       cfgs = getPerEraBlockConfig hardForkBlockConfigPerEra
 
+  projectChainOrderConfig =
+        PerEraChainOrderConfig
+      . hcmap proxySingle (WrapChainOrderConfig . projectChainOrderConfig)
+      . getPerEraBlockConfig
+      . hardForkBlockConfigPerEra
+
 {-------------------------------------------------------------------------------
   Ticking the chain dependent state
 -------------------------------------------------------------------------------}

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol/ChainSel.hs

@@ -11,7 +11,8 @@
 
 -- | Infrastructure for doing chain selection across eras
 module Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel (
-    AcrossEraSelection (..)
+    AcrossEraMode (..)
+  , AcrossEraSelection (..)
   , WithBlockNo (..)
   , acrossEraSelection
   , mapWithBlockNo
@@ -41,7 +42,12 @@ data AcrossEraSelection :: Type -> Type -> Type where
 
   -- | Two eras using the same 'SelectView'. In this case, we can just compare
   -- chains even across eras, as the chain ordering is fully captured by
-  -- 'SelectView' and its 'Ord' instance.
+  -- 'SelectView' and its 'ChainOrder' instance.
+  --
+  -- We use the 'ChainOrderConfig' of the 'SelectView' in the newer era (with
+  -- the intuition that newer eras are generally "preferred") when invoking
+  -- 'compareChains'. However, this choice is arbitrary; we could also make it
+  -- configurable here.
   CompareSameSelectView ::
        SelectView (BlockProtocol x) ~ SelectView (BlockProtocol y)
     => AcrossEraSelection x y
@@ -50,55 +56,99 @@ data AcrossEraSelection :: Type -> Type -> Type where
   Compare two eras
 -------------------------------------------------------------------------------}
 
+
+-- | GADT indicating whether we are lifting 'compare' or 'preferCandidate' to
+-- the HFC, together with the type of configuration we need for that and the
+-- result type.
+data AcrossEraMode cfg a where
+  AcrossEraCompare         :: AcrossEraMode Proxy                Ordering
+  AcrossEraPreferCandidate :: AcrossEraMode WrapChainOrderConfig Bool
+
+applyAcrossEraMode ::
+     ChainOrder sv
+  => cfg blk
+  -> (WrapChainOrderConfig blk -> ChainOrderConfig sv)
+  -> AcrossEraMode cfg a
+  -> sv -> sv -> a
+applyAcrossEraMode cfg f = \case
+    AcrossEraCompare         -> compare
+    AcrossEraPreferCandidate -> preferCandidate (f cfg)
+
+data FlipArgs = KeepArgs | FlipArgs
+
 acrossEras ::
-     forall blk blk'. SingleEraBlock blk
-  => WithBlockNo WrapSelectView blk
+     forall blk blk' cfg a. SingleEraBlock blk
+  => FlipArgs
+  -> AcrossEraMode cfg a
+  -> cfg                        blk'
+     -- ^ The configuration corresponding to the later block/era, also see
+     -- 'CompareSameSelectView'.
+  -> WithBlockNo WrapSelectView blk
   -> WithBlockNo WrapSelectView blk'
   -> AcrossEraSelection blk blk'
-  -> Ordering
-acrossEras (WithBlockNo bnoL (WrapSelectView l))
-           (WithBlockNo bnoR (WrapSelectView r)) = \case
-    CompareBlockNo        -> compare bnoL bnoR
-    CompareSameSelectView -> compare l r
+  -> a
+acrossEras flipArgs mode cfg
+  (WithBlockNo bnoL (WrapSelectView l))
+  (WithBlockNo bnoR (WrapSelectView r)) = \case
+    CompareBlockNo        -> maybeFlip cmp bnoL bnoR
+      where
+        cmp = applyAcrossEraMode cfg (const ()) mode
+    CompareSameSelectView -> maybeFlip cmp l r
+      where
+        cmp = applyAcrossEraMode cfg (unwrapChainOrderConfig) mode
+  where
+    maybeFlip :: (b -> b -> a) -> b -> b -> a
+    maybeFlip = case flipArgs of
+      KeepArgs -> id
+      FlipArgs -> flip
 
 acrossEraSelection ::
+     forall xs cfg a.
      All SingleEraBlock              xs
-  => Tails AcrossEraSelection        xs
+  => AcrossEraMode cfg a
+  -> NP cfg                          xs
+  -> Tails AcrossEraSelection        xs
   -> WithBlockNo (NS WrapSelectView) xs
   -> WithBlockNo (NS WrapSelectView) xs
-  -> Ordering
-acrossEraSelection = \ffs l r ->
-    goLeft ffs (distribBlockNo l, distribBlockNo r)
+  -> a
+acrossEraSelection mode = \cfg ffs l r ->
+    goBoth cfg ffs (distribBlockNo l, distribBlockNo r)
   where
-    goLeft ::
-         All SingleEraBlock                xs
-      => Tails AcrossEraSelection          xs
-      -> ( NS (WithBlockNo WrapSelectView) xs
-         , NS (WithBlockNo WrapSelectView) xs
+    goBoth ::
+         All SingleEraBlock                xs'
+      => NP cfg                            xs'
+      -> Tails AcrossEraSelection          xs'
+      -> ( NS (WithBlockNo WrapSelectView) xs'
+         , NS (WithBlockNo WrapSelectView) xs'
          )
-      -> Ordering
-    goLeft TNil            = \(a, _) -> case a of {}
-    goLeft (TCons fs ffs') = \case
-        (Z a, Z b) -> compare (dropBlockNo a) (dropBlockNo b)
-        (Z a, S b) ->          goRight a fs b
-        (S a, Z b) -> invert $ goRight b fs a
-        (S a, S b) -> goLeft ffs' (a, b)
-
-    goRight ::
-         forall x xs. (SingleEraBlock x, All SingleEraBlock xs)
-      => WithBlockNo WrapSelectView x
-      -> NP (AcrossEraSelection     x)   xs
-      -> NS (WithBlockNo WrapSelectView) xs
-      -> Ordering
-    goRight a = go
+      -> a
+    goBoth _             TNil            = \(a, _) -> case a of {}
+    goBoth (cfg :* cfgs) (TCons fs ffs') = \case
+        (Z a, Z b) -> cmp (dropBlockNo a) (dropBlockNo b)
+          where
+            cmp = applyAcrossEraMode cfg unwrapChainOrderConfig mode
+        (Z a, S b) -> goOne KeepArgs a cfgs fs b
+        (S a, Z b) -> goOne FlipArgs b cfgs fs a
+        (S a, S b) -> goBoth cfgs ffs' (a, b)
+
+    goOne ::
+         forall x xs'. (SingleEraBlock x, All SingleEraBlock xs')
+      => FlipArgs
+      -> WithBlockNo WrapSelectView x
+      -> NP cfg                          xs'
+      -> NP (AcrossEraSelection     x)   xs'
+      -> NS (WithBlockNo WrapSelectView) xs'
+      -> a
+    goOne flipArgs a = go
       where
-        go :: forall xs'. All SingleEraBlock  xs'
-           => NP (AcrossEraSelection x)       xs'
-           -> NS (WithBlockNo WrapSelectView) xs'
-           -> Ordering
-        go Nil          b  = case b of {}
-        go (f :* _)  (Z b) = acrossEras a b f
-        go (_ :* fs) (S b) = go fs b
+        go :: forall xs''. All SingleEraBlock xs''
+           => NP cfg                          xs''
+           -> NP (AcrossEraSelection x)       xs''
+           -> NS (WithBlockNo WrapSelectView) xs''
+           -> a
+        go _             Nil          b  = case b of {}
+        go (cfg :* _   ) (f :* _)  (Z b) = acrossEras flipArgs mode cfg a b f
+        go (_   :* cfgs) (_ :* fs) (S b) = go cfgs fs b
 
 {-------------------------------------------------------------------------------
   WithBlockNo
@@ -115,12 +165,3 @@ mapWithBlockNo f (WithBlockNo bno fx) = WithBlockNo bno (f fx)
 
 distribBlockNo :: SListI xs => WithBlockNo (NS f) xs -> NS (WithBlockNo f) xs
 distribBlockNo (WithBlockNo b ns) = hmap (WithBlockNo b) ns
-
-{-------------------------------------------------------------------------------
-  Auxiliary
--------------------------------------------------------------------------------}
-
-invert :: Ordering -> Ordering
-invert LT = GT
-invert GT = LT
-invert EQ = EQ

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs

@@ -288,6 +288,8 @@ instance Bridge m a => BlockSupportsProtocol (DualBlock m a) where
   validateView cfg = validateView (dualBlockConfigMain cfg) . dualHeaderMain
   selectView   cfg = selectView   (dualBlockConfigMain cfg) . dualHeaderMain
 
+  projectChainOrderConfig = projectChainOrderConfig . dualBlockConfigMain
+
 {-------------------------------------------------------------------------------
   Ledger errors
 -------------------------------------------------------------------------------}