Allow to customize preferCandidate (#1063)

Closes #939

The core idea is to keep a total order (via `Ord`) for `SelectView`, but
allowing to customize the logic of `preferCandidate` (previously, it was
always defined in terms of `Ord`, i.e. `preferCandidate ours cand = cand
> ours`), such that it becomes possible to eg implement the restricted
VRF tiebreaker (#524) this way, which is fundamentally intransitive.

This is in contrast to #1046 (an alternative to this PR), where
`preferCandidate` is not customizable, and we instead live with the fact
the ordering might not be transitive, which techically would require
replacing our calls to `sortBy` with eg a topological sorting algorithm,
or just assume/test that `sortBy` still works "well enough" with
non-transitive orders.

Also see #1047 as a follow-up PR that leverages the new flexibility
offered by this PR.

This PR undoes some of the changes of
IntersectMBO/ouroboros-network#2743 and
IntersectMBO/ouroboros-network#2732 which were
back then merged to increase simplicity/ease of exposition in the
report, but it now turns out that the flexibility they removed is
actually useful for us today.

ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs

@@ -74,6 +74,7 @@ import           Test.Util.HardFork.Future (Future)
 import           Test.Util.Orphans.Arbitrary ()
 import           Test.Util.Orphans.IOLike ()
 import           Test.Util.Orphans.NoThunks ()
+import           Test.Util.QuickCheck
 import           Test.Util.Range
 import           Test.Util.Shrink (andId, dropId)
 import           Test.Util.Slots (NumSlots (..))
@@ -674,10 +675,6 @@ prop_general_internal syncity pga testOutput =
                 | ((s1, _, max1), (s2, min2, _)) <- orderedPairs extrema
                 ]
       where
-        -- QuickCheck's @==>@ 'discard's the test if @p1@ fails; that's not
-        -- what we want
-        implies p1 p2 = not p1 .||. p2
-
         -- all pairs @(x, y)@ where @x@ precedes @y@ in the given list
         orderedPairs :: [a] -> [(a, a)]
         orderedPairs = \case

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/ouroboros-consensus-protocol.cabal

@@ -43,6 +43,12 @@ common common-lib
   if flag(asserts)
     ghc-options: -fno-ignore-asserts
 
+common common-test
+  import: common-lib
+  ghc-options:
+    -threaded
+    -rtsopts
+
 library
   import: common-lib
   hs-source-dirs: src/ouroboros-consensus-protocol
@@ -90,3 +96,24 @@ library unstable-protocol-testlib
     cardano-protocol-tpraos,
     cardano-slotting,
     ouroboros-consensus-protocol,
+
+test-suite protocol-test
+  import: common-test
+  type: exitcode-stdio-1.0
+  hs-source-dirs: test/protocol-test
+  main-is: Main.hs
+  other-modules:
+    Test.Consensus.Protocol.Praos.SelectView
+
+  build-depends:
+    QuickCheck,
+    base,
+    cardano-crypto-class,
+    cardano-ledger-binary:testlib,
+    cardano-ledger-core,
+    containers,
+    ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib},
+    ouroboros-consensus-protocol,
+    serialise,
+    tasty,
+    tasty-quickcheck,

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-protocol/test/protocol-test/Main.hs

@@ -0,0 +1,14 @@
+module Main (main) where
+
+import qualified Test.Consensus.Protocol.Praos.SelectView
+import           Test.Tasty
+import           Test.Util.TestEnv
+
+main :: IO ()
+main = defaultMainWithTestEnv defaultTestEnvConfig tests
+
+tests :: TestTree
+tests =
+    testGroup "protocol"
+      [ Test.Consensus.Protocol.Praos.SelectView.tests
+      ]

ouroboros-consensus-protocol/test/protocol-test/Test/Consensus/Protocol/Praos/SelectView.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Test.Consensus.Protocol.Praos.SelectView (tests) where
+
+import qualified Cardano.Crypto.Hash as Crypto
+import qualified Cardano.Crypto.Util as Crypto
+import           Cardano.Crypto.VRF (OutputVRF, mkTestOutputVRF)
+import           Cardano.Ledger.Crypto (Crypto (..), StandardCrypto)
+import qualified Cardano.Ledger.Keys as SL
+import           Codec.Serialise (encode)
+import           Control.Monad
+import           Data.Containers.ListUtils (nubOrdOn)
+import           Ouroboros.Consensus.Block
+import           Ouroboros.Consensus.Protocol.Praos.Common
+import           Test.Cardano.Ledger.Binary.Arbitrary ()
+import           Test.Ouroboros.Consensus.Protocol
+import           Test.QuickCheck.Gen (Gen (..))
+import           Test.QuickCheck.Random (mkQCGen)
+import           Test.Tasty
+import           Test.Tasty.QuickCheck hiding (elements)
+import           Test.Util.QuickCheck
+import           Test.Util.TestEnv
+
+tests :: TestTree
+tests = testGroup "PraosChainSelectView"
+    [   adjustQuickCheckTests (* 50)
+      -- Use a small max size by default in order to have a decent chance to
+      -- trigger the actual tiebreaker cases.
+      $ adjustQuickCheckMaxSize (`div` 10)
+      $ tests_chainOrder (Proxy @(PraosChainSelectView StandardCrypto))
+    ]
+
+instance Crypto c => Arbitrary (PraosChainSelectView c) where
+  arbitrary = do
+      size           <- fromIntegral <$> getSize
+      csvChainLength <- BlockNo <$> choose (1, size)
+      csvSlotNo      <- SlotNo  <$> choose (1, size)
+      csvIssuer      <- elements knownIssuers
+      csvIssueNo     <- genIssueNo
+      pure PraosChainSelectView {
+          csvChainLength
+        , csvSlotNo
+        , csvIssuer
+        , csvIssueNo
+        , csvTieBreakVRF = mkVRFFor csvIssuer csvSlotNo
+        }
+   where
+     -- We want to draw from the same small set of issuer identities in order to
+     -- have a chance to explore cases where the issuers of two 'SelectView's
+     -- are identical.
+     knownIssuers :: [SL.VKey SL.BlockIssuer c]
+     knownIssuers =
+           nubOrdOn SL.hashKey
+         $ unGen (replicateM numIssuers (SL.VKey <$> arbitrary)) randomSeed 100
+       where
+         randomSeed = mkQCGen 4 -- chosen by fair dice roll
+         numIssuers = 10
+
+     -- TODO Actually randomize this once the issue number tiebreaker has been
+     -- fixed to be transitive. See the document in
+     -- https://github.com/IntersectMBO/ouroboros-consensus/pull/891 for
+     -- details.
+     --
+     -- TL;DR: In an edge case, the issue number tiebreaker prevents the
+     -- chain order from being transitive. This could be fixed relatively
+     -- easily, namely by swapping the issue number tiebreaker and the VRF
+     -- tiebreaker. However, this is technically not backwards-compatible,
+     -- impacting the current pre-Conway diffusion pipelining scheme.
+     --
+     -- See https://github.com/IntersectMBO/ouroboros-consensus/issues/1075.
+     genIssueNo = pure 1
+
+     -- The header VRF is a deterministic function of the issuer VRF key, the
+     -- slot and the epoch nonce. Additionally, for any particular chain, the
+     -- slot determines the epoch nonce.
+     mkVRFFor :: SL.VKey SL.BlockIssuer c -> SlotNo -> OutputVRF (VRF c)
+     mkVRFFor issuer slot =
+           mkTestOutputVRF
+         $ Crypto.bytesToNatural
+         $ Crypto.hashToBytes
+         $ Crypto.xor (Crypto.castHash issuerHash)
+         $ Crypto.hashWithSerialiser encode slot
+       where
+         SL.KeyHash issuerHash = SL.hashKey issuer

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/ouroboros-consensus.cabal

@@ -331,6 +331,7 @@ library unstable-consensus-testlib
     Test.Ouroboros.Consensus.ChainGenerator.Slot
     Test.Ouroboros.Consensus.ChainGenerator.Some
     Test.Ouroboros.Consensus.DiffusionPipelining
+    Test.Ouroboros.Consensus.Protocol
     Test.QuickCheck.Extras
     Test.Util.BoolProps
     Test.Util.ChainDB

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
 -------------------------------------------------------------------------------}