Merge branch 'cad-1877-multi-pool' into cad-1859-k1000-assemblage

cardano-node/src/Cardano/Node/Parsers.hs

@@ -43,6 +43,7 @@ nodeRunParser = do
   shelleyKESFile  <- optional parseKesKeyFilePath
   shelleyVRFFile  <- optional parseVrfKeyFilePath
   shelleyCertFile <- optional parseOperationalCertFilePath
+  shelleyBulkCredsFile <- optional parseBulkCredsFilePath
 
   -- Node Address
   nIPv4Address <- lastOption parseHostIPv4Addr
@@ -72,6 +73,7 @@ nodeRunParser = do
              , shelleyKESFile
              , shelleyVRFFile
              , shelleyCertFile
+             , shelleyBulkCredsFile
              }
            , pncValidateDB = validate
            , pncShutdownIPC = shutdownIPC
@@ -213,6 +215,15 @@ parseOperationalCertFilePath =
         <> completer (bashCompleter "file")
     )
 
+parseBulkCredsFilePath :: Parser FilePath
+parseBulkCredsFilePath =
+  strOption
+    ( long "bulk-credentials-file"
+        <> metavar "FILEPATH"
+        <> help "Path to the bulk pool credentials file."
+        <> completer (bashCompleter "file")
+    )
+
 --TODO: pass the current KES evolution, not the KES_0
 parseKesKeyFilePath :: Parser FilePath
 parseKesKeyFilePath =

cardano-node/src/Cardano/Node/Protocol/Cardano.hs

@@ -21,6 +21,7 @@ module Cardano.Node.Protocol.Cardano
   ) where
 
 import           Prelude
+import           Cardano.Prelude (headMay)
 
 import           Control.Monad.Trans.Except (ExceptT)
 import           Control.Monad.Trans.Except.Extra (firstExceptT)
@@ -158,7 +159,7 @@ mkConsensusProtocolCardano NodeByronProtocolConfiguration {
           shelleyBasedInitialNonce =
             Shelley.genesisHashToPraosNonce shelleyGenesisHash,
           shelleyBasedLeaderCredentials =
-            shelleyLeaderCredentials
+            headMay shelleyLeaderCredentials
         }
         Consensus.ProtocolParamsShelley {
           shelleyProtVer =

cardano-node/src/Cardano/Node/Protocol/Shelley.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 
 module Cardano.Node.Protocol.Shelley
   (
@@ -28,8 +30,7 @@ import qualified Data.Aeson as Aeson
 import qualified Data.ByteString as BS
 import qualified Data.Text as T
 
-import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither,
-                     newExceptT)
+import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither)
 
 import qualified Cardano.Crypto.Hash.Class as Crypto
 
@@ -46,7 +47,7 @@ import           Shelley.Spec.Ledger.Keys (coerceKeyRole)
 import           Shelley.Spec.Ledger.PParams (ProtVer (..))
 
 import           Cardano.Api.Typed hiding (FileError)
-import qualified Cardano.Api.Typed as Api (FileError)
+import qualified Cardano.Api.Typed as Api (FileError(..))
 
 import           Cardano.Node.Types
 
@@ -99,14 +100,14 @@ mkConsensusProtocolShelley NodeShelleyProtocolConfiguration {
     (genesis, genesisHash) <- readGenesis npcShelleyGenesisFile
                                           npcShelleyGenesisFileHash
     firstExceptT GenesisValidationFailure . hoistEither $ validateGenesis genesis
-    optionalLeaderCredentials <- readLeaderCredentials files
+    leaderCredentials <- readLeaderCredentials files
 
     return $ Consensus.ProtocolShelley
       Consensus.ProtocolParamsShelleyBased {
         shelleyBasedGenesis = genesis,
         shelleyBasedInitialNonce = genesisHashToPraosNonce genesisHash,
         shelleyBasedLeaderCredentials =
-          maybeToList optionalLeaderCredentials
+            leaderCredentials
       }
       Consensus.ProtocolParamsShelley {
         shelleyProtVer =
@@ -139,34 +140,91 @@ readGenesis (GenesisFile file) mbExpectedGenesisHash = do
           -> throwError (GenesisHashMismatch actual expected)
         _ -> return ()
 
-
 readLeaderCredentials :: Maybe ProtocolFilepaths
                       -> ExceptT ShelleyProtocolInstantiationError IO
-                                 (Maybe (TPraosLeaderCredentials StandardCrypto))
-
--- It's OK to supply none of the files
-readLeaderCredentials Nothing = return Nothing
-readLeaderCredentials (Just ProtocolFilepaths {
-                              shelleyCertFile = Nothing,
-                              shelleyVRFFile  = Nothing,
-                              shelleyKESFile  = Nothing
-                            }) = return Nothing
-
--- Or to supply all of the files
-readLeaderCredentials (Just ProtocolFilepaths {
-                              shelleyCertFile = Just certFile,
-                              shelleyVRFFile  = Just vrfFile,
-                              shelleyKESFile  = Just kesFile
-                            }) = do
-
-    OperationalCertificate opcert (StakePoolVerificationKey vkey) <-
-      firstExceptT FileError . newExceptT $ readFileTextEnvelope AsOperationalCertificate certFile
-    VrfSigningKey vrfKey <-
-      firstExceptT FileError . newExceptT $ readFileTextEnvelope (AsSigningKey AsVrfKey) vrfFile
-    KesSigningKey kesKey <-
-      firstExceptT FileError . newExceptT $ readFileTextEnvelope (AsSigningKey AsKesKey) kesFile
-
-    return $ Just TPraosLeaderCredentials {
+                                 [TPraosLeaderCredentials StandardCrypto]
+readLeaderCredentials Nothing = return []
+readLeaderCredentials (Just pfp) =
+  readShelleyCredentials pfp
+  >>= mapM parseShelleyCredentials
+
+data ShelleyCredentials
+  = ShelleyCredentials
+    { scCert :: (TextEnvelope, FilePath)
+    , scVrf  :: (TextEnvelope, FilePath)
+    , scKes  :: (TextEnvelope, FilePath)
+    }
+
+readShelleyCredentials ::
+     ProtocolFilepaths
+  -> ExceptT ShelleyProtocolInstantiationError IO
+             [ShelleyCredentials]
+readShelleyCredentials pfp@ProtocolFilepaths { shelleyBulkCredsFile = mfp } =
+  -- The set of credentials files is a sum total of what comes from the CLI,
+  -- as well as what is referred to by the bulk credentials file.
+  (<>) <$> interpCLI pfp <*> readBulkFile mfp
+ where
+   -- It's OK to supply none of the files on the CLI
+   interpCLI ProtocolFilepaths
+     { shelleyCertFile      = Nothing,
+       shelleyVRFFile       = Nothing,
+       shelleyKESFile       = Nothing
+     } = pure []
+   -- Or to supply all of the files
+   interpCLI ProtocolFilepaths
+     { shelleyCertFile      = Just certFile,
+       shelleyVRFFile       = Just vrfFile,
+       shelleyKESFile       = Just kesFile
+     } = fmap (:[]) $ ShelleyCredentials
+                        <$> readEnvelope certFile
+                        <*> readEnvelope vrfFile
+                        <*> readEnvelope kesFile
+   -- But not OK to supply some of the files without the others.
+   interpCLI ProtocolFilepaths {shelleyCertFile = Nothing} =
+     throwError OCertNotSpecified
+   interpCLI ProtocolFilepaths {shelleyVRFFile = Nothing} =
+     throwError VRFKeyNotSpecified
+   interpCLI ProtocolFilepaths {shelleyKESFile = Nothing} =
+     throwError KESKeyNotSpecified
+
+   readEnvelope :: FilePath -> ExceptT ShelleyProtocolInstantiationError IO
+                                       (TextEnvelope, FilePath)
+   readEnvelope fp = do
+     content <- handleIOExceptT (CredentialsReadError fp) $
+                  BS.readFile fp
+     firstExceptT (EnvelopeParseError fp) $ hoistEither $
+       (, fp) <$> Aeson.eitherDecodeStrict' content
+
+   readBulkFile :: Maybe FilePath
+                -> ExceptT ShelleyProtocolInstantiationError IO
+                           [ShelleyCredentials]
+   readBulkFile Nothing = pure []
+   readBulkFile (Just fp) = do
+     content <- handleIOExceptT (CredentialsReadError fp) $
+                  BS.readFile fp
+     envelopes <- firstExceptT (EnvelopeParseError fp) $ hoistEither $
+                    Aeson.eitherDecodeStrict' content
+     pure $ uncurry mkCredentials <$> zip [0..] envelopes
+    where
+      mkCredentials :: Int -> (TextEnvelope, TextEnvelope, TextEnvelope)
+                    -> ShelleyCredentials
+      mkCredentials ix (teCert, teVrf, teKes) =
+       let loc = fp <> ":" <> show ix
+       in ShelleyCredentials (teCert, loc) (teVrf, loc) (teKes, loc)
+
+parseShelleyCredentials ::
+     ShelleyCredentials
+  -> ExceptT ShelleyProtocolInstantiationError IO
+             (TPraosLeaderCredentials StandardCrypto)
+parseShelleyCredentials ShelleyCredentials { scCert, scVrf, scKes } = do
+    (OperationalCertificate opcert (StakePoolVerificationKey vkey),
+     VrfSigningKey vrfKey,
+     KesSigningKey kesKey)
+      <- (,,) <$> parseEnvelope AsOperationalCertificate scCert
+              <*> parseEnvelope (AsSigningKey AsVrfKey) scVrf
+              <*> parseEnvelope (AsSigningKey AsKesKey) scKes
+
+    return $ TPraosLeaderCredentials {
                tpraosLeaderCredentialsCanBeLeader =
                  TPraosCanBeLeader {
                    tpraosCanBeLeaderOpCert     = opcert,
@@ -176,14 +234,15 @@ readLeaderCredentials (Just ProtocolFilepaths {
                tpraosLeaderCredentialsInitSignKey = kesKey,
                tpraosLeaderCredentialsLabel = "Shelley"
              }
-
--- But not OK to supply some of the files without the others.
-readLeaderCredentials (Just ProtocolFilepaths {shelleyCertFile = Nothing}) =
-    throwError OCertNotSpecified
-readLeaderCredentials (Just ProtocolFilepaths {shelleyVRFFile = Nothing}) =
-    throwError VRFKeyNotSpecified
-readLeaderCredentials (Just ProtocolFilepaths {shelleyKESFile = Nothing}) =
-    throwError KESKeyNotSpecified
+  where
+    parseEnvelope ::
+         HasTextEnvelope a
+      => AsType a
+      -> (TextEnvelope, String)
+      -> ExceptT ShelleyProtocolInstantiationError IO a
+    parseEnvelope as (te, loc) =
+      firstExceptT (FileError . Api.FileError loc) . hoistEither $
+        deserialiseFromTextEnvelope as te
 
 
 ------------------------------------------------------------------------------
@@ -195,6 +254,8 @@ data ShelleyProtocolInstantiationError =
      | GenesisHashMismatch !GenesisHash !GenesisHash -- actual, expected
      | GenesisDecodeError !FilePath !String
      | GenesisValidationFailure ![ValidationErr]
+     | CredentialsReadError !FilePath !IOException
+     | EnvelopeParseError !FilePath !String
      | FileError !(Api.FileError TextEnvelopeError)
 --TODO: pick a less generic constructor than FileError
 
@@ -223,6 +284,14 @@ renderShelleyProtocolInstantiationError pie =
 
     GenesisValidationFailure vErrs -> T.unlines $ map describeValidationErr vErrs
 
+    CredentialsReadError fp err ->
+        "There was an error reading a credentials file: "
+     <> toS fp <> " Error: " <> T.pack (show err)
+
+    EnvelopeParseError fp err ->
+        "There was an error parsing a credentials envelope: "
+     <> toS fp <> " Error: " <> T.pack (show err)
+
     FileError fileErr -> T.pack $ displayError fileErr
 
     OCertNotSpecified  -> missingFlagMessage "shelley-operational-certificate"

cardano-node/src/Cardano/Node/Types.hs

@@ -245,11 +245,12 @@ class AdjustFilePaths a where
 
 data ProtocolFilepaths =
      ProtocolFilepaths {
-       byronCertFile   :: !(Maybe FilePath)
-     , byronKeyFile    :: !(Maybe FilePath)
-     , shelleyKESFile  :: !(Maybe FilePath)
-     , shelleyVRFFile  :: !(Maybe FilePath)
-     , shelleyCertFile :: !(Maybe FilePath)
+       byronCertFile        :: !(Maybe FilePath)
+     , byronKeyFile         :: !(Maybe FilePath)
+     , shelleyKESFile       :: !(Maybe FilePath)
+     , shelleyVRFFile       :: !(Maybe FilePath)
+     , shelleyCertFile      :: !(Maybe FilePath)
+     , shelleyBulkCredsFile :: !(Maybe FilePath)
      } deriving (Eq, Show)
 
 newtype GenesisHash = GenesisHash (Crypto.Hash Crypto.Blake2b_256 ByteString)

cardano-node/test/Test/Cardano/Node/POM.hs

@@ -74,7 +74,7 @@ testPartialCliConfig =
     , pncDatabaseFile = mempty
     , pncSocketPath   = mempty
     , pncDiffusionMode = mempty
-    , pncProtocolFiles = Last . Just $ ProtocolFilepaths Nothing Nothing Nothing Nothing Nothing
+    , pncProtocolFiles = Last . Just $ ProtocolFilepaths Nothing Nothing Nothing Nothing Nothing Nothing
     , pncValidateDB = Last $ Just True
     , pncShutdownIPC = Last $ Just Nothing
     , pncShutdownOnSlotSynced = Last . Just . MaxSlotNo $ SlotNo 42
@@ -96,7 +96,7 @@ expectedConfig =
     , ncConfigFile = ConfigYamlFilePath "configuration/cardano/mainnet-config.json"
     , ncTopologyFile = TopologyFile "configuration/cardano/mainnet-topology.json"
     , ncDatabaseFile = DbFile "mainnet/db/"
-    , ncProtocolFiles = ProtocolFilepaths Nothing Nothing Nothing Nothing Nothing
+    , ncProtocolFiles = ProtocolFilepaths Nothing Nothing Nothing Nothing Nothing Nothing
     , ncValidateDB = True
     , ncShutdownIPC = Nothing
     , ncShutdownOnSlotSynced = MaxSlotNo $ SlotNo 42