From 3e9d75e927a4b6de8be93a965514bd227d72098f Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Tue, 26 Jul 2022 13:29:42 -0500 Subject: [PATCH] Introduce the --relay-specification-file option to the create-staked command. This will allow the specification of the pool relays for all of the created stake pools --- cardano-api/src/Cardano/Api/Shelley.hs | 2 +- .../src/Cardano/CLI/Shelley/Commands.hs | 15 ++- .../src/Cardano/CLI/Shelley/Parsers.hs | 12 ++- .../src/Cardano/CLI/Shelley/Run/Genesis.hs | 100 ++++++++++++------ 4 files changed, 92 insertions(+), 37 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index 2ab1c9c4562..f167e71b345 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -235,8 +235,8 @@ import Cardano.Api.Address import Cardano.Api.Block import Cardano.Api.Certificate import Cardano.Api.Eras -import Cardano.Api.IPC import Cardano.Api.InMode +import Cardano.Api.IPC import Cardano.Api.KeysByron import Cardano.Api.KeysPraos import Cardano.Api.KeysShelley diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs index da0e428f0f7..50272e1b894 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs @@ -429,7 +429,20 @@ renderTextViewCmd (TextViewInfo _ _) = "text-view decode-cbor" data GenesisCmd = GenesisCreate GenesisDir Word Word (Maybe SystemStart) (Maybe Lovelace) NetworkId | GenesisCreateCardano GenesisDir Word Word (Maybe SystemStart) (Maybe Lovelace) BlockCount Word Rational NetworkId FilePath FilePath FilePath (Maybe FilePath) - | GenesisCreateStaked GenesisDir Word Word Word Word (Maybe SystemStart) (Maybe Lovelace) Lovelace NetworkId Word Word Word + | GenesisCreateStaked + GenesisDir + Word + Word + Word + Word + (Maybe SystemStart) + (Maybe Lovelace) + Lovelace + NetworkId + Word + Word + Word + FilePath -- ^ Relay specification filepath | GenesisKeyGenGenesis VerificationKeyFile SigningKeyFile | GenesisKeyGenDelegate VerificationKeyFile SigningKeyFile OpCertCounterFile | GenesisKeyGenUTxO VerificationKeyFile SigningKeyFile diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index d92058e9458..8193c24efef 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -1232,6 +1232,7 @@ pGenesisCmd = <*> pBulkPoolCredFiles <*> pBulkPoolsPerFile <*> pStuffedUtxoCount + <*> pRelayJsonFp pGenesisHash :: Parser GenesisCmd pGenesisHash = @@ -1304,6 +1305,15 @@ pGenesisCmd = <> Opt.value 0 ) + pRelayJsonFp :: Parser FilePath + pRelayJsonFp = + Opt.strOption + ( Opt.long "relay-specification-file" + <> Opt.metavar "FILE" + <> Opt.help "JSON file specified the relays of each stake pool." + <> Opt.completer (Opt.bashCompleter "file") + ) + convertTime :: String -> UTCTime convertTime = parseTimeOrError False defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%SZ") @@ -2779,7 +2789,7 @@ eDNSName :: String -> Either String ByteString eDNSName str = -- We're using 'Shelley.textToDns' to validate the string. case Shelley.textToDns (toS str) of - Nothing -> Left "DNS name is more than 64 bytes" + Nothing -> Left $ "DNS name is more than 64 bytes: " <> str Just dnsName -> Right . Text.encodeUtf8 . Shelley.dnsToText $ dnsName pSingleHostAddress :: Parser StakePoolRelay diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs index b7d639d3483..ec8b385a24c 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs @@ -23,7 +23,7 @@ module Cardano.CLI.Shelley.Run.Genesis ) where import Cardano.Prelude hiding (unlines) -import Prelude (error, id, unlines, zip3) +import Prelude (String, error, id, unlines, zip3) import Data.Aeson hiding (Key) import qualified Data.Aeson as Aeson @@ -92,12 +92,12 @@ import Cardano.CLI.Shelley.Run.StakeAddress (ShelleyStakeAddressCmdErr renderShelleyStakeAddressCmdError, runStakeAddressKeyGenToFile) import Cardano.CLI.Types -import Cardano.CLI.Byron.Delegation -import Cardano.CLI.Byron.Genesis as Byron -import qualified Cardano.CLI.Byron.Key as Byron import qualified Cardano.Chain.Common as Byron (KeyHash, mkKnownLovelace, rationalToLovelacePortion) import Cardano.Chain.Genesis (FakeAvvmOptions (..), TestnetBalanceOptions (..), gdProtocolParameters, gsDlgIssuersSecrets, gsPoorSecrets, gsRichSecrets) +import Cardano.CLI.Byron.Delegation +import Cardano.CLI.Byron.Genesis as Byron +import qualified Cardano.CLI.Byron.Key as Byron import qualified Cardano.Crypto.Signing as Byron import Cardano.Api.SerialiseTextEnvelope (textEnvelopeToJSON) @@ -115,8 +115,8 @@ import Data.ListMap (ListMap (..)) import qualified Cardano.CLI.IO.Lazy as Lazy -import System.Random (StdGen) import qualified System.Random as Random +import System.Random (StdGen) data ShelleyGenesisCmdError = ShelleyGenesisCmdAesonDecodeError !FilePath !Text @@ -136,6 +136,8 @@ data ShelleyGenesisCmdError | ShelleyGenesisCmdStakeAddressCmdError !ShelleyStakeAddressCmdError | ShelleyGenesisCmdCostModelsError !FilePath | ShelleyGenesisCmdByronError !ByronGenesisError + | ShelleyGenesisStakePoolRelayFileError !FilePath !IOException + | ShelleyGenesisStakePoolRelayJsonDecodeError !FilePath !String deriving Show instance Error ShelleyGenesisCmdError where @@ -176,6 +178,12 @@ instance Error ShelleyGenesisCmdError where " Error: " <> Text.unpack e ShelleyGenesisCmdGenesisFileReadError e -> displayError e ShelleyGenesisCmdByronError e -> show e + ShelleyGenesisStakePoolRelayFileError fp e -> + "Error occurred while reading the stake pool relay specification file: " <> fp <> + " Error: " <> show e + ShelleyGenesisStakePoolRelayJsonDecodeError fp e -> + "Error occurred while decoding the stake pool relay specification file: " <> fp <> + " Error: " <> e runGenesisCmd :: GenesisCmd -> ExceptT ShelleyGenesisCmdError IO () runGenesisCmd (GenesisKeyGenGenesis vk sk) = runGenesisKeyGenGenesis vk sk @@ -187,7 +195,8 @@ runGenesisCmd (GenesisTxIn vk nw mOutFile) = runGenesisTxIn vk nw mOutFile runGenesisCmd (GenesisAddr vk nw mOutFile) = runGenesisAddr vk nw mOutFile runGenesisCmd (GenesisCreate gd gn un ms am nw) = runGenesisCreate gd gn un ms am nw runGenesisCmd (GenesisCreateCardano gd gn un ms am k slotLength sc nw bg sg ag mNodeCfg) = runGenesisCreateCardano gd gn un ms am k slotLength sc nw bg sg ag mNodeCfg -runGenesisCmd (GenesisCreateStaked gd gn gp gl un ms am ds nw bf bp su) = runGenesisCreateStaked gd gn gp gl un ms am ds nw bf bp su +runGenesisCmd (GenesisCreateStaked gd gn gp gl un ms am ds nw bf bp su relayJsonFp) = + runGenesisCreateStaked gd gn gp gl un ms am ds nw bf bp su relayJsonFp runGenesisCmd (GenesisHashFile gf) = runGenesisHashFile gf -- @@ -661,11 +670,13 @@ runGenesisCreateStaked -> Word -- ^ bulk credential files to write -> Word -- ^ pool credentials per bulk file -> Word -- ^ num stuffed UTxO entries + -> FilePath -- ^ Specified stake pool relays -> ExceptT ShelleyGenesisCmdError IO () runGenesisCreateStaked (GenesisDir rootdir) genNumGenesisKeys genNumUTxOKeys genNumPools genNumStDelegs mStart mNonDlgAmount stDlgAmount network - bulkPoolCredFiles bulkPoolsPerFile numStuffedUtxo = do + numBulkPoolCredFiles bulkPoolsPerFile numStuffedUtxo + sPoolRelayFp = do liftIO $ do createDirectoryIfMissing False rootdir createDirectoryIfMissing False gendir @@ -678,31 +689,39 @@ runGenesisCreateStaked (GenesisDir rootdir) alonzoGenesis <- readAlonzoGenesis (rootdir "genesis.alonzo.spec.json") forM_ [ 1 .. genNumGenesisKeys ] $ \index -> do - createGenesisKeys gendir index + createGenesisKeys gendir index createDelegateKeys deldir index forM_ [ 1 .. genNumUTxOKeys ] $ \index -> createUtxoKeys utxodir index - pools <- forM [ 1 .. genNumPools ] $ \index -> do + relaySpecificationJsonBs + <- handleIOExceptT (ShelleyGenesisStakePoolRelayFileError sPoolRelayFp) + $ LBS.readFile sPoolRelayFp + + specifiedStakePoolRelays + <- firstExceptT (ShelleyGenesisStakePoolRelayJsonDecodeError sPoolRelayFp) + . hoistEither $ Aeson.eitherDecode relaySpecificationJsonBs + + poolParams <- forM [ 1 .. genNumPools ] $ \index -> do createPoolCredentials pooldir index - buildPool network pooldir index + buildPoolParams network pooldir index specifiedStakePoolRelays - when (bulkPoolCredFiles * bulkPoolsPerFile > genNumPools) $ - left $ ShelleyGenesisCmdTooFewPoolsForBulkCreds genNumPools bulkPoolCredFiles bulkPoolsPerFile + when (numBulkPoolCredFiles * bulkPoolsPerFile > genNumPools) $ + left $ ShelleyGenesisCmdTooFewPoolsForBulkCreds genNumPools numBulkPoolCredFiles bulkPoolsPerFile -- We generate the bulk files for the last pool indices, -- so that all the non-bulk pools have stable indices at beginning: - let bulkOffset = fromIntegral $ genNumPools - bulkPoolCredFiles * bulkPoolsPerFile + let bulkOffset = fromIntegral $ genNumPools - numBulkPoolCredFiles * bulkPoolsPerFile bulkIndices :: [Word] = [ 1 + bulkOffset .. genNumPools ] bulkSlices :: [[Word]] = List.chunksOf (fromIntegral bulkPoolsPerFile) bulkIndices - forM_ (zip [ 1 .. bulkPoolCredFiles ] bulkSlices) $ + forM_ (zip [ 1 .. numBulkPoolCredFiles ] bulkSlices) $ uncurry (writeBulkPoolCredentials pooldir) let (delegsPerPool, delegsRemaining) = divMod genNumStDelegs genNumPools delegsForPool poolIx = if delegsRemaining /= 0 && poolIx == genNumPools then delegsPerPool else delegsPerPool + delegsRemaining - distribution = [pool | (pool, poolIx) <- zip pools [1 ..], _ <- [1 .. delegsForPool poolIx]] + distribution = [pool | (pool, poolIx) <- zip poolParams [1 ..], _ <- [1 .. delegsForPool poolIx]] g <- Random.getStdGen @@ -718,7 +737,7 @@ runGenesisCreateStaked (GenesisDir rootdir) stuffedUtxoAddrs <- liftIO $ Lazy.replicateM (fromIntegral numStuffedUtxo) genStuffedAddress let stake = second Ledger._poolId . mkDelegationMapEntry <$> delegations - stakePools = [ (Ledger._poolId poolParams, poolParams) | poolParams <- snd . mkDelegationMapEntry <$> delegations ] + stakePools = [ (Ledger._poolId poolParams', poolParams') | poolParams' <- snd . mkDelegationMapEntry <$> delegations ] delegAddrs = dInitialUtxoAddr <$> delegations !shelleyGenesis = updateCreateStakedOutputTemplate @@ -741,13 +760,13 @@ runGenesisCreateStaked (GenesisDir rootdir) ] ++ [ mconcat [ ", " - , textShow bulkPoolCredFiles, " bulk pool credential files, " + , textShow numBulkPoolCredFiles, " bulk pool credential files, " , textShow bulkPoolsPerFile, " pools per bulk credential file, indices starting from " , textShow bulkOffset, ", " , textShow $ length bulkIndices, " total pools in bulk nodes, each bulk node having this many entries: " , textShow $ length <$> bulkSlices ] - | bulkPoolCredFiles * bulkPoolsPerFile > 0 ] + | numBulkPoolCredFiles * bulkPoolsPerFile > 0 ] where adjustTemplate t = t { sgNetworkMagic = unNetworkMagic (toNetworkMagic network) } @@ -861,19 +880,24 @@ data Delegation = Delegation } deriving (Generic, NFData) -buildPool :: NetworkId -> FilePath -> Word -> ExceptT ShelleyGenesisCmdError IO (Ledger.PoolParams StandardCrypto) -buildPool nw dir index = do - StakePoolVerificationKey poolColdVK <- firstExceptT (ShelleyGenesisCmdPoolCmdError - . ShelleyPoolCmdReadFileError) - . newExceptT - $ readFileTextEnvelope (AsVerificationKey AsStakePoolKey) poolColdVKF - VrfVerificationKey poolVrfVK <- firstExceptT (ShelleyGenesisCmdNodeCmdError - . ShelleyNodeCmdReadFileError) - . newExceptT - $ readFileTextEnvelope (AsVerificationKey AsVrfKey) poolVrfVKF - rewardsSVK <- firstExceptT ShelleyGenesisCmdTextEnvReadFileError - . newExceptT - $ readFileTextEnvelope (AsVerificationKey AsStakeKey) poolRewardVKF +buildPoolParams + :: NetworkId + -> FilePath -- ^ File directory where the necessary pool credentials were created + -> Word + -> Map Word Ledger.StakePoolRelay -- ^ User submitted stake pool relay map + -> ExceptT ShelleyGenesisCmdError IO (Ledger.PoolParams StandardCrypto) +buildPoolParams nw dir index specifiedRelays = do + StakePoolVerificationKey poolColdVK + <- firstExceptT (ShelleyGenesisCmdPoolCmdError . ShelleyPoolCmdReadFileError) + . newExceptT $ readFileTextEnvelope (AsVerificationKey AsStakePoolKey) poolColdVKF + + VrfVerificationKey poolVrfVK + <- firstExceptT (ShelleyGenesisCmdNodeCmdError . ShelleyNodeCmdReadFileError) + . newExceptT $ readFileTextEnvelope (AsVerificationKey AsVrfKey) poolVrfVKF + rewardsSVK + <- firstExceptT ShelleyGenesisCmdTextEnvReadFileError + . newExceptT $ readFileTextEnvelope (AsVerificationKey AsStakeKey) poolRewardVKF + pure Ledger.PoolParams { Ledger._poolId = Ledger.hashKey poolColdVK , Ledger._poolVrf = Ledger.hashVerKeyVRF poolVrfVK @@ -883,10 +907,18 @@ buildPool nw dir index = do , Ledger._poolRAcnt = toShelleyStakeAddr $ makeStakeAddress nw $ StakeCredentialByKey (verificationKeyHash rewardsSVK) , Ledger._poolOwners = mempty - , Ledger._poolRelays = Seq.empty + , Ledger._poolRelays = lookupPoolRelay specifiedRelays , Ledger._poolMD = Ledger.SNothing } where + lookupPoolRelay + :: Map Word Ledger.StakePoolRelay -> Seq.StrictSeq Ledger.StakePoolRelay + lookupPoolRelay m = + case Map.lookup index m of + Just spRelay -> + Seq.singleton spRelay + Nothing -> mempty + strIndex = show index poolColdVKF = dir "cold" ++ strIndex ++ ".vkey" poolVrfVKF = dir "vrf" ++ strIndex ++ ".vkey" @@ -903,12 +935,12 @@ writeBulkPoolCredentials dir bulkIx poolIxs = do readPoolCreds :: Word -> ExceptT ShelleyGenesisCmdError IO (TextEnvelope, TextEnvelope, TextEnvelope) readPoolCreds ix = do - (,,) <$> readEnvelope poolCert + (,,) <$> readEnvelope poolOpCert <*> readEnvelope poolVrfSKF <*> readEnvelope poolKesSKF where strIndex = show ix - poolCert = dir "opcert" ++ strIndex ++ ".cert" + poolOpCert = dir "opcert" ++ strIndex ++ ".cert" poolVrfSKF = dir "vrf" ++ strIndex ++ ".skey" poolKesSKF = dir "kes" ++ strIndex ++ ".skey" readEnvelope :: FilePath -> ExceptT ShelleyGenesisCmdError IO TextEnvelope