Conway: restrict VRF tiebreaker based on slot distance

ouroboros-consensus-cardano/changelog.d/20240409_142855_alexander.esgen_duncan_tiebreaker.md

@@ -0,0 +1,3 @@
+### Breaking
+
+- Restricted the VRF tiebreaker based on slot distance starting in Conway.

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

@@ -35,6 +35,8 @@ module Ouroboros.Consensus.Shelley.Eras (
   , WrapTx (..)
     -- * Type synonyms for convenience
   , EraCrypto
+    -- * Convenience functions
+  , isBeforeConway
     -- * Re-exports
   , StandardCrypto
   ) where
@@ -45,6 +47,7 @@ import           Cardano.Ledger.Alonzo (AlonzoEra)
 import qualified Cardano.Ledger.Alonzo.Rules as Alonzo
 import qualified Cardano.Ledger.Alonzo.Translation as Alonzo
 import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
+import qualified Cardano.Ledger.Api.Era as L
 import           Cardano.Ledger.Babbage (BabbageEra)
 import qualified Cardano.Ledger.Babbage.Rules as Babbage
 import qualified Cardano.Ledger.Babbage.Translation as Babbage
@@ -173,6 +176,10 @@ class ( Core.EraSegWits era
 data ConwayEraGovDict era where
     ConwayEraGovDict :: CG.ConwayEraGov era => ConwayEraGovDict era
 
+isBeforeConway :: forall era. L.Era era => Proxy era -> Bool
+isBeforeConway _ =
+    L.eraProtVerLow @era < L.eraProtVerLow @(L.ConwayEra (L.EraCrypto era))
+
 -- | The default implementation of 'applyShelleyBasedTx', a thin wrapper around
 -- 'SL.applyTx'
 defaultApplyShelleyBasedTx ::

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

@@ -4,7 +4,10 @@
 {-# LANGUAGE DerivingVia                #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TypeApplications           #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 module Ouroboros.Consensus.Shelley.Ledger.Config (
@@ -29,7 +32,9 @@ import           NoThunks.Class (NoThunks (..))
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.BlockchainTime
 import           Ouroboros.Consensus.Config
-import           Ouroboros.Consensus.Shelley.Eras (EraCrypto)
+import           Ouroboros.Consensus.Protocol.Praos.Common
+                     (VRFTiebreakerFlavor (..))
+import           Ouroboros.Consensus.Shelley.Eras (EraCrypto, isBeforeConway)
 import           Ouroboros.Consensus.Shelley.Ledger.Block
 import           Ouroboros.Network.Magic (NetworkMagic (..))
 
@@ -40,35 +45,48 @@ import           Ouroboros.Network.Magic (NetworkMagic (..))
 data instance BlockConfig (ShelleyBlock proto era) = ShelleyConfig {
       -- | The highest protocol version this node supports. It will be stored
       -- the headers of produced blocks.
-      shelleyProtocolVersion  :: !SL.ProtVer
-    , shelleySystemStart      :: !SystemStart
-    , shelleyNetworkMagic     :: !NetworkMagic
+      shelleyProtocolVersion     :: !SL.ProtVer
+    , shelleySystemStart         :: !SystemStart
+    , shelleyNetworkMagic        :: !NetworkMagic
       -- | For nodes that can produce blocks, this should be set to the
       -- verification key(s) corresponding to the node's signing key(s). For non
       -- block producing nodes, this can be set to the empty map.
-    , shelleyBlockIssuerVKeys :: !(Map (SL.KeyHash 'SL.BlockIssuer (EraCrypto era))
-                                       (SL.VKey 'SL.BlockIssuer (EraCrypto era)))
+    , shelleyBlockIssuerVKeys    :: !(Map (SL.KeyHash 'SL.BlockIssuer (EraCrypto era))
+                                          (SL.VKey 'SL.BlockIssuer (EraCrypto era)))
+    , shelleyVRFTiebreakerFlavor :: !VRFTiebreakerFlavor
     }
   deriving stock (Generic)
 
 deriving instance ShelleyBasedEra era => Show     (BlockConfig (ShelleyBlock proto era))
 deriving instance ShelleyBasedEra era => NoThunks (BlockConfig (ShelleyBlock proto era))
 
 mkShelleyBlockConfig ::
-     ShelleyBasedEra era
+     forall proto era. ShelleyBasedEra era
   => SL.ProtVer
   -> SL.ShelleyGenesis (EraCrypto era)
   -> [SL.VKey 'SL.BlockIssuer (EraCrypto era)]
   -> BlockConfig (ShelleyBlock proto era)
 mkShelleyBlockConfig protVer genesis blockIssuerVKeys = ShelleyConfig {
-      shelleyProtocolVersion  = protVer
-    , shelleySystemStart      = SystemStart  $ SL.sgSystemStart  genesis
-    , shelleyNetworkMagic     = NetworkMagic $ SL.sgNetworkMagic genesis
-    , shelleyBlockIssuerVKeys = Map.fromList
+      shelleyProtocolVersion     = protVer
+    , shelleySystemStart         = SystemStart  $ SL.sgSystemStart  genesis
+    , shelleyNetworkMagic        = NetworkMagic $ SL.sgNetworkMagic genesis
+    , shelleyBlockIssuerVKeys    = Map.fromList
         [ (SL.hashKey k, k)
         | k <- blockIssuerVKeys
         ]
+    , shelleyVRFTiebreakerFlavor
     }
+  where
+    shelleyVRFTiebreakerFlavor
+      | isBeforeConway (Proxy @era)
+      = UnrestrictedVRFTiebreaker
+      | otherwise
+      -- See 'RestrictedVRFTiebreaker' for context. 5 slots is the "usual" value
+      -- we consider when talking about the maximum propagation delay.
+      --
+      -- TODO derive/clamp this value from something else, eg active slot
+      -- coefficient?
+      = RestrictedVRFTiebreaker 5
 
 {-------------------------------------------------------------------------------
   Codec config

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

@@ -15,7 +15,7 @@ import           Ouroboros.Consensus.Protocol.Signed
 import           Ouroboros.Consensus.Protocol.TPraos
 import           Ouroboros.Consensus.Shelley.Eras (EraCrypto)
 import           Ouroboros.Consensus.Shelley.Ledger.Block
-import           Ouroboros.Consensus.Shelley.Ledger.Config ()
+import           Ouroboros.Consensus.Shelley.Ledger.Config (BlockConfig (..))
 import           Ouroboros.Consensus.Shelley.Protocol.Abstract
                      (ShelleyProtocolHeader, pHeaderIssueNo, pHeaderIssuer,
                      pTieBreakVRFValue, protocolHeaderView)
@@ -40,6 +40,8 @@ instance ShelleyCompatible proto era => BlockSupportsProtocol (ShelleyBlock prot
       hdrIssuer ::  SL.VKey 'SL.BlockIssuer (EraCrypto era)
       hdrIssuer = pHeaderIssuer shdr
 
+  projectChainOrderConfig = shelleyVRFTiebreakerFlavor
+
 -- TODO correct place for these two?
 type instance Signed (Header (ShelleyBlock proto era)) =
   Signed (ShelleyProtocolHeader proto)

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

@@ -20,7 +20,6 @@ module Ouroboros.Consensus.Shelley.Node.DiffusionPipelining (
   , isBeforeConway
   ) where
 
-import qualified Cardano.Ledger.Api.Era as L
 import qualified Cardano.Ledger.Shelley.API as SL
 import           Control.Monad (guard)
 import           Data.Set (Set)
@@ -30,6 +29,7 @@ import           GHC.Generics (Generic)
 import           NoThunks.Class
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Protocol.Abstract
+import           Ouroboros.Consensus.Shelley.Eras (isBeforeConway)
 import           Ouroboros.Consensus.Shelley.Ledger.Block
 import           Ouroboros.Consensus.Shelley.Ledger.Protocol ()
 import           Ouroboros.Consensus.Shelley.Protocol.Abstract
@@ -78,10 +78,6 @@ data ShelleyTentativeHeaderView proto =
 deriving stock instance ConsensusProtocol proto => Show (ShelleyTentativeHeaderView proto)
 deriving stock instance ConsensusProtocol proto => Eq   (ShelleyTentativeHeaderView proto)
 
-isBeforeConway :: forall era. L.Era era => Proxy era -> Bool
-isBeforeConway _ =
-    L.eraProtVerLow @era < L.eraProtVerLow @(L.ConwayEra (L.EraCrypto era))
-
 -- | This is currently a hybrid instance:
 --
 --  - For eras before Conway, this uses the logic from

ouroboros-consensus-protocol/changelog.d/20240409_142855_alexander.esgen_duncan_tiebreaker.md

@@ -0,0 +1,4 @@
+### Breaking
+
+- Allowed to configure Praos chain order to restrict the VRF tiebreaker based on
+  slot distance.

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

@@ -13,6 +13,7 @@ module Ouroboros.Consensus.Protocol.Praos.Common (
     MaxMajorProtVer (..)
   , PraosCanBeLeader (..)
   , PraosChainSelectView (..)
+  , VRFTiebreakerFlavor (..)
     -- * node support
   , PraosNonces (..)
   , PraosProtocolSupportsNode (..)
@@ -54,36 +55,138 @@ data PraosChainSelectView c = PraosChainSelectView
   }
   deriving (Show, Eq, Generic, NoThunks)
 
+-- | When to compare the VRF tiebreakers.
+data VRFTiebreakerFlavor =
+    -- | Always compare the VRF tiebreakers. This is the behavior of all eras
+    -- before Conway. Once mainnet has transitioned to Conway, we can remove
+    -- this option.
+    UnrestrictedVRFTiebreaker
+  | -- | Only compare the VRF tiebreakers when the slot numbers differ by at
+    -- most the given number of slots.
+    --
+    -- The main motivation is as follows:
+    --
+    -- When two blocks A and B with the same block number differ in their slot
+    -- number by more than Δ (the maximum message delay from Praos), say
+    -- @slot(A) + Δ < slot(B)@, the issuer of B should have been able to mint a
+    -- block with a block number higher than A (eg by minting on top of A).
+    -- Therefore, we do not want to allow B to win against A by having a better
+    -- VRF tiebreaker, such that properly configured pools (like the issuer of
+    -- A) do not lose blocks because of poorly configured pools (like the issuer
+    -- of B).
+    RestrictedVRFTiebreaker SlotNo
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NoThunks)
+
+-- Used to implement the 'Ord' and 'ChainOrder' instances for Praos.
+comparePraos ::
+  Crypto c =>
+  VRFTiebreakerFlavor ->
+  PraosChainSelectView c ->
+  PraosChainSelectView c ->
+  Ordering
+comparePraos tiebreakerFlavor =
+  mconcat
+    [ compare `on` csvChainLength,
+      whenSame csvIssuer (compare `on` csvIssueNo),
+      applyTiebreakerFlavor (compare `on` Down . csvTieBreakVRF)
+    ]
+  where
+    -- When the @a@s are equal, use the given comparison function,
+    -- otherwise, no preference.
+    whenSame ::
+      Eq a =>
+      (view -> a) ->
+      (view -> view -> Ordering) ->
+      (view -> view -> Ordering)
+    whenSame f comp v1 v2
+      | f v1 == f v2 =
+          comp v1 v2
+      | otherwise =
+          EQ
+
+    applyTiebreakerFlavor = case tiebreakerFlavor of
+        UnrestrictedVRFTiebreaker       -> id
+        RestrictedVRFTiebreaker maxDist -> whenSlotsWithin maxDist
+
+    -- When the chain tips are within the given number of slots of each other,
+    -- use the given comparison function, otherwise, no preference.
+    whenSlotsWithin ::
+      SlotNo ->
+      (PraosChainSelectView c -> PraosChainSelectView c -> Ordering) ->
+      (PraosChainSelectView c -> PraosChainSelectView c -> Ordering)
+    whenSlotsWithin maxDist comp v1 v2
+      | let dist = slotDist (csvSlotNo v1) (csvSlotNo v2)
+      , dist <= maxDist =
+          comp v1 v2
+      | otherwise =
+          EQ
+
+    slotDist :: SlotNo -> SlotNo -> SlotNo
+    slotDist s t
+      -- slot numbers are unsigned, so have to take care with subtraction
+      | s >= t    = s - t
+      | otherwise = t - s
+
 -- | 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.
+--
+-- IMPORTANT: This is not a complete picture of the Praos chain order, do also
+-- consult the documentation of 'ChainOrder'.
 instance Crypto c => Ord (PraosChainSelectView c) where
-  compare =
-    mconcat
-      [ compare `on` csvChainLength,
-        whenSame csvIssuer (compare `on` csvIssueNo),
-        compare `on` Down . csvTieBreakVRF
-      ]
-    where
-      -- When the @a@s are equal, use the given comparison function,
-      -- otherwise, no preference.
-      whenSame ::
-        Eq a =>
-        (view -> a) ->
-        (view -> view -> Ordering) ->
-        (view -> view -> Ordering)
-      whenSame f comp v1 v2
-        | f v1 == f v2 =
-            comp v1 v2
-        | otherwise =
-            EQ
-
-deriving via SimpleChainOrder (PraosChainSelectView c)
-  instance Crypto c => ChainOrder (PraosChainSelectView c)
+  compare = comparePraos UnrestrictedVRFTiebreaker
+
+-- | IMPORTANT: This is not a 'SimpleChainOrder'; rather, there are
+-- 'PraosChainSelectView's @a, b@ such that @a < b@, but @'not' $
+-- 'preferCandidate' cfg a b@, namely for @cfg = 'RestrictedVRFTiebreaker'@.
+--
+-- === Rules
+--
+-- Concretely, we have @'preferCandidate' cfg ours cand@ based on the following
+-- lexicographical criteria:
+--
+-- 1. Chain length, with longer chains always preferred.
+--
+-- 2. If the tip of each chain was issued by the same agent, then we prefer the
+--    candidate if it has a higher ocert issue number.
+--
+-- 3. Depending on the 'VRFTiebreakerFlavor':
+--
+--     * If 'UnrestrictedVRFTiebreaker': Compare via a VRF value from the chain
+--       tip, with lower values preferred. See @pTieBreakVRFValue@ for which one
+--       is used.
+--
+--     * If @'RestrictedVRFTiebreaker' maxDist@: Only do the VRF comparison (as
+--       in the previous step) if the slot numbers differ by at most @maxDist@.
+--
+-- === Non-transitivity of 'RestrictedVRFTiebreaker'
+--
+-- When using @cfg = 'RestrictedVRFTiebreaker' maxDist@, the chain order is not
+-- transitive. As an example, suppose @maxDist = 5@ and consider three
+-- 'PraosChainSelectView's with the same chain length and pairwise different
+-- issuers and, as well as
+--
+-- +------+---+---+---+
+-- |      | a | b | c |
+-- +======+===+===+===+
+-- | Slot | 0 | 3 | 6 |
+-- +------+---+---+---+
+-- | VRF  | 3 | 2 | 1 |
+-- +------+---+---+---+
+--
+-- Then we have @'preferCandidate' cfg a b@ and @'preferCandidate' b c@, but
+-- __not__ @'preferCandidate' a c@ (despite @a < c@).
+instance Crypto c => ChainOrder (PraosChainSelectView c) where
+  type ChainOrderConfig (PraosChainSelectView c) = VRFTiebreakerFlavor
+
+  preferCandidate cfg ours cand = comparePraos cfg ours cand == LT
 
 data PraosCanBeLeader c = PraosCanBeLeader
   { -- | Certificate delegating rights from the stake pool cold key (or