diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs index 3579af69929..948ef137904 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs @@ -29,6 +29,7 @@ import Ouroboros.Consensus.NodeId (CoreNodeId) import Ouroboros.Consensus.Protocol.Abstract as X import Ouroboros.Consensus.Protocol.BFT as X import Ouroboros.Consensus.Protocol.LeaderSchedule as X +import Ouroboros.Consensus.Protocol.ModChainSel as X import Ouroboros.Consensus.Protocol.PBFT as X import Ouroboros.Consensus.Protocol.Praos as X import Ouroboros.Consensus.Util @@ -41,7 +42,7 @@ type ProtocolMockBFT = Bft BftMockCrypto type ProtocolMockPraos = Praos AddrDist PraosMockCrypto type ProtocolLeaderSchedule = WithLeaderSchedule (Praos () PraosCryptoUnused) type ProtocolMockPBFT = PBft (PBftLedgerView PBftMockCrypto) PBftMockCrypto -type ProtocolRealPBFT = PBft ByronConfig PBftCardanoCrypto +type ProtocolRealPBFT = ModChainSel (PBft ByronConfig PBftCardanoCrypto) SelectEBBsPromptly {------------------------------------------------------------------------------- Abstract over the various protocols diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs index 4363852a395..9dedbcb7473 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs @@ -13,6 +13,7 @@ module Ouroboros.Consensus.Protocol.ModChainSel ( ChainSelection (..) , ModChainSel + , SelectEBBsPromptly -- * Type family instances , NodeConfig (..) ) where @@ -25,19 +26,21 @@ import GHC.Generics (Generic) import Cardano.Prelude (NoUnexpectedThunks) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Consensus.Protocol.Abstract +import qualified Ouroboros.Consensus.Util.AnchoredFragment as AF class OuroborosTag p => ChainSelection p s where - type family CanSelect' p :: * -> Constraint + type family CanSelect' p s :: * -> Constraint - preferCandidate' :: CanSelect' p b + preferCandidate' :: CanSelect' p s b => proxy s -> NodeConfig p -> AnchoredFragment b -- ^ Our chain -> AnchoredFragment b -- ^ Candidate -> Bool - compareCandidates' :: CanSelect' p b + compareCandidates' :: CanSelect' p s b => proxy s -> NodeConfig p -> AnchoredFragment b -> AnchoredFragment b -> Ordering @@ -54,7 +57,7 @@ instance (Typeable p, Typeable s, ChainSelection p s) => OuroborosTag (ModChainS type LedgerView (ModChainSel p s) = LedgerView p type ValidationErr (ModChainSel p s) = ValidationErr p type CanValidate (ModChainSel p s) = CanValidate p - type CanSelect (ModChainSel p s) = CanSelect' p + type CanSelect (ModChainSel p s) = CanSelect' p s checkIsLeader (McsNodeConfig cfg) = checkIsLeader cfg applyChainState (McsNodeConfig cfg) = applyChainState cfg @@ -67,3 +70,26 @@ instance (Typeable p, Typeable s, ChainSelection p s) => OuroborosTag (ModChainS instance OuroborosTag p => NoUnexpectedThunks (NodeConfig (ModChainSel p s)) -- use generic instance + +{------------------------------------------------------------------------------- + Individual modifiers +-------------------------------------------------------------------------------} + +-- | Override 'preferCandidate' such that the ChainDB will select a new EBB +-- /promptly/. +-- +-- Uses the default 'compareCandidates' from the definition of 'OuroborosTag'. +data SelectEBBsPromptly + +instance OuroborosTag p => ChainSelection p SelectEBBsPromptly where + type instance CanSelect' p SelectEBBsPromptly = AF.HasHeader + + preferCandidate' _ _ ours cand = + case AF.compareHeadBlockNo ours cand of + LT -> True + EQ -> case AF.intersect ours cand of + Nothing -> False + Just (_, _, ours', cand') -> AF.length ours' < AF.length cand' + GT -> False + + compareCandidates' _ _ = AF.compareHeadBlockNo