Don't use Ord SelectView in the abstract consensus layer

A lawful `Ord` instance represents a total order. However, we want to adopt a
non-transitive tiebreaker rule (restricted VRF tiebreakers based on slot
distance), so we remove the `Ord` instance from the abstract Consensus layer and
instead introduce a custom class, `ChainOrder`.

TODO sorting subtlety

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/DiffusionPipelining.hs

@@ -121,13 +121,14 @@ instance
           }
 
   applyTentativeHeaderView _ thv st
-    | LegacyShelleyTentativeHeaderView thv' <- thv
+    | LegacyShelleyTentativeHeaderView sv' <- thv
     , LegacyShelleyTentativeHeaderState st' <- st
-    = LegacyShelleyTentativeHeaderState <$>
-        applyTentativeHeaderView
-          (Proxy @(SelectViewDiffusionPipelining (ShelleyBlock proto era)))
-          thv'
-          st'
+    = do
+        case st' of
+          NoLastInvalidSelectView  -> pure ()
+          LastInvalidSelectView sv -> guard $ compareChains sv sv' == LT
+        pure $ LegacyShelleyTentativeHeaderState $ LastInvalidSelectView sv'
+
     | ShelleyTentativeHeaderView bno hdrIdentity <- thv
     , ShelleyTentativeHeaderState lastBlockNo badIdentities <- st
     = case compare (NotOrigin bno) lastBlockNo of

ouroboros-consensus-protocol/changelog.d/20240409_141920_alexander.esgen_remove_ord_selectview.md

@@ -0,0 +1,3 @@
+### Breaking
+
+- Added `ChainOrder` instance for `PraosChainSelectView`, and `Ord` instance.

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

@@ -41,15 +41,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,8 +51,15 @@ data PraosChainSelectView c = PraosChainSelectView
   }
   deriving (Show, Eq, Generic, NoThunks)
 
-instance Crypto c => Ord (PraosChainSelectView c) where
-  compare =
+-- | 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 => ChainOrder (PraosChainSelectView c) where
+  compareChains =
     mconcat
       [ compare `on` csvChainLength,
         whenSame csvIssuer (compare `on` csvIssueNo),

ouroboros-consensus/changelog.d/20240409_141920_alexander.esgen_remove_ord_selectview.md

@@ -0,0 +1,3 @@
+### Breaking
+
+- Require `ChainOrder` for `SelectView` instead of `Ord`.

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

@@ -225,8 +225,8 @@ instance BlockSupportsDiffusionPipelining (DisableDiffusionPipelining blk) where
 -- >   instance BlockSupportsProtocol blk
 -- >   => BlockSupportsDiffusionPipelining MyBlock
 --
--- This requires that the 'SelectView' is totally ordered, in particular that
--- the order is transitive.
+-- This requires that the 'SelectView' is totally ordered via 'Ord', in
+-- particular that the order is transitive.
 --
 -- For example, if @'SelectView' ~ 'BlockNo'@, this means that a header can be
 -- pipelined if it has a larger block number than the last tentative trap
@@ -255,6 +255,7 @@ deriving anyclass instance ConsensusProtocol proto => NoThunks (SelectViewTentat
 instance
   ( BlockSupportsProtocol blk
   , Show (SelectView (BlockProtocol blk))
+  , Ord (SelectView (BlockProtocol blk))
   ) => BlockSupportsDiffusionPipelining (SelectViewDiffusionPipelining blk) where
   type TentativeHeaderState (SelectViewDiffusionPipelining blk) =
     SelectViewTentativeState (BlockProtocol blk)

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

@@ -69,8 +69,8 @@ newtype HardForkSelectView xs = HardForkSelectView {
   deriving (Show, Eq)
   deriving newtype (NoThunks)
 
-instance CanHardFork xs => Ord (HardForkSelectView xs) where
-  compare (HardForkSelectView l) (HardForkSelectView r) =
+instance CanHardFork xs => ChainOrder (HardForkSelectView xs) where
+  compareChains (HardForkSelectView l) (HardForkSelectView r) =
      acrossEraSelection
        hardForkChainSel
        (mapWithBlockNo getOneEraSelectView l)

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

@@ -41,7 +41,7 @@ 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.
   CompareSameSelectView ::
        SelectView (BlockProtocol x) ~ SelectView (BlockProtocol y)
     => AcrossEraSelection x y
@@ -59,7 +59,7 @@ acrossEras ::
 acrossEras (WithBlockNo bnoL (WrapSelectView l))
            (WithBlockNo bnoR (WrapSelectView r)) = \case
     CompareBlockNo        -> compare bnoL bnoR
-    CompareSameSelectView -> compare l r
+    CompareSameSelectView -> compareChains l r
 
 acrossEraSelection ::
      All SingleEraBlock              xs
@@ -79,7 +79,7 @@ acrossEraSelection = \ffs l r ->
       -> Ordering
     goLeft TNil            = \(a, _) -> case a of {}
     goLeft (TCons fs ffs') = \case
-        (Z a, Z b) -> compare (dropBlockNo a) (dropBlockNo b)
+        (Z a, Z b) -> compareChains (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)

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

@@ -1,17 +1,26 @@
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE DefaultSignatures          #-}
+{-# LANGUAGE DerivingVia                #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeFamilies               #-}
 
 module Ouroboros.Consensus.Protocol.Abstract (
     -- * Abstract definition of the Ouroboros protocol
     ConsensusConfig
   , ConsensusProtocol (..)
+    -- * Chain order
+  , ChainOrder (..)
+  , TotalChainOrder (..)
   , preferCandidate
     -- * Convenience re-exports
   , SecurityParam (..)
   ) where
 
 import           Control.Monad.Except
+import           Data.Coerce (coerce)
 import           Data.Kind (Type)
 import           Data.Typeable (Typeable)
 import           GHC.Stack
@@ -41,7 +50,7 @@ class ( Show (ChainDepState   p)
       , Show (LedgerView      p)
       , Eq   (ChainDepState   p)
       , Eq   (ValidationErr   p)
-      , Ord  (SelectView      p)
+      , ChainOrder (SelectView p)
       , NoThunks (ConsensusConfig p)
       , NoThunks (ChainDepState   p)
       , NoThunks (ValidationErr   p)
@@ -66,12 +75,10 @@ class ( Show (ChainDepState   p)
   -- two things independent of a choice of consensus protocol: we never switch
   -- to chains that fork off more than @k@ blocks ago, and we never adopt an
   -- invalid chain. The actual comparison of chains however depends on the chain
-  -- selection protocol. We define chain selection (which is itself a partial
-  -- order) in terms of a totally ordered /select view/ on the headers at the
-  -- tips of those chains: chain A is strictly preferred over chain B whenever
-  -- A's select view is greater than B's select view. When the select view on A
-  -- and B is the same, the chains are considered to be incomparable (neither
-  -- chain is preferred over the other).
+  -- selection protocol. We define chain selection in terms of a /select view/
+  -- on the headers at the tips of those chains: chain A is strictly preferred
+  -- over chain B whenever A's select view is greater than B's select view
+  -- according to the 'ChainOrder' instance.
   type family SelectView p :: Type
   type SelectView p = BlockNo
 
@@ -170,6 +177,82 @@ class ( Show (ChainDepState   p)
   -- | We require that protocols support a @k@ security parameter
   protocolSecurityParam :: ConsensusConfig p -> SecurityParam
 
+-- | The chain order of some type; in the Consensus layer, this will always be
+-- the 'SelectView' of some 'ConsensusProtocol'.
+class Eq a => ChainOrder a where
+  -- | Compare chains via the information of @a@ as a proxy.
+  --
+  -- * If this returns 'LT' or 'GT', the latter or former chain is strictly
+  --   preferred, respectively, and can eg be adopted if the other one is
+  --   currently selected. (With Ouroboros Genesis, there are additional
+  --   concerns here based on where the two chains intersect.)
+  --
+  -- * If this returns 'EQ', the chains are equally preferrable. In that case,
+  --   the Ouroboros class of consensus protocols /always/ sticks with the
+  --   current chain.
+  --
+  -- === Requirements
+  --
+  -- Write @cc a b@ for @'compareChains' a b@ for brevity.
+  --
+  --  [__Reflexivity__]: @cc a a == EQ@ for all @a@.
+  --
+  --  [__Antisymmetry__]: For all @a, b@:
+  --
+  --      * @cc a b == LT@ if and only if @cc b a == GT@
+  --      * @cc a b == EQ@ if and only if @cc b a == EQ@
+  --      * @cc a b == GT@ if and only if @cc b a == LT@
+  --
+  --  [__Acyclicity__]: Consider the digraph with nodes @a@ and an edge from @v@
+  --      to @w@ if @cc v w == LT@. We require that this graph is /acyclic/.
+  --
+  --      Intuitively, this means that chain selection can never go into a loop
+  --      while repeatedly selecting the same chain.
+  --
+  --      TODO talk about using a topological sort?
+  --
+  --  [__Block number precedence__]: @a@ must contain the underlying block
+  --      number, and use this as the primary way of comparing chains.
+  --
+  --      Suppose that we have a function @blockNo :: a -> Natural@. Then
+  --      for all @a, b :: a@ with
+  --
+  --      @'compare' (blockNo a) (blockNo b) /= EQ@
+  --
+  --      we must have
+  --
+  --      @'compare' (blockNo a) (blockNo b) == cc a b@
+  --
+  --      Intuitively, this means that only the logic for breaking ties between
+  --      chains with equal block number is customizable via this class.
+  --
+  -- === Transitivity as a non-requirement
+  --
+  -- We do /not/ require this relation to be transitive, ie that @cc a b == LT@
+  -- and @cc b c == LT@ implies @cc a c == LT@ for all @a, b, c@.
+  --
+  -- Note that due to the __Block number precedence__ requirement, violations of
+  -- transitivity can only occur when @a@, @b@ and @c@ have equal block number.
+  --
+  -- Generally, it is recommended to write a transitive chain order if possible
+  -- (hence inducing a total order on @a@), see 'TotalChainOrder', as it
+  -- simplifies reasoning about its behavior. In particular, any transitive
+  -- chain order is automatically acyclic.
+  --
+  -- However, forgoing transitivity can enable more sophisticated tiebreaking
+  -- rules that eg exhibit desirable incentive behavior.
+  compareChains :: a -> a -> Ordering
+
+-- | A @DerivingVia@ helper in case the chain order is a total order (in
+-- particular, transitive).
+newtype TotalChainOrder a = TotalChainOrder a
+  deriving newtype (Eq)
+
+instance Ord a => ChainOrder (TotalChainOrder a) where
+  compareChains = coerce (compare @a)
+
+deriving via TotalChainOrder BlockNo instance ChainOrder BlockNo
+
 -- | Compare a candidate chain to our own
 --
 -- If both chains are equally preferable, the Ouroboros class of consensus
@@ -179,4 +262,4 @@ preferCandidate :: ConsensusProtocol p
                 -> SelectView p  -- ^ Tip of our chain
                 -> SelectView p  -- ^ Tip of the candidate
                 -> Bool
-preferCandidate _ ours cand = cand > ours
+preferCandidate _ ours cand = compareChains cand ours == GT

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

@@ -6,9 +6,9 @@ module Ouroboros.Consensus.Protocol.MockChainSel (
   , selectUnvalidatedChain
   ) where
 
-import           Data.List (sortOn)
+import           Data.Function (on)
+import           Data.List (sortBy)
 import           Data.Maybe (listToMaybe, mapMaybe)
-import           Data.Ord (Down (..))
 import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Network.Mock.Chain (Chain)
 import qualified Ouroboros.Network.Mock.Chain as Chain
@@ -38,7 +38,7 @@ selectChain :: forall proxy p hdr l. ConsensusProtocol p
 selectChain p view ours =
       listToMaybe
     . map snd
-    . sortOn (Down . fst)
+    . sortBy (flip compareChains `on` fst)
     . mapMaybe selectPreferredCandidate
   where
     -- | Only retain a candidate if it is preferred over the current chain. As

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

@@ -21,7 +21,7 @@ newtype instance ConsensusConfig (ModChainSel p s) = McsConsensusConfig {
   deriving (Generic)
 
 instance ( ConsensusProtocol p
-         , Ord  s
+         , ChainOrder s
          , Show s
          , Typeable s
          , NoThunks s

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveAnyClass            #-}
 {-# LANGUAGE DeriveGeneric             #-}
+{-# LANGUAGE DerivingVia               #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts          #-}
 {-# LANGUAGE FlexibleInstances         #-}
@@ -135,7 +136,9 @@ data PBftSelectView = PBftSelectView {
       pbftSelectViewBlockNo :: BlockNo
     , pbftSelectViewIsEBB   :: IsEBB
     }
-  deriving (Show, Eq, Generic, NoThunks)
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NoThunks)
+  deriving (ChainOrder) via TotalChainOrder PBftSelectView
 
 mkPBftSelectView :: GetHeader blk => Header blk -> PBftSelectView
 mkPBftSelectView hdr = PBftSelectView {

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs

@@ -149,6 +149,8 @@ deriving instance Eq (ValidationErr (BlockProtocol blk)) => Eq (WrapValidationEr
 
 deriving instance Ord (SelectView (BlockProtocol blk)) => Ord (WrapSelectView blk)
 
+deriving instance ChainOrder (SelectView (BlockProtocol blk)) => ChainOrder (WrapSelectView blk)
+
 deriving instance Show (ChainDepState (BlockProtocol blk)) => Show (WrapChainDepState blk)
 deriving instance Show (LedgerView    (BlockProtocol blk)) => Show (WrapLedgerView    blk)
 deriving instance Show (SelectView    (BlockProtocol blk)) => Show (WrapSelectView    blk)

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

@@ -22,6 +22,7 @@ import           Data.Maybe (isJust)
 import           Data.Word (Word64)
 import           GHC.Stack
 import           Ouroboros.Consensus.Block
+import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.Util.Assert
 import           Ouroboros.Network.AnchoredFragment (AnchoredFragment,
                      AnchoredSeq (Empty, (:>)))
@@ -112,7 +113,7 @@ compareAnchoredFragments cfg frag1 frag2 =
           else GT
       (_ :> tip, _ :> tip') ->
         -- Case 4
-        compare
+        compareChains
           (selectView cfg tip)
           (selectView cfg tip')
   where

ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs

@@ -60,6 +60,7 @@ instance BlockSupportsMetrics (SimpleBlock c ext) where
 deriving via SelectViewDiffusionPipelining (SimpleBlock c ext) instance
   ( BlockSupportsProtocol (SimpleBlock c ext)
   , Show (SelectView (BlockProtocol (SimpleBlock c ext)))
+  , Ord  (SelectView (BlockProtocol (SimpleBlock c ext)))
   ) => BlockSupportsDiffusionPipelining (SimpleBlock c ext)
 
 instance ( LedgerSupportsProtocol      (SimpleBlock SimpleMockCrypto ext)
@@ -68,6 +69,7 @@ instance ( LedgerSupportsProtocol      (SimpleBlock SimpleMockCrypto ext)
          , Show (ForgeStateUpdateError (SimpleBlock SimpleMockCrypto ext))
          , Serialise ext
          , RunMockBlock SimpleMockCrypto ext
+         , Ord (SelectView (BlockProtocol (SimpleBlock SimpleMockCrypto ext)))
          ) => RunNode (SimpleBlock SimpleMockCrypto ext)
 
 {-------------------------------------------------------------------------------

ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs

@@ -97,6 +97,7 @@ import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Node.ProtocolInfo
 import           Ouroboros.Consensus.Node.Run
 import           Ouroboros.Consensus.NodeId
+import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.Protocol.BFT
 import           Ouroboros.Consensus.Protocol.ModChainSel
 import           Ouroboros.Consensus.Protocol.Signed
@@ -459,7 +460,9 @@ data BftWithEBBsSelectView = BftWithEBBsSelectView {
     , bebbChainLength :: !ChainLength
     , bebbHash        :: !TestHeaderHash
     }
-  deriving (Show, Eq, Generic, NoThunks)
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NoThunks)
+  deriving (ChainOrder) via TotalChainOrder BftWithEBBsSelectView
 
 instance Ord BftWithEBBsSelectView where
   compare (BftWithEBBsSelectView lBlockNo lIsEBB lChainLength lHash)