Merge #773

773: Have some nodes join later in test-consensus r=nfrisby a=nfrisby This PR is only for discussion. I have a first draft take on #231 and would like feedback, of all kinds. Edit: the PR has matured and looks nearly ready to merge, but I suspect I should open a separate PR because of the 100+ comments on this one. Edit: Fixes #231. Co-authored-by: Nicolas Frisby <[email protected]>
IntersectMBO · Sep 5, 2019 · f79f071 · f79f071
2 parents 05a62ac + 73b5ce4
commit f79f071
Show file tree

Hide file tree

Showing 23 changed files with 722 additions and 249 deletions.
diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -266,6 +266,7 @@ test-suite test-consensus
                     Test.Dynamic.TxGen
                     Test.Dynamic.Util
                     Test.Dynamic.Util.Expectations
+                    Test.Dynamic.Util.NodeJoinPlan
                     Test.Dynamic.Util.Tests
                     Test.Ouroboros
                     Test.Util.DepFn

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/BlockFetchServer.hs b/ouroboros-consensus/src/Ouroboros/Consensus/BlockFetchServer.hs
@@ -9,6 +9,8 @@ module Ouroboros.Consensus.BlockFetchServer
   ( blockFetchServer
     -- * Trace events
   , TraceBlockFetchServerEvent
+    -- * Exceptions
+  , BlockFetchServerException
   ) where
 
 import           Data.Typeable (Typeable)

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime.hs b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime.hs
@@ -8,6 +8,7 @@
 module Ouroboros.Consensus.BlockchainTime (
     -- * Abstract definition
     BlockchainTime(..)
+  , blockUntilSlot
   , onSlotChange
   , onSlot
     -- * Use in testing
@@ -81,6 +82,22 @@ data BlockchainTime m = BlockchainTime {
     , onSlot_        :: HasCallStack => SlotNo -> m () -> m ()
     }
 
+-- | Returns 'True' immediately if the requested slot is already over, else
+-- blocks as requested and then returns 'False'
+--
+blockUntilSlot ::
+     MonadSTM m
+  => BlockchainTime m
+  -> SlotNo
+  -> m Bool
+blockUntilSlot btime slot = do
+    tooLate <- atomically $ do
+        now <- getCurrentSlot btime
+        if now > slot then pure True else do
+            check $ now == slot
+            pure False
+    pure tooLate
+
 -- | Wrapper around 'onSlotChange_' to ensure 'HasCallStack' constraint
 --
 -- See documentation of 'onSlotChange_'.

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs
@@ -80,6 +80,13 @@ data ChainSyncClientException blk =
       -- | The chain validation threw an error.
     | ChainError (ValidationErr (BlockProtocol blk))
 
+      -- | The upstream node rolled forward to a point too far in our past.
+      -- This may happen if, during catch-up, our local node has moved too far ahead of the upstream node.
+      -- 
+      -- We store the requested point and head point from the upstream node as
+      -- well as the tip of our current ledger.
+    | InvalidRollForward (Point blk) (Point blk) (Point blk)
+
       -- | The upstream node rolled back more than @k@ blocks.
       --
       -- We store the requested intersection point and head point from the
@@ -356,7 +363,7 @@ chainSyncClient tracer cfg btime (ClockSkew maxSkew)
 
     rollForward :: Header blk -> Point blk
                 -> m (Consensus ClientStIdle blk m)
-    rollForward hdr _theirHead = traceException $ atomically $ do
+    rollForward hdr theirHead = traceException $ atomically $ do
       -- Reject the block if invalid
       let hdrHash  = headerHash hdr
           hdrPoint = headerPoint hdr
@@ -422,8 +429,11 @@ chainSyncClient tracer cfg btime (ClockSkew maxSkew)
 
           -- TODO: Chain sync Client: Reuse anachronistic ledger view? #581
           case anachronisticProtocolLedgerView cfg curLedger (pointSlot hdrPoint) of
-            Nothing   -> retry
-            Just view -> case view `SB.at` hdrSlot of
+            -- unexpected alternative; see comment before this case expression
+            Left TooFarBehind ->
+                disconnect $ InvalidRollForward hdrPoint theirHead ourTip
+            Left TooFarAhead  -> retry
+            Right view -> case view `SB.at` hdrSlot of
                 Nothing -> error "anachronisticProtocolLedgerView invariant violated"
                 Just lv -> return lv
               where

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs
@@ -8,6 +8,7 @@ module Ouroboros.Consensus.Ledger.Abstract (
     UpdateLedger(..)
   , BlockProtocol
   , ProtocolLedgerView(..)
+  , AnachronyFailure(..)
   ) where
 
 import           Control.Monad.Except
@@ -123,4 +124,10 @@ class UpdateLedger blk => ProtocolLedgerView blk where
     :: NodeConfig (BlockProtocol blk)
     -> LedgerState blk
     -> WithOrigin SlotNo -- ^ Slot for which you would like a ledger view
-    -> Maybe (SlotBounded (LedgerView (BlockProtocol blk)))
+    -> Either AnachronyFailure (SlotBounded (LedgerView (BlockProtocol blk)))
+
+-- | See 'anachronisticProtocolLedgerView'.
+data AnachronyFailure
+  = TooFarAhead
+  | TooFarBehind
+  deriving (Eq,Show)
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs
@@ -929,16 +929,18 @@ instance (ByronGiven, Typeable cfg, ConfigContainsGenesis cfg)
     (ByronEBBLedgerState (ByronLedgerState ls ss)) slot =
       case find (containsSlot slot) ss of
         -- We can find a snapshot which supports this slot
-        Just sb -> Just
+        Just sb -> Right
                  $  PBftLedgerView
                  .  CC.Delegation.unMap
                  .  V.Interface.delegationMap
                  .  CC.Block.cvsDelegationState
                 <$> sb
         -- No snapshot - we could be in the past or in the future
         Nothing
-          | slot >= At lvLB && slot <= At lvUB
-          -> Just $ PBftLedgerView <$>
+          | slot < At lvLB -> Left TooFarBehind
+          | slot > At lvUB -> Left TooFarAhead
+          | otherwise
+          -> Right $ PBftLedgerView <$>
              case intermediateUpdates of
                 -- No updates to apply. So the current ledger state is valid
                 -- from the end of the last snapshot to the first scheduled
@@ -954,8 +956,6 @@ instance (ByronGiven, Typeable cfg, ConfigContainsGenesis cfg)
                                            (V.Scheduling.sdDelegate x)
                                            acc)
                    dsNow toApply
-          | otherwise
-          -> Nothing
     where
       lb = case ss of
         _ Seq.:|> s -> max lvLB (sbUpper s)

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/BFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/BFT.hs
@@ -105,7 +105,7 @@ instance ( SimpleCrypto c
          , Signable (BftDSIGN c') (SignedSimpleBft c c')
          ) => ProtocolLedgerView (SimpleBftBlock c c') where
   protocolLedgerView _ _ = ()
-  anachronisticProtocolLedgerView _ _ _ = Just $ SB.unbounded ()
+  anachronisticProtocolLedgerView _ _ _ = Right $ SB.unbounded ()
 
 {-------------------------------------------------------------------------------
   Serialisation

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/PBFT.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/PBFT.hs
@@ -115,7 +115,7 @@ instance ( SimpleCrypto c
   protocolLedgerView (EncNodeConfig _ pbftParams) _ls =
       pbftParams
   anachronisticProtocolLedgerView (EncNodeConfig _ pbftParams) _ _ =
-      Just $ SB.unbounded pbftParams
+      Right $ SB.unbounded pbftParams
 
 {-------------------------------------------------------------------------------
   Serialisation

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/Praos.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/Praos.hs
@@ -131,7 +131,7 @@ instance ( SimpleCrypto c
       equalStakeDist addrDist
 
   anachronisticProtocolLedgerView (EncNodeConfig _ addrDist) _ _ =
-      Just $ SB.unbounded $ equalStakeDist addrDist
+      Right $ SB.unbounded $ equalStakeDist addrDist
 
 {-------------------------------------------------------------------------------
   Serialisation

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/PraosRule.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block/PraosRule.hs
@@ -84,7 +84,7 @@ instance SimpleCrypto c
 instance SimpleCrypto c
       => ProtocolLedgerView (SimplePraosRuleBlock c) where
   protocolLedgerView _ _ = ()
-  anachronisticProtocolLedgerView _ _ _ = Just $ SB.unbounded ()
+  anachronisticProtocolLedgerView _ _ _ = Right $ SB.unbounded ()
 
 {-------------------------------------------------------------------------------
   We don't need crypto for this protocol

diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
 module Test.Dynamic.BFT (
     tests
   ) where
@@ -6,7 +8,6 @@ import           Test.QuickCheck
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
 
-import           Ouroboros.Consensus.BlockchainTime
 import           Ouroboros.Consensus.Demo
 import           Ouroboros.Consensus.Node.ProtocolInfo
 import           Ouroboros.Consensus.Protocol
@@ -20,22 +21,23 @@ import           Test.Util.Orphans.Arbitrary ()
 tests :: TestTree
 tests = testGroup "Dynamic chain generation" [
       testProperty "simple BFT convergence" $
-        prop_simple_bft_convergence params
+        prop_simple_bft_convergence k
     ]
   where
-    params = defaultSecurityParam
+    k = defaultSecurityParam
 
 prop_simple_bft_convergence :: SecurityParam
-                            -> NumCoreNodes
-                            -> NumSlots
+                            -> TestConfig
                             -> Seed
                             -> Property
-prop_simple_bft_convergence k numCoreNodes numSlots seed =
+prop_simple_bft_convergence k
+  testConfig@TestConfig{numCoreNodes, numSlots} seed =
     prop_general k
+        testConfig
         (roundRobinLeaderSchedule numCoreNodes numSlots)
         testOutput
   where
     testOutput =
         runTestNetwork
             (\nid -> protocolInfo numCoreNodes nid (ProtocolMockBFT k))
-            numCoreNodes numSlots seed
+            testConfig seed
diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/General.hs
@@ -5,11 +5,17 @@
 module Test.Dynamic.General (
     prop_general
   , runTestNetwork
+    -- * TestConfig
+  , TestConfig (..)
+  , genTestConfig
+  , shrinkTestConfig
     -- * Re-exports
   , TestOutput (..)
   ) where
 
+import           Control.Monad (join)
 import qualified Data.Map as Map
+import           Data.Word (Word64)
 import           Test.QuickCheck
 
 import           Control.Monad.Class.MonadTime
@@ -35,10 +41,70 @@ import qualified Ouroboros.Storage.FS.Sim.MockFS as Mock
 import           Test.Dynamic.Network
 import           Test.Dynamic.TxGen
 import           Test.Dynamic.Util
+import           Test.Dynamic.Util.NodeJoinPlan
 
+import           Test.Util.Orphans.Arbitrary ()
 import           Test.Util.Range
 
--- | Execute a fully-connected network of nodes that all join immediately
+{-------------------------------------------------------------------------------
+  Configuring tests
+-------------------------------------------------------------------------------}
+
+data TestConfig = TestConfig
+  { numCoreNodes :: !NumCoreNodes
+  , numSlots     :: !NumSlots
+  , nodeJoinPlan :: !NodeJoinPlan
+  }
+  deriving (Show)
+
+genTestConfig :: NumCoreNodes -> NumSlots -> Gen TestConfig
+genTestConfig numCoreNodes numSlots = do
+    nodeJoinPlan <- genNodeJoinPlan numCoreNodes numSlots
+    pure TestConfig{numCoreNodes, numSlots, nodeJoinPlan}
+
+-- | Shrink without changing the number of nodes or slots
+shrinkTestConfig :: TestConfig -> [TestConfig]
+shrinkTestConfig testConfig@TestConfig{nodeJoinPlan} =
+    [ testConfig{nodeJoinPlan = p'}
+    | p' <- shrinkNodeJoinPlan nodeJoinPlan
+    ]
+
+-- | Shrink, including the number of nodes and slots
+shrinkTestConfigFreely :: TestConfig -> [TestConfig]
+shrinkTestConfigFreely TestConfig{numCoreNodes, numSlots, nodeJoinPlan} =
+    tail $   -- drop the identity result
+    [ TestConfig
+        { numCoreNodes = n'
+        , numSlots = t'
+        , nodeJoinPlan = p'
+        }
+    | n' <- numCoreNodes : shrink numCoreNodes
+    , t' <- numSlots : shrink numSlots
+    , let adjustedP = adjustedNodeJoinPlan n' t'
+    , p' <- adjustedP : shrinkNodeJoinPlan adjustedP
+    ]
+  where
+    adjustedNodeJoinPlan (NumCoreNodes n') (NumSlots t') =
+        NodeJoinPlan $
+        -- scale by t' / t
+        Map.map (\(SlotNo i) -> SlotNo $ (i * toEnum t') `div` toEnum t) $
+        -- discard discarded nodes
+        Map.filterWithKey (\(CoreNodeId nid) _ -> nid < n') $
+        m
+      where
+        NumSlots t = numSlots
+        NodeJoinPlan m = nodeJoinPlan
+
+instance Arbitrary TestConfig where
+  arbitrary = join $ genTestConfig <$> arbitrary <*> arbitrary
+  shrink = shrinkTestConfigFreely
+
+{-------------------------------------------------------------------------------
+  Running tests
+-------------------------------------------------------------------------------}
+
+-- | Execute a fully-connected network of nodes that join according to the node
+-- join plan
 --
 -- Runs the network for the specified number of slots, and returns the
 -- resulting 'TestOutput'.
@@ -50,24 +116,29 @@ runTestNetwork ::
      , TracingConstraints blk
      )
   => (CoreNodeId -> ProtocolInfo blk)
-  -> NumCoreNodes
-  -> NumSlots
+  -> TestConfig
   -> Seed
   -> TestOutput blk
-runTestNetwork pInfo numCoreNodes numSlots seed = runSimOrThrow $ do
+runTestNetwork pInfo TestConfig{numCoreNodes, numSlots, nodeJoinPlan}
+  seed = runSimOrThrow $ do
     registry  <- unsafeNewRegistry
     testBtime <- newTestBlockchainTime registry numSlots slotLen
     broadcastNetwork
       registry
       testBtime
       numCoreNodes
+      nodeJoinPlan
       pInfo
       (seedToChaCha seed)
       slotLen
   where
     slotLen :: DiffTime
     slotLen = 100000
 
+{-------------------------------------------------------------------------------
+  Test properties
+-------------------------------------------------------------------------------}
+
 -- | The properties always required
 --
 -- Includes:
@@ -82,25 +153,34 @@ prop_general ::
      , HasHeader blk
      )
   => SecurityParam
+  -> TestConfig
   -> LeaderSchedule
   -> TestOutput blk
   -> Property
-prop_general k schedule TestOutput{testOutputNodes} =
+prop_general k TestConfig{numSlots, nodeJoinPlan} schedule
+  TestOutput{testOutputNodes} =
+    counterexample ("nodeJoinPlan: " <> condense nodeJoinPlan) $
     counterexample ("schedule: " <> condense schedule) $
-    counterexample ("nodeChains: " <> condense nodeChains) $
+    counterexample ("nodeChains: " <> unlines ("" : map (\x -> "  " <> condense x) (Map.toList nodeChains))) $
+    counterexample ("consensus expected: " <> show isConsensusExcepected) $
+    tabulate "consensus expected" [show isConsensusExcepected] $
     tabulate "shortestLength" [show (rangeK k (shortestLength nodeChains))] $
+    tabulate "floor(4 * lastJoinSlot / numSlots)" [show lastJoinSlot] $
     prop_all_common_prefix
         maxForkLength
         (Map.elems nodeChains) .&&.
     conjoin
       [ fileHandleLeakCheck nid nodeInfo
       | (nid, nodeInfo) <- Map.toList nodeInfos ]
   where
-    NumBlocks maxForkLength = determineForkLength k schedule
+    NumBlocks maxForkLength = determineForkLength k nodeJoinPlan schedule
 
     nodeChains = nodeOutputFinalChain <$> testOutputNodes
     nodeInfos  = nodeOutputNodeInfo   <$> testOutputNodes
 
+    isConsensusExcepected :: Bool
+    isConsensusExcepected = consensusExpected k nodeJoinPlan schedule
+
     fileHandleLeakCheck :: NodeId -> NodeInfo blk MockFS -> Property
     fileHandleLeakCheck nid nodeInfo = conjoin
         [ checkLeak "ImmutableDB" $ nodeInfoImmDbFs nodeInfo
@@ -111,3 +191,12 @@ prop_general k schedule TestOutput{testOutputNodes} =
         checkLeak dbName fs = counterexample
           ("Node " <> show nid <> "'s " <> dbName <> " is leaking file handles")
           (Mock.numOpenHandles fs === 0)
+
+    -- in which quarter of the simulation does the last node join?
+    lastJoinSlot :: Maybe Word64
+    lastJoinSlot =
+        fmap (\(SlotNo i, _) -> (4 * i) `div` toEnum t) $
+        Map.maxView m
+      where
+        NumSlots t = numSlots
+        NodeJoinPlan m = nodeJoinPlan