Merge #326

326: Refactor `fromProtocol` r=Jimbo4350 a=Jimbo4350 This PR: - Refactors `fromProtocol` to accept exactly what it needs. - Removes extraneous command line arguments as a result of the above refactor. Relevant: #311 Co-authored-by: Jordan Millar <[email protected]>
IntersectMBO · Nov 26, 2019 · 950e7c5 · 950e7c5
2 parents d56ef7e + c53f6fd
commit 950e7c5
Show file tree

Hide file tree

Showing 22 changed files with 451 additions and 281 deletions.
diff --git a/cardano-config/src/Cardano/Config/CommonCLI.hs b/cardano-config/src/Cardano/Config/CommonCLI.hs
@@ -25,11 +25,14 @@ module Cardano.Config.CommonCLI
   , parseDbPathLast
   , parseDelegationCert
   , parseDelegationCertLast
+  , parseGenesisHash
   , parseGenesisHashLast
   , parseGenesisPath
   , parseGenesisPathLast
+  , parsePbftSigThreshold
   , parsePbftSigThresholdLast
-  , parseRequireNetworkMagicLast
+  , parseRequiresNetworkMagic
+  , parseRequiresNetworkMagicLast
   , parseSigningKey
   , parseSlotLengthLast
   , parseSocketDir
@@ -45,6 +48,7 @@ import qualified Prelude
 import           Options.Applicative hiding (command)
 import qualified Options.Applicative as OA
 
+import           Cardano.Crypto (RequiresNetworkMagic(..))
 import qualified Ouroboros.Consensus.BlockchainTime as Consensus
 
 import           Cardano.Config.Partial
@@ -63,7 +67,7 @@ data CommonCLI = CommonCLI
 
 data CommonCLIAdvanced = CommonCLIAdvanced
   { ccaPBftSigThd                 :: !(Last Double)
-  , ccaRequiresNetworkMagic       :: !(Last RequireNetworkMagic)
+  , ccaRequiresNetworkMagic       :: !(Last RequiresNetworkMagic)
   , ccaSlotLength                 :: !(Last Consensus.SlotLength)
   --TODO cliUpdate                :: !PartialUpdate
   }
@@ -95,6 +99,14 @@ parseGenesisPathLast =
         <> help "The filepath to the genesis file."
     )
 
+parseGenesisHash :: Parser Text
+parseGenesisHash =
+  strOption
+    ( long "genesis-hash"
+        <> metavar "GENESIS-HASH"
+        <> help "The genesis hash value."
+    )
+
 parseGenesisHashLast :: Parser (Last Text)
 parseGenesisHashLast =
   lastStrOption
@@ -187,6 +199,16 @@ parseCommonCLI =
          <> help "Directory with local sockets:  ${dir}/node-{core,relay}-${node-id}.socket"
         )
 
+parsePbftSigThreshold :: Parser (Maybe Double)
+parsePbftSigThreshold =
+  optional $ option auto
+    ( long "pbft-signature-threshold"
+        <> metavar "DOUBLE"
+        <> help "The PBFT signature threshold."
+        <> hidden
+    )
+
+
 parsePbftSigThresholdLast :: Parser (Last Double)
 parsePbftSigThresholdLast =
   lastDoubleOption
@@ -195,9 +217,18 @@ parsePbftSigThresholdLast =
         <> help "The PBFT signature threshold."
         <> hidden
     )
-parseRequireNetworkMagicLast :: Parser (Last RequireNetworkMagic)
-parseRequireNetworkMagicLast =
-  lastFlag NoRequireNetworkMagic RequireNetworkMagic
+
+parseRequiresNetworkMagic :: Parser RequiresNetworkMagic
+parseRequiresNetworkMagic =
+  flag RequiresNoMagic RequiresMagic
+    ( long "require-network-magic"
+        <> help "Require network magic in transactions."
+        <> hidden
+    )
+
+parseRequiresNetworkMagicLast :: Parser (Last RequiresNetworkMagic)
+parseRequiresNetworkMagicLast =
+  lastFlag RequiresNoMagic RequiresMagic
     ( long "require-network-magic"
         <> help "Require network magic in transactions."
         <> hidden
@@ -225,7 +256,7 @@ parseCommonCLIAdvanced =
           <> help "The PBFT signature threshold."
           <> hidden
            )
-    <*> lastFlag NoRequireNetworkMagic RequireNetworkMagic
+    <*> lastFlag RequiresNoMagic RequiresMagic
            ( long "require-network-magic"
           <> help "Require network magic in transactions."
           <> hidden

diff --git a/cardano-config/src/Cardano/Config/Partial.hs b/cardano-config/src/Cardano/Config/Partial.hs
@@ -20,7 +20,6 @@ module Cardano.Config.Partial
     , PartialCertificate (..)
     , PartialWallet (..)
     -- * re-exports
-    , RequireNetworkMagic (..)
     , NodeProtocol (..)
     , mkCardanoConfiguration
     ) where
@@ -34,6 +33,7 @@ import qualified Ouroboros.Consensus.BlockchainTime as Consensus
 
 import           Cardano.Config.Types
 import           Cardano.Config.Topology
+import           Cardano.Crypto (RequiresNetworkMagic)
 
 -- | Partial @CardanoConfiguration@ configuration.
 data PartialCardanoConfiguration = PartialCardanoConfiguration
@@ -73,7 +73,7 @@ data PartialCore = PartialCore
     -- ^ The type of protocol run on the node.
     , pcoStaticKeySigningKeyFile    :: !(Last FilePath)
     , pcoStaticKeyDlgCertFile       :: !(Last FilePath)
-    , pcoRequiresNetworkMagic       :: !(Last RequireNetworkMagic)
+    , pcoRequiresNetworkMagic       :: !(Last RequiresNetworkMagic)
     , pcoPBftSigThd                 :: !(Last Double)
     } deriving (Eq, Show, Generic)
     deriving Semigroup via GenericSemigroup PartialCore

diff --git a/cardano-config/src/Cardano/Config/Presets.hs b/cardano-config/src/Cardano/Config/Presets.hs
@@ -23,11 +23,11 @@ import           Cardano.Config.Partial ( NodeProtocol (..)
                                         , PartialTXP (..)
                                         , PartialUpdate (..)
                                         , PartialWallet (..)
-                                        , RequireNetworkMagic (..)
                                         )
 import           Cardano.Config.Topology (NodeAddress(..), NodeHostAddress(..),
                                           TopologyInfo(..))
 import           Cardano.Config.Types (Protocol(..), ViewMode(..))
+import           Cardano.Crypto (RequiresNetworkMagic(..))
 
 --------------------------------------------------------------------------------
 -- Cardano Mainnet Configuration
@@ -40,7 +40,7 @@ mainnetConfiguration =
     , pccLogConfig = pure "./configuration/log-configuration.yaml"
     , pccDBPath = pure "./db/"
     , pccApplicationLockFile = pure ""
-    , pccTopologyInfo = pure $ TopologyInfo (RelayId 0) "./configuration/simple-topology.json"
+    , pccTopologyInfo = pure $ TopologyInfo (CoreId 0) "./configuration/simple-topology.json"
     , pccNodeAddress = pure $ NodeAddress (NodeHostAddress Nothing) 7000
     , pccProtocol = pure ByronLegacy
     , pccViewMode = pure LiveView
@@ -56,7 +56,7 @@ mainnetConfiguration =
           , pcoNodeProtocol = pure BFTProtocol
           , pcoStaticKeySigningKeyFile = mempty
           , pcoStaticKeyDlgCertFile = mempty
-          , pcoRequiresNetworkMagic = pure NoRequireNetworkMagic
+          , pcoRequiresNetworkMagic = pure RequiresNoMagic
           , pcoPBftSigThd = mempty
           }
     , pccNTP =
@@ -158,7 +158,7 @@ devConfiguration =
     , pccLogConfig = pure "./log-config.yaml"
     , pccSocketDir = pure "./socket/"
     , pccApplicationLockFile = pure ""
-    , pccTopologyInfo = pure $ TopologyInfo (RelayId 0) "./configuration/simple-topology.json"
+    , pccTopologyInfo = pure $ TopologyInfo (CoreId 0) "./configuration/simple-topology.json"
     , pccNodeAddress = pure $ NodeAddress (NodeHostAddress Nothing) 7000
     , pccProtocol = pure ByronLegacy
     , pccViewMode = pure LiveView
@@ -173,7 +173,7 @@ devConfiguration =
           , pcoNodeProtocol = pure BFTProtocol
           , pcoStaticKeySigningKeyFile = mempty
           , pcoStaticKeyDlgCertFile = mempty
-          , pcoRequiresNetworkMagic = pure RequireNetworkMagic
+          , pcoRequiresNetworkMagic = pure RequiresMagic
           , pcoPBftSigThd = mempty
           }
     , pccNTP =

diff --git a/cardano-config/src/Cardano/Config/Protocol.hs b/cardano-config/src/Cardano/Config/Protocol.hs
@@ -22,15 +22,13 @@ import           Prelude (error, fail)
 import           Test.Cardano.Prelude (canonicalDecodePretty)
 
 import           Codec.CBOR.Read (deserialiseFromBytes, DeserialiseFailure)
-import           Control.Exception hiding (throwIO)
 import qualified Data.ByteString.Lazy as LB
 import           Data.Text (unpack)
 
 import qualified Cardano.Chain.Genesis as Genesis
 import qualified Cardano.Chain.Update as Update
-import           Cardano.Crypto (decodeAbstractHash)
+import           Cardano.Crypto (RequiresNetworkMagic, decodeHash)
 import qualified Cardano.Crypto.Signing as Signing
-import           Cardano.Shell.Lib (GeneralException (..))
 
 import           Ouroboros.Consensus.Block (Header)
 import           Ouroboros.Consensus.Mempool.API (ApplyTxErr, GenTx, GenTxId)
@@ -51,9 +49,8 @@ import           Ouroboros.Network.Block
 
 import           Cardano.Config.Types
                    (DelegationCertFile (..), GenesisFile (..),
-                    MiscellaneousFilepaths (..), NodeCLI (..),
-                    NodeConfiguration (..), LastKnownBlockVersion (..),
-                    Update (..), Protocol (..), SigningKeyFile (..))
+                    LastKnownBlockVersion (..), Update (..),
+                    Protocol (..), SigningKeyFile (..))
 
 -- TODO: consider not throwing this, or wrap it in a local error type here
 -- that has proper error messages.
@@ -90,63 +87,72 @@ mockSecurityParam = SecurityParam 5
 -- 'CardanoConfiguration', a 'MissingNodeInfo' exception is thrown.
 mockSomeProtocol
   :: (RunNode blk, TraceConstraints blk)
-  => NodeConfiguration
+  => Maybe NodeId
+  -> Maybe Int
+  -- ^ Number of core nodes
   -> (CoreNodeId -> NumCoreNodes -> Consensus.Protocol blk)
   -> IO SomeProtocol
-mockSomeProtocol nc mkConsensusProtocol =  do
-    (cid, numCoreNodes) <- either throwIO return $ extractNodeInfo nc
+mockSomeProtocol nId mNumCoreNodes mkConsensusProtocol =  do
+    (cid, numCoreNodes) <- either throwIO return $ extractNodeInfo nId mNumCoreNodes
     let p = mkConsensusProtocol cid numCoreNodes
     case Consensus.runProtocol p of
       Dict -> return $ SomeProtocol p
 
-
-
 data SomeProtocol where
   SomeProtocol :: (RunNode blk, TraceConstraints blk)
                => Consensus.Protocol blk -> SomeProtocol
 
-fromProtocol :: NodeConfiguration
-             -> NodeCLI
-             -> IO SomeProtocol
-fromProtocol nc nCli = case ncProtocol nc of
-  ByronLegacy ->
-    error "Byron Legacy protocol is not implemented."
-
-  BFT         -> mockSomeProtocol nc $ \cid numCoreNodes ->
+fromProtocol
+  :: Text
+  -> Maybe NodeId
+  -> Maybe Int
+  -- ^ Number of core nodes
+  -> GenesisFile
+  -> RequiresNetworkMagic
+  -> Maybe Double
+  -> Maybe DelegationCertFile
+  -> Maybe SigningKeyFile
+  -> Update
+  -> Protocol
+  -> IO SomeProtocol
+fromProtocol _ _ _ _ _ _ _ _ _ ByronLegacy =
+  error "Byron Legacy protocol is not implemented."
+fromProtocol _ nId mNumCoreNodes _ _ _ _ _ _ BFT =
+  mockSomeProtocol nId mNumCoreNodes $ \cid numCoreNodes ->
     Consensus.ProtocolMockBFT numCoreNodes cid mockSecurityParam
-
-  Praos       -> mockSomeProtocol nc $ \cid numCoreNodes ->
+fromProtocol _ nId mNumCoreNodes _ _ _ _ _ _ Praos =
+  mockSomeProtocol nId mNumCoreNodes $ \cid numCoreNodes ->
     Consensus.ProtocolMockPraos numCoreNodes cid PraosParams {
         praosSecurityParam = mockSecurityParam
       , praosSlotsPerEpoch = 3
       , praosLeaderF       = 0.5
       , praosLifetimeKES   = 1000000
-      }
-
-  MockPBFT    -> mockSomeProtocol nc $ \cid numCoreNodes@(NumCoreNodes numNodes) ->
-    Consensus.ProtocolMockPBFT numCoreNodes cid PBftParams {
-        pbftSecurityParam      = mockSecurityParam
-      , pbftNumNodes           = fromIntegral numNodes
-      , pbftSignatureThreshold = (1.0 / fromIntegral numNodes) + 0.1
-      }
-
-  RealPBFT    -> do
-    let NodeConfiguration { ncGenesisHash } = nc
-        genHash = either (throw . ConfigurationError) identity $
-                  decodeAbstractHash ncGenesisHash
+    }
+fromProtocol _ nId mNumCoreNodes _ _ _ _ _ _ MockPBFT =
+  mockSomeProtocol nId mNumCoreNodes $ \cid numCoreNodes@(NumCoreNodes numNodes) ->
+    Consensus.ProtocolMockPBFT numCoreNodes cid
+      PBftParams { pbftSecurityParam      = mockSecurityParam
+                 , pbftNumNodes           = fromIntegral numNodes
+                 , pbftSignatureThreshold = (1.0 / fromIntegral numNodes) + 0.1
+                 }
+fromProtocol gHash _ _ genFile nMagic sigThresh delCertFp sKeyFp update RealPBFT = do
+    let genHash = either panic identity $ decodeHash gHash
 
     gcE <- runExceptT (Genesis.mkConfigFromFile
-                       (ncReqNetworkMagic nc)
-                       (unGenesisFile . genesisFile $ mscFp nCli)
+                       nMagic
+                       (unGenesisFile genFile)
                        genHash
                       )
     let gc = case gcE of
-          Left err -> throw err -- TODO: no no no!
-          Right x -> x
+            Left err -> panic $ show err
+            Right x -> x
 
-    optionalLeaderCredentials <- readLeaderCredentials gc nCli
+    optionalLeaderCredentials <- readLeaderCredentials
+                                   gc
+                                   delCertFp
+                                   sKeyFp
 
-    let p = protocolConfigRealPbft nc gc optionalLeaderCredentials
+    let p = protocolConfigRealPbft update sigThresh gc optionalLeaderCredentials
 
     case Consensus.runProtocol p of
       Dict -> return $ SomeProtocol p
@@ -155,25 +161,20 @@ fromProtocol nc nCli = case ncProtocol nc of
 -- | The plumbing to select and convert the appropriate configuration subset
 -- for the 'RealPBFT' protocol.
 --
-protocolConfigRealPbft :: NodeConfiguration
+protocolConfigRealPbft :: Update
+                       -> Maybe Double
                        -> Genesis.Config
                        -> Maybe PBftLeaderCredentials
                        -> Consensus.Protocol Consensus.ByronBlock
-protocolConfigRealPbft NodeConfiguration {
-                         ncPbftSignatureThresh,
-                         ncUpdate = Update {
-                           upApplicationName,
-                           upApplicationVersion,
-                           upLastKnownBlockVersion
-                         }
-                       }
+protocolConfigRealPbft (Update appName appVer lastKnownBlockVersion)
+                       pbftSignatureThresh
                        genesis leaderCredentials =
     Consensus.ProtocolRealPBFT
       genesis
-      (PBftSignatureThreshold <$> ncPbftSignatureThresh)
-      (convertProtocolVersion upLastKnownBlockVersion)
-      (Update.SoftwareVersion (Update.ApplicationName upApplicationName)
-                              (toEnum upApplicationVersion))
+      (PBftSignatureThreshold <$> pbftSignatureThresh)
+      (convertProtocolVersion lastKnownBlockVersion)
+      (Update.SoftwareVersion (Update.ApplicationName appName)
+                              (toEnum appVer))
       leaderCredentials
   where
     convertProtocolVersion
@@ -184,11 +185,10 @@ protocolConfigRealPbft NodeConfiguration {
 
 
 readLeaderCredentials :: Genesis.Config
-                      -> NodeCLI
+                      -> Maybe DelegationCertFile
+                      -> Maybe SigningKeyFile
                       -> IO (Maybe PBftLeaderCredentials)
-readLeaderCredentials gc nCli = do
-  let mDelCertFp = delegCertFile $ mscFp nCli
-  let mSKeyFp = signKeyFile $ mscFp nCli
+readLeaderCredentials gc mDelCertFp mSKeyFp = do
   case (mDelCertFp, mSKeyFp) of
     (Nothing, Nothing) -> pure Nothing
     (Just _, Nothing) -> panic "Signing key filepath not specified"
@@ -221,12 +221,13 @@ data MissingNodeInfo
   deriving (Show, Exception)
 
 extractNodeInfo
-  :: NodeConfiguration
+  :: Maybe NodeId
+  -> Maybe Int
   -> Either MissingNodeInfo (CoreNodeId, NumCoreNodes)
-extractNodeInfo NodeConfiguration { ncNodeId, ncNumCoreNodes } = do
+extractNodeInfo mNodeId ncNumCoreNodes  = do
 
-    coreNodeId   <- case ncNodeId of
-      CoreId coreNodeId -> pure coreNodeId
-      _                 -> Left MissingCoreNodeId
+    coreNodeId   <- case mNodeId of
+                      Just (CoreId coreNodeId) -> pure coreNodeId
+                      _ -> Left MissingCoreNodeId
     numCoreNodes <- maybe (Left MissingNumCoreNodes) Right ncNumCoreNodes
     return (CoreNodeId coreNodeId , NumCoreNodes numCoreNodes)