diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands.hs index ca46a50f5d..f2180dd891 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands.hs @@ -116,7 +116,7 @@ pCmds era envCli = asum $ catMaybes [ fmap AddressCmds <$> pAddressCmds (toCardanoEra era) envCli , fmap KeyCmds <$> pKeyCmds - , fmap GenesisCmds <$> pGenesisCmds envCli + , fmap GenesisCmds <$> pGenesisCmds (toCardanoEra era) envCli , fmap GovernanceCmds <$> pGovernanceCmds (toCardanoEra era) , fmap NodeCmds <$> pNodeCmds , fmap QueryCmds <$> pQueryCmds (toCardanoEra era) envCli diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Genesis.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Genesis.hs index 339f3a2ad6..bd4858cb19 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Genesis.hs @@ -29,7 +29,7 @@ data GenesisCmds era = GenesisCreate !GenesisCreateCmdArgs | GenesisCreateCardano !GenesisCreateCardanoCmdArgs | GenesisCreateStaked !GenesisCreateStakedCmdArgs - | GenesisCreateTestNetData !GenesisCreateTestNetDataCmdArgs + | GenesisCreateTestNetData !(GenesisCreateTestNetDataCmdArgs era) | GenesisKeyGenGenesis !GenesisKeyGenGenesisCmdArgs | GenesisKeyGenDelegate !GenesisKeyGenDelegateCmdArgs | GenesisKeyGenUTxO !GenesisKeyGenUTxOCmdArgs @@ -84,8 +84,9 @@ data GenesisCreateStakedCmdArgs = GenesisCreateStakedCmdArgs , mStakePoolRelaySpecFile :: !(Maybe FilePath) -- ^ Relay specification filepath } deriving Show -data GenesisCreateTestNetDataCmdArgs = GenesisCreateTestNetDataCmdArgs - { specShelley :: !(Maybe FilePath) -- ^ Path to the @genesis-shelley@ file to use. If unspecified, a default one will be used. +data GenesisCreateTestNetDataCmdArgs era = GenesisCreateTestNetDataCmdArgs + { eon :: !(CardanoEra era) + , specShelley :: !(Maybe FilePath) -- ^ Path to the @genesis-shelley@ file to use. If unspecified, a default one will be used. , specAlonzo :: !(Maybe FilePath) -- ^ Path to the @genesis-alonzo@ file to use. If unspecified, a default one will be used. , specConway :: !(Maybe FilePath) -- ^ Path to the @genesis-conway@ file to use. If unspecified, a default one will be used. , numGenesisKeys :: !Word -- ^ The number of genesis keys credentials to create and write to disk. diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Genesis.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Genesis.hs index a6e45fa67b..5ae1be60f7 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Genesis.hs @@ -23,13 +23,11 @@ import Data.Word (Word64) import Options.Applicative hiding (help, str) import qualified Options.Applicative as Opt -{- HLINT ignore "Use <$>" -} -{- HLINT ignore "Move brackets to avoid $" -} - pGenesisCmds :: () - => EnvCli + => CardanoEra era + -> EnvCli -> Maybe (Parser (GenesisCmds era)) -pGenesisCmds envCli = +pGenesisCmds era envCli = subInfoParser "genesis" ( Opt.progDesc $ mconcat @@ -90,7 +88,7 @@ pGenesisCmds envCli = ] , Just $ subParser "create-testnet-data" - $ Opt.info (pGenesisCreateTestNetData envCli) + $ Opt.info (pGenesisCreateTestNetData era envCli) $ Opt.progDesc $ mconcat [ "Create data to use for starting a testnet." @@ -209,12 +207,12 @@ pGenesisCreateStaked envCli = , Opt.completer (Opt.bashCompleter "file") ] -pGenesisCreateTestNetData :: EnvCli -> Parser (GenesisCmds era) -pGenesisCreateTestNetData envCli = - fmap GenesisCreateTestNetData $ GenesisCreateTestNetDataCmdArgs - <$> (optional $ pSpecFile "shelley") - <*> (optional $ pSpecFile "alonzo") - <*> (optional $ pSpecFile "conway") +pGenesisCreateTestNetData :: CardanoEra era -> EnvCli -> Parser (GenesisCmds era) +pGenesisCreateTestNetData era envCli = + fmap GenesisCreateTestNetData $ GenesisCreateTestNetDataCmdArgs era + <$> optional (pSpecFile "shelley") + <*> optional (pSpecFile "alonzo") + <*> optional (pSpecFile "conway") <*> pNumGenesisKeys <*> pNumPools <*> pNumStakeDelegs @@ -223,15 +221,15 @@ pGenesisCreateTestNetData envCli = <*> pNumUtxoKeys <*> pSupply <*> pSupplyDelegated - <*> (optional $ pNetworkIdForTestnetData envCli) + <*> optional (pNetworkIdForTestnetData envCli) <*> Opt.optional pRelays <*> pMaybeSystemStart <*> pOutputDir where - pSpecFile era = Opt.strOption $ mconcat - [ Opt.long $ "spec-" <> era + pSpecFile eraStr = Opt.strOption $ mconcat + [ Opt.long $ "spec-" <> eraStr , Opt.metavar "FILE" - , Opt.help $ "The " <> era <> " specification file to use as input. A default one is generated if omitted." + , Opt.help $ "The " <> eraStr <> " specification file to use as input. A default one is generated if omitted." ] pNumGenesisKeys = Opt.option Opt.auto $ mconcat [ Opt.long "genesis-keys" @@ -255,7 +253,7 @@ pGenesisCreateTestNetData envCli = pDReps :: CredentialGenerationMode -> String -> String -> Parser DRepCredentials pDReps mode modeOptionName modeExplanation = DRepCredentials mode <$> - (Opt.option Opt.auto $ mconcat + Opt.option Opt.auto (mconcat [ Opt.long modeOptionName , Opt.help $ "The number of DRep credentials to make (default is 0). " <> modeExplanation , Opt.metavar "INT", Opt.value 0 @@ -268,7 +266,7 @@ pGenesisCreateTestNetData envCli = pStakeDelegators :: CredentialGenerationMode -> String -> String -> Parser StakeDelegators pStakeDelegators mode modeOptionName modeExplanation = StakeDelegators mode <$> - (Opt.option Opt.auto $ mconcat + Opt.option Opt.auto (mconcat [ Opt.long modeOptionName , Opt.help $ "The number of stake delegator credential sets to make (default is 0). " <> modeExplanation , Opt.metavar "INT", Opt.value 0 diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs index 069a9fcd35..3be044f9bf 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs @@ -12,19 +12,16 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -{- HLINT ignore "Redundant <$>" -} -{- HLINT ignore "Use let" -} - module Cardano.CLI.EraBased.Run.CreateTestnetData ( genStuffedAddress - , getCurrentTimePlus30 - , readRelays - , readAndDecodeGenesisFile - , runGenesisKeyGenUTxOCmd - , runGenesisKeyGenGenesisCmd - , runGenesisKeyGenDelegateCmd - , runGenesisCreateTestNetDataCmd - , runGenesisKeyGenDelegateVRF + , getCurrentTimePlus30 + , readRelays + , readAndDecodeGenesisFile + , runGenesisKeyGenUTxOCmd + , runGenesisKeyGenGenesisCmd + , runGenesisKeyGenDelegateCmd + , runGenesisCreateTestNetDataCmd + , runGenesisKeyGenDelegateVRF ) where import Cardano.Api hiding (ConwayEra) @@ -36,8 +33,8 @@ import Cardano.Api.Shelley (Address (ShelleyAddress), OperationalCertificateIssueCounter (OperationalCertificateIssueCounter), ShelleyGenesis (ShelleyGenesis, sgGenDelegs, sgInitialFunds, sgMaxLovelaceSupply, sgNetworkMagic, sgProtocolParams, sgStaking, sgSystemStart), StakeCredential (StakeCredentialByKey), VerificationKey (VrfVerificationKey), - VrfKey, alonzoGenesisDefaults, conwayGenesisDefaults, shelleyGenesisDefaults, - toShelleyAddr, toShelleyNetwork, toShelleyStakeAddr) + VrfKey, alonzoGenesisDefaults, conwayGenesisDefaults, decodeAlonzoGenesis, + shelleyGenesisDefaults, toShelleyAddr, toShelleyNetwork, toShelleyStakeAddr) import Cardano.CLI.EraBased.Commands.Genesis as Cmd import qualified Cardano.CLI.EraBased.Commands.Governance.DRep as DRep @@ -176,10 +173,11 @@ runGenesisKeyGenUTxOCmd vkeyDesc = "Genesis Initial UTxO Verification Key" runGenesisCreateTestNetDataCmd - :: GenesisCreateTestNetDataCmdArgs + :: GenesisCreateTestNetDataCmdArgs era -> ExceptT GenesisCmdError IO () runGenesisCreateTestNetDataCmd Cmd.GenesisCreateTestNetDataCmdArgs - { networkId + { eon = era + , networkId , specShelley , specAlonzo , specConway @@ -195,13 +193,14 @@ runGenesisCreateTestNetDataCmd Cmd.GenesisCreateTestNetDataCmdArgs , numUtxoKeys , totalSupply , delegatedSupply - , relays + , relays , systemStart , outputDir } = do liftIO $ createDirectoryIfMissing False outputDir shelleyGenesisInit <- maybeReadAndDecodeGenesisFileSpec specShelley shelleyGenesisDefaults - alonzoGenesis <- maybeReadAndDecodeGenesisFileSpec specAlonzo alonzoGenesisDefaults + alonzoGenesis <- fromMaybe (alonzoGenesisDefaults era) <$> + traverse (readAndDecodeGenesisFileWith (runExcept . decodeAlonzoGenesis (Just era))) specAlonzo conwayGenesis <- maybeReadAndDecodeGenesisFileSpec specConway conwayGenesisDefaults -- Read NetworkId either from file or from the flag. Flag overrides template file. @@ -418,13 +417,10 @@ mkPaths numKeys dir segment filename = | idx <- [1 .. numKeys]] genStuffedAddress :: L.Network -> IO (AddressInEra ShelleyEra) -genStuffedAddress network = - shelleyAddressInEra ShelleyBasedEraShelley <$> - (ShelleyAddress - <$> pure network - <*> (L.KeyHashObj . mkKeyHash . read64BitInt - <$> Crypto.runSecureRandom (getRandomBytes 8)) - <*> pure L.StakeRefNull) +genStuffedAddress network = do + paymentCredential <- L.KeyHashObj . mkKeyHash . read64BitInt <$> Crypto.runSecureRandom (getRandomBytes 8) + pure . shelleyAddressInEra ShelleyBasedEraShelley $ + ShelleyAddress network paymentCredential L.StakeRefNull where read64BitInt :: ByteString -> Int read64BitInt = (fromIntegral :: Word64 -> Int) @@ -679,19 +675,18 @@ updateOutputTemplate unLovelace (L.Coin coin) = fromIntegral coin maybeReadAndDecodeGenesisFileSpec :: (FromJSON a) => Maybe FilePath -> a -> ExceptT GenesisCmdError IO a -maybeReadAndDecodeGenesisFileSpec spec defaultSpec = - case spec of - Just specPath -> - newExceptT $ readAndDecodeGenesisFile specPath - Nothing -> - -- No template given: a default file is created - pure defaultSpec - -readAndDecodeGenesisFile :: (FromJSON a) => FilePath -> IO (Either GenesisCmdError a) -readAndDecodeGenesisFile fpath = runExceptT $ do +maybeReadAndDecodeGenesisFileSpec mSpecFile defaultSpec = + fromMaybe defaultSpec <$> + traverse readAndDecodeGenesisFile mSpecFile + +readAndDecodeGenesisFile :: (FromJSON a) => FilePath -> ExceptT GenesisCmdError IO a +readAndDecodeGenesisFile = readAndDecodeGenesisFileWith Aeson.eitherDecode + +readAndDecodeGenesisFileWith :: (LBS.ByteString -> Either String a) -> FilePath -> ExceptT GenesisCmdError IO a +readAndDecodeGenesisFileWith decode' fpath = do lbs <- handleIOExceptT (GenesisCmdGenesisFileReadError . FileIOError fpath) $ LBS.readFile fpath firstExceptT (GenesisCmdGenesisFileDecodeError fpath . Text.pack) - . hoistEither $ Aeson.eitherDecode' lbs + . hoistEither $ decode' lbs -- @readRelays fp@ reads the relays specification from a file readRelays :: () @@ -705,7 +700,7 @@ readRelays fp = do . hoistEither $ Aeson.eitherDecode relaySpecJsonBs -- | Current UTCTime plus 30 seconds -getCurrentTimePlus30 :: ExceptT a IO UTCTime +getCurrentTimePlus30 :: MonadIO m => m UTCTime getCurrentTimePlus30 = plus30sec <$> liftIO getCurrentTime where diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis.hs index b367cd00cc..2af1581217 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis.hs @@ -6,20 +6,14 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} - -{- HLINT ignore "Replace case with maybe" -} -{- HLINT ignore "Reduce duplication" -} -{- HLINT ignore "Redundant <$>" -} -{- HLINT ignore "Use let" -} module Cardano.CLI.EraBased.Run.Genesis ( runGenesisCmds @@ -75,6 +69,7 @@ import Cardano.Slotting.Slot (EpochSize (EpochSize)) import Ouroboros.Consensus.Shelley.Node (ShelleyGenesisStaking (..)) import Control.DeepSeq (NFData, force) +import Control.Exception (evaluate) import Control.Monad (forM, forM_, unless, when) import Data.Aeson hiding (Key) import qualified Data.Aeson as Aeson @@ -85,7 +80,6 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char (isDigit) -import Data.Either (fromRight) import Data.Fixed (Fixed (MkFixed)) import Data.Function (on) import Data.Functor (void) @@ -401,15 +395,15 @@ runGenesisCreateCardanoCmd overrideShelleyGenesis t = t { sgNetworkMagic = unNetworkMagic (toNetworkMagic network) , sgNetworkId = toShelleyNetwork network - , sgActiveSlotsCoeff = fromMaybe (error $ "Could not convert from Rational: " ++ show slotCoeff) $ L.boundRational slotCoeff + , sgActiveSlotsCoeff = unsafeBoundedRational slotCoeff , sgSecurityParam = unBlockCount security , sgUpdateQuorum = fromIntegral $ ((numGenesisKeys `div` 3) * 2) + 1 , sgEpochLength = EpochSize $ floor $ (fromIntegral (unBlockCount security) * 10) / slotCoeff , sgMaxLovelaceSupply = 45_000_000_000_000_000 , sgSystemStart = getSystemStart start - , sgSlotLength = L.secondsToNominalDiffTimeMicro $ MkFixed (fromIntegral slotLength) * 1000 + , sgSlotLength = L.secondsToNominalDiffTimeMicro $ MkFixed (fromIntegral slotLength) * 1_000 } - shelleyGenesisTemplate' <- liftIO $ overrideShelleyGenesis . fromRight (error "shelley genesis template not found") <$> TN.readAndDecodeGenesisFile shelleyGenesisTemplate + shelleyGenesisTemplate' <- overrideShelleyGenesis <$> TN.readAndDecodeGenesisFile shelleyGenesisTemplate alonzoGenesis <- readAlonzoGenesis alonzoGenesisTemplate conwayGenesis <- readConwayGenesis conwayGenesisTemplate (delegateMap, vrfKeys, kesKeys, opCerts) <- liftIO $ generateShelleyNodeSecrets shelleyDelegateKeys shelleyGenesisvkeys @@ -883,13 +877,13 @@ computeInsecureDelegation g0 nw pool = do let stakeAddressReference = StakeAddressByValue . StakeCredentialByKey . verificationKeyHash $ stakeVK let initialUtxoAddr = makeShelleyAddress nw (PaymentCredentialByKey (verificationKeyHash paymentVK)) stakeAddressReference - delegation <- pure $ force Delegation - { dInitialUtxoAddr = shelleyAddressInEra ShelleyBasedEraShelley initialUtxoAddr - , dDelegStaking = L.hashKey (unStakeVerificationKey stakeVK) - , dPoolParams = pool - } + delegation = Delegation + { dInitialUtxoAddr = shelleyAddressInEra ShelleyBasedEraShelley initialUtxoAddr + , dDelegStaking = L.hashKey (unStakeVerificationKey stakeVK) + , dPoolParams = pool + } - pure (g2, delegation) + evaluate . force $ (g2, delegation) -- | Attempts to read Shelley genesis from disk -- and if not found creates a default Shelley genesis. @@ -898,7 +892,7 @@ readShelleyGenesisWithDefault -> (ShelleyGenesis L.StandardCrypto -> ShelleyGenesis L.StandardCrypto) -> ExceptT GenesisCmdError IO (ShelleyGenesis L.StandardCrypto) readShelleyGenesisWithDefault fpath adjustDefaults = do - newExceptT (TN.readAndDecodeGenesisFile fpath) + TN.readAndDecodeGenesisFile fpath `catchError` \err -> case err of GenesisCmdGenesisFileReadError (FileIOError _ ioe) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/DRep.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/DRep.hs index 743d1c8561..dd61fa9a9a 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/DRep.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/DRep.hs @@ -163,11 +163,8 @@ runGovernanceDRepMetadataHashCmd { metadataFile , mOutFile } = do - metadataBytes <- firstExceptT ReadFileError $ newExceptT (readByteStringFile metadataFile) - (_metadata, metadataHash) <- - firstExceptT GovernanceCmdDRepMetadataValidationError - . hoistEither - $ validateAndHashDRepMetadata metadataBytes + metadataBytes <- firstExceptT ReadFileError . newExceptT $ readByteStringFile metadataFile + let (_metadata, metadataHash) = hashDRepMetadata metadataBytes firstExceptT WriteFileError . newExceptT . writeByteStringOutput mOutFile diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs index cbc384bdc0..114bb6ccf9 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs @@ -173,8 +173,8 @@ runQueryProtocolParametersCmd AnyCardanoEra era <- firstExceptT QueryCmdAcquireFailure $ determineEra localNodeConnInfo sbe <- forEraInEon @ShelleyBasedEra era (left QueryCmdByronEra) pure let qInMode = QueryInEra $ QueryInShelleyBasedEra sbe Api.QueryProtocolParameters - pp <- firstExceptT QueryCmdConvenienceError - $ executeQueryAnyMode localNodeConnInfo qInMode + pp <- executeQueryAnyMode localNodeConnInfo qInMode + & modifyError QueryCmdConvenienceError writeProtocolParameters sbe mOutFile pp where writeProtocolParameters @@ -654,7 +654,8 @@ runQueryTxMempoolCmd localQuery <- case query of TxMempoolQueryTxExists tx -> do - AnyCardanoEra era <- modifyError QueryCmdAcquireFailure (determineEra localNodeConnInfo) + AnyCardanoEra era <- determineEra localNodeConnInfo + & modifyError QueryCmdAcquireFailure pure $ LocalTxMonitoringQueryTx $ TxIdInMode era tx TxMempoolQueryNextTx -> pure LocalTxMonitoringSendNextTx TxMempoolQueryInfo -> pure LocalTxMonitoringMempoolInformation @@ -1293,7 +1294,7 @@ runQueryLeadershipScheduleCmd vrkSkey <- modifyError QueryCmdTextEnvelopeReadError . hoistIOEither $ readFileTextEnvelope (AsSigningKey AsVrfKey) vrkSkeyFp - shelleyGenesis <- modifyError QueryCmdGenesisReadError . hoistIOEither $ + shelleyGenesis <- modifyError QueryCmdGenesisReadError $ readAndDecodeGenesisFile @(ShelleyGenesis StandardCrypto) genFile join $ lift diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCmdError.hs index 6fa63a24ce..f12e984b4a 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCmdError.hs @@ -50,7 +50,6 @@ data GovernanceCmdError | GovernanceCmdDecoderError !DecoderError | GovernanceCmdVerifyPollError !GovernancePollError | GovernanceCmdWriteFileError !(FileError ()) - | GovernanceCmdDRepMetadataValidationError !DRepMetadataValidationError -- Legacy - remove me after cardano-cli transitions to new era based structure | GovernanceCmdMIRCertNotSupportedInConway | GovernanceCmdGenesisDelegationNotSupportedInConway @@ -108,8 +107,6 @@ instance Error GovernanceCmdError where pretty $ renderGovernancePollError pollError GovernanceCmdWriteFileError fileError -> "Cannot write file: " <> prettyError fileError - GovernanceCmdDRepMetadataValidationError e -> - "DRep metadata validation error: " <> prettyError e GovernanceCmdMIRCertNotSupportedInConway -> "MIR certificates are not supported in Conway era onwards." GovernanceCmdGenesisDelegationNotSupportedInConway ->