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.

Author: amesgen

ouroboros-consensus-diffusion/changelog.d/20240425_110304_alexander.esgen_customize_prefer_candidate.md

@@ -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-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs

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

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

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

@@ -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/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.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/Main.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-protocol/test/protocol-test/Test/Consensus/Protocol/Praos/SelectView.hs

@@ -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/changelog.d/20240417_122327_alexander.esgen_customize_prefer_candidate.md

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

@@ -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 _ = ()