consensus: Add SelectEBBsPromptly protocol combinator and use for Rea…

…lPBFT
IntersectMBO · Dec 17, 2019 · f538901 · f538901
1 parent 333ea01
commit f538901
Show file tree

Hide file tree

Showing 2 changed files with 32 additions and 5 deletions.
diff --git 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
@@ -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