diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/DiffusionPipelining.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/DiffusionPipelining.hs index 33ef11b354..5e12079a4c 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/DiffusionPipelining.hs +++ b/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 diff --git a/ouroboros-consensus-protocol/changelog.d/20240409_141920_alexander.esgen_remove_ord_selectview.md b/ouroboros-consensus-protocol/changelog.d/20240409_141920_alexander.esgen_remove_ord_selectview.md new file mode 100644 index 0000000000..bc7168a64d --- /dev/null +++ b/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. diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs index 99d6914c1d..e54b40ae65 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs +++ b/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), diff --git a/ouroboros-consensus/changelog.d/20240409_141920_alexander.esgen_remove_ord_selectview.md b/ouroboros-consensus/changelog.d/20240409_141920_alexander.esgen_remove_ord_selectview.md new file mode 100644 index 0000000000..f01796953b --- /dev/null +++ b/ouroboros-consensus/changelog.d/20240409_141920_alexander.esgen_remove_ord_selectview.md @@ -0,0 +1,3 @@ +### Breaking + +- Require `ChainOrder` for `SelectView` instead of `Ord`. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsDiffusionPipelining.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsDiffusionPipelining.hs index 698faa18f4..a57b8d1034 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsDiffusionPipelining.hs +++ b/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) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs index dd8f93b7bd..e2671f1d8c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs +++ b/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) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol/ChainSel.hs index 4a2ce969f0..432fa6a4d1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol/ChainSel.hs +++ b/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) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs index 0663d00e8d..135a4a1647 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs +++ 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 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs index e123000d01..3c200792ac 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs +++ b/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 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/ModChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/ModChainSel.hs index 4d8a51dbb9..443a759c0e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/ModChainSel.hs +++ b/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 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT.hs index cad66c5127..872012bc34 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT.hs +++ b/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 { diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs index 160862d7e1..4488b9fc1d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs +++ b/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) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs index ee757ef5c2..f2fabbe722 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs +++ b/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 diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs index 9de5c2dbe7..b1247f2ba3 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs +++ b/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) {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs index a7bef650d1..bf92961475 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs +++ b/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)