Merge #916

916: fixup Real PBFT setup r=mrBliss a=nfrisby The `RealPBFT` setup was creating nodes with different `CoreNodeId`s than expected. This was causing property failures during my work-in-progress on Issue #231 PR #773. Is it safe to export `plcCoreNodeId`, even just for testing? I'm weary of adding exports to code I'm not familiar with. Co-authored-by: Nicolas Frisby <[email protected]>
IntersectMBO · Aug 13, 2019 · b42077e · b42077e
2 parents 316dc13 + b51de58
commit b42077e
Show file tree

Hide file tree

Showing 2 changed files with 32 additions and 8 deletions.
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/ProtocolInfo/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/ProtocolInfo/Byron.hs
@@ -15,6 +15,8 @@ module Ouroboros.Consensus.Node.ProtocolInfo.Byron (
   , PBftLeaderCredentials
   , PBftLeaderCredentialsError
   , mkPBftLeaderCredentials
+    -- * For testing
+  , plcCoreNodeId
   ) where
 
 import           Control.Exception (Exception)
@@ -51,7 +53,7 @@ import qualified Test.Cardano.Chain.Genesis.Dummy as Dummy
 data PBftLeaderCredentials = PBftLeaderCredentials {
       plcSignKey     :: Crypto.SigningKey
     , plcDlgCert     :: Delegation.Certificate
-    , plcCodeNodeId  :: CoreNodeId
+    , plcCoreNodeId  :: CoreNodeId
     } deriving Show
 
 -- | Make the 'PBftLeaderCredentials', with a couple sanity checks:
@@ -76,7 +78,7 @@ mkPBftLeaderCredentials gc sk cert = do
     return PBftLeaderCredentials {
       plcSignKey     = sk
     , plcDlgCert     = cert
-    , plcCodeNodeId  = nid
+    , plcCoreNodeId  = nid
     }
   where
     (?!) :: Maybe a -> e -> Either e a

diff --git a/ouroboros-consensus/test-consensus/Test/Dynamic/RealPBFT.hs b/ouroboros-consensus/test-consensus/Test/Dynamic/RealPBFT.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE GADTs               #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -25,6 +26,7 @@ import           Ouroboros.Consensus.BlockchainTime
 import           Ouroboros.Consensus.Demo
 import           Ouroboros.Consensus.Ledger.Byron (ByronBlockOrEBB, ByronGiven)
 import           Ouroboros.Consensus.Node.ProtocolInfo
+import           Ouroboros.Consensus.Node.ProtocolInfo.Byron (plcCoreNodeId)
 import           Ouroboros.Consensus.NodeId
 import           Ouroboros.Consensus.Protocol
 import           Ouroboros.Consensus.Util.Random
@@ -42,13 +44,33 @@ import           Test.Dynamic.Util
 import           Test.Util.Orphans.Arbitrary ()
 
 tests :: TestTree
-tests = testGroup "Dynamic chain generation" [
-      testProperty "simple Real PBFT convergence" $
+tests = testGroup "Dynamic chain generation"
+    [ testProperty "check Real PBFT setup" $
+        \numCoreNodes ->
+          forAll (elements (enumCoreNodes numCoreNodes)) $ \coreNodeId ->
+          prop_setup_coreNodeId numCoreNodes coreNodeId
+    , testProperty "simple Real PBFT convergence" $
         prop_simple_real_pbft_convergence sp
     ]
   where
     sp = defaultSecurityParam
 
+prop_setup_coreNodeId ::
+     NumCoreNodes
+  -> CoreNodeId
+  -> Property
+prop_setup_coreNodeId numCoreNodes coreNodeId =
+    case mkProtocolRealPBFT numCoreNodes coreNodeId genesisConfig genesisSecrets of
+      ProtocolRealPBFT _cfg _th _pv _swv (Just plc) ->
+          coreNodeId === plcCoreNodeId plc
+      _ ->
+          counterexample "mkProtocolRealPBFT did not use ProtocolRealPBFT" $
+          property False
+  where
+    genesisConfig  :: Genesis.Config
+    genesisSecrets :: Genesis.GeneratedSecrets
+    (genesisConfig, genesisSecrets) = generateGenesisConfig numCoreNodes
+
 prop_simple_real_pbft_convergence :: SecurityParam
                                   -> NumCoreNodes
                                   -> NumSlots
@@ -106,12 +128,12 @@ mkProtocolRealPBFT (NumCoreNodes n) (CoreNodeId i)
       1.0 / (fromIntegral n + 1.0)
 
     dlgKey :: Crypto.SigningKey
-    dlgKey = Genesis.gsRichSecrets genesisSecrets !! i
+    dlgKey = fromJust $
+       find (\sec -> Delegation.delegateVK dlgCert == Crypto.toVerification sec)
+            $ Genesis.gsRichSecrets genesisSecrets
 
     dlgCert :: Delegation.Certificate
-    dlgCert = fromJust $
-      find (\crt -> Delegation.delegateVK crt == Crypto.toVerification dlgKey)
-           (Map.elems dlgMap)
+    dlgCert = snd $ Map.toAscList dlgMap !! i
 
     dlgMap :: Map Common.KeyHash Delegation.Certificate
     dlgMap = Genesis.unGenesisDelegation