consensus: address PR comments

IntersectMBO · Dec 17, 2019 · 35dfbd4 · 35dfbd4
1 parent f538901
commit 35dfbd4
Show file tree

Hide file tree

Showing 8 changed files with 34 additions and 22 deletions.
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs
@@ -4,7 +4,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE NamedFieldPuns        #-}
-{-# LANGUAGE PatternGuards         #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
@@ -402,16 +401,19 @@ forkBlockProduction IS{..} =
                         -> (Point blk, BlockNo)
     prevPointAndBlockNo slot c = case c of
         Empty _   -> (genesisPoint, genesisBlockNo)
-        c' :> hdr
-          | Just{} <- nodeIsEBB hdr -> (headerPoint hdr, blockNo hdr)
-          | otherwise               -> case blockSlot hdr `compare` slot of
+        c' :> hdr -> case blockSlot hdr `compare` slot of
           LT -> (headerPoint hdr, blockNo hdr)
           -- The block at the tip of our chain has a slot that lies in the
           -- future.
           GT -> error "prevPointAndBlockNo: block in future"
           -- The block at the tip has the same slot as the block we're going
           -- to produce (@slot@), so look at the block before it.
-          EQ | _ :> hdr' <- c'
+          EQ
+             | Just{} <- nodeIsEBB hdr
+               -- We allow forging a block that is the successor of an EBB in
+               -- the same slot.
+             -> (headerPoint hdr, blockNo hdr)
+             | _ :> hdr' <- c'
              -> (headerPoint hdr', blockNo hdr')
              | otherwise
                -- If there is no block before it, so use genesis.

diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs
@@ -14,6 +14,7 @@ import           Ouroboros.Consensus.Protocol
 import           Ouroboros.Consensus.Util.Random
 
 import           Test.Dynamic.General
+import           Test.Dynamic.Network (MaybeForgeEBB (..))
 import           Test.Dynamic.Util
 
 import           Test.Util.Orphans.Arbitrary ()
@@ -42,4 +43,4 @@ prop_simple_bft_convergence k slotLength
     testOutput =
         runTestNetwork
             (\nid -> protocolInfo (ProtocolMockBFT numCoreNodes nid k slotLength))
-            testConfig Nothing seed
+            testConfig NothingForgeEBB seed
diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs
@@ -26,17 +26,14 @@ import           Test.QuickCheck
 import           Control.Monad.IOSim (runSimOrThrow)
 
 import           Ouroboros.Network.Block (BlockNo (..), pattern BlockPoint,
-                     ChainHash, pattern GenesisPoint, HasHeader, Point,
-                     blockPoint)
+                     pattern GenesisPoint, HasHeader, Point, blockPoint)
 
-import           Ouroboros.Consensus.Block (BlockProtocol)
 import           Ouroboros.Consensus.BlockchainTime
 import           Ouroboros.Consensus.Node.ProtocolInfo
 import           Ouroboros.Consensus.Node.Run
 import           Ouroboros.Consensus.NodeId
 import           Ouroboros.Consensus.Protocol (LeaderSchedule (..))
-import           Ouroboros.Consensus.Protocol.Abstract (NodeConfig,
-                     SecurityParam (..))
+import           Ouroboros.Consensus.Protocol.Abstract (SecurityParam (..))
 
 import           Ouroboros.Consensus.Util.Condense
 import           Ouroboros.Consensus.Util.IOLike
@@ -126,7 +123,7 @@ runTestNetwork ::
      )
   => (CoreNodeId -> ProtocolInfo blk)
   -> TestConfig
-  -> Maybe (NodeConfig (BlockProtocol blk) -> SlotNo -> BlockNo -> ChainHash blk -> blk)
+  -> MaybeForgeEBB blk
   -> Seed
   -> TestOutput blk
 runTestNetwork pInfo

diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs
@@ -22,6 +22,7 @@ import           Ouroboros.Consensus.Protocol
 import           Ouroboros.Consensus.Util.Random
 
 import           Test.Dynamic.General
+import           Test.Dynamic.Network (MaybeForgeEBB (..))
 import           Test.Dynamic.Util
 import           Test.Dynamic.Util.NodeJoinPlan
 import           Test.Dynamic.Util.NodeTopology
@@ -82,7 +83,7 @@ prop_simple_leader_schedule_convergence
             (\nid -> protocolInfo
                        (ProtocolLeaderSchedule numCoreNodes nid
                                                params schedule))
-            testConfig Nothing seed
+            testConfig NothingForgeEBB seed
 
 {-------------------------------------------------------------------------------
   Dependent generation and shrinking of leader schedules

diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs
@@ -16,6 +16,7 @@
 -- | Setup network
 module Test.Dynamic.Network (
     runNodeNetwork
+  , MaybeForgeEBB (..)
   , TracingConstraints
     -- * Tracers
   , MiniProtocolExpectedException (..)
@@ -104,6 +105,14 @@ import qualified Test.Util.FS.Sim.MockFS as Mock
 import           Test.Util.FS.Sim.STM (simHasFS)
 import           Test.Util.Tracer
 
+data MaybeForgeEBB blk
+  = NothingForgeEBB
+    -- ^ Do not forge EBBs during this test
+  | JustForgeEBB !(NodeConfig (BlockProtocol blk) ->
+                   SlotNo -> BlockNo -> ChainHash blk -> blk)
+    -- ^ Forge EBBs during this test using this function @(slot, block no,
+    -- prevHash)@
+
 -- | Setup a network of core nodes, where each joins according to the node join
 -- plan and is interconnected according to the node topology
 --
@@ -121,7 +130,7 @@ runNodeNetwork :: forall m blk.
                  -> NumCoreNodes
                  -> NodeJoinPlan
                  -> NodeTopology
-                 -> Maybe (NodeConfig (BlockProtocol blk) -> SlotNo -> BlockNo -> ChainHash blk -> blk)
+                 -> MaybeForgeEBB blk
                  -> (CoreNodeId -> ProtocolInfo blk)
                  -> ChaChaDRG
                  -> DiffTime
@@ -239,19 +248,19 @@ runNodeNetwork registry testBtime numCoreNodes nodeJoinPlan nodeTopology
                 -> ChainDB.ChainDB m blk
                 -> EpochInfo m
                 -> m ()
-    ebbProducer v cfg chainDB epochInfo = go 0
+    ebbProducer nextEbbSlotVar cfg chainDB epochInfo = go 0
       where
         go :: EpochNo -> m ()
         go !epoch = do
           -- The first slot in @epoch@
           ebbSlotNo <- epochInfoFirst epochInfo epoch
-          atomically $ writeTVar v ebbSlotNo
+          atomically $ writeTVar nextEbbSlotVar ebbSlotNo
 
           void $ blockUntilSlot btime ebbSlotNo
 
           case mbForgeEBB of
-            Nothing       -> pure ()
-            Just forgeEBB -> do
+            NothingForgeEBB       -> pure ()
+            JustForgeEBB forgeEBB -> do
               (prevSlot, ebbBlockNo, prevHash) <- atomically $ do
                 p <- ChainDB.getTipPoint chainDB
                 let mSlot = pointSlot p

diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/PBFT.hs
@@ -15,6 +15,7 @@ import           Ouroboros.Consensus.Protocol
 import           Ouroboros.Consensus.Util.Random
 
 import           Test.Dynamic.General
+import           Test.Dynamic.Network (MaybeForgeEBB (..))
 import           Test.Dynamic.Util
 
 import           Test.Util.Orphans.Arbitrary ()
@@ -46,4 +47,4 @@ prop_simple_pbft_convergence
     testOutput =
         runTestNetwork
             (\nid -> protocolInfo (ProtocolMockPBFT numCoreNodes nid params))
-            testConfig Nothing seed
+            testConfig NothingForgeEBB seed
diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/Praos.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/Praos.hs
@@ -16,6 +16,7 @@ import           Ouroboros.Consensus.Protocol
 import           Ouroboros.Consensus.Util.Random
 
 import           Test.Dynamic.General
+import           Test.Dynamic.Network (MaybeForgeEBB (..))
 import           Test.Dynamic.Util
 import           Test.Dynamic.Util.NodeJoinPlan
 import           Test.Dynamic.Util.NodeTopology
@@ -96,4 +97,4 @@ prop_simple_praos_convergence
     testOutput@TestOutput{testOutputNodes} =
         runTestNetwork
             (\nid -> protocolInfo (ProtocolMockPraos numCoreNodes nid params))
-            testConfig Nothing seed
+            testConfig NothingForgeEBB seed
diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/RealPBFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/RealPBFT.hs
@@ -48,7 +48,7 @@ import qualified Cardano.Crypto as Crypto
 import qualified Test.Cardano.Chain.Genesis.Dummy as Dummy
 
 import           Test.Dynamic.General
-import           Test.Dynamic.Network (NodeOutput (..))
+import           Test.Dynamic.Network (MaybeForgeEBB (..), NodeOutput (..))
 import qualified Test.Dynamic.Ref.RealPBFT as Ref
 import           Test.Dynamic.Util
 import           Test.Dynamic.Util.NodeJoinPlan
@@ -164,7 +164,7 @@ prop_simple_real_pbft_convergence
             (\nid -> protocolInfo
                        (mkProtocolRealPBFT params nid
                                            genesisConfig genesisSecrets))
-            testConfig (Just forgeEBB) seed
+            testConfig (JustForgeEBB forgeEBB) seed
 
     finalChains :: [Chain ByronBlock]
     finalChains = Map.elems $ nodeOutputFinalChain <$> testOutputNodes testOutput