From abba8cb585c06373ea47b95ed84c0c04a6722398 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 17 Nov 2023 20:43:12 +1100 Subject: [PATCH 1/8] Upgrade to cardano-api-8.32.0.0 --- cabal.project | 6 + cardano-cli/app/cardano-cli.hs | 4 +- .../src/Cardano/CLI/Byron/Delegation.hs | 18 +- cardano-cli/src/Cardano/CLI/Byron/Genesis.hs | 50 +-- cardano-cli/src/Cardano/CLI/Byron/Key.hs | 32 +- cardano-cli/src/Cardano/CLI/Byron/Parsers.hs | 3 +- cardano-cli/src/Cardano/CLI/Byron/Run.hs | 21 +- cardano-cli/src/Cardano/CLI/Byron/Tx.hs | 21 +- .../src/Cardano/CLI/Byron/UpdateProposal.hs | 33 +- cardano-cli/src/Cardano/CLI/Byron/Vote.hs | 33 +- .../Cardano/CLI/EraBased/Options/Common.hs | 49 +-- .../src/Cardano/CLI/EraBased/Run/Query.hs | 370 +++++++++--------- cardano-cli/src/Cardano/CLI/Helpers.hs | 23 +- cardano-cli/src/Cardano/CLI/Pretty.hs | 58 +-- cardano-cli/src/Cardano/CLI/Read.hs | 169 ++++---- cardano-cli/src/Cardano/CLI/Run.hs | 3 +- cardano-cli/src/Cardano/CLI/Run/Ping.hs | 9 +- .../CLI/Types/Errors/AddressCmdError.hs | 32 +- .../CLI/Types/Errors/AddressInfoError.hs | 8 +- .../CLI/Types/Errors/BootstrapWitnessError.hs | 4 +- ...CardanoAddressSigningKeyConversionError.hs | 16 +- .../src/Cardano/CLI/Types/Errors/CmdError.hs | 34 +- .../CLI/Types/Errors/DelegationError.hs | 10 +- .../CLI/Types/Errors/GenesisCmdError.hs | 100 ++--- .../Types/Errors/GovernanceActionsError.hs | 15 +- .../CLI/Types/Errors/GovernanceCmdError.hs | 53 +-- .../Types/Errors/GovernanceCommitteeError.hs | 12 +- .../CLI/Types/Errors/GovernanceHashError.hs | 4 +- .../CLI/Types/Errors/GovernanceQueryError.hs | 24 +- .../Types/Errors/GovernanceVoteCmdError.hs | 14 +- .../CLI/Types/Errors/ItnKeyConversionError.hs | 31 +- .../Cardano/CLI/Types/Errors/KeyCmdError.hs | 33 +- .../Cardano/CLI/Types/Errors/NodeCmdError.hs | 29 +- .../CLI/Types/Errors/ProtocolParamsError.hs | 14 +- .../Cardano/CLI/Types/Errors/QueryCmdError.hs | 65 +-- .../Errors/QueryCmdLocalStateQueryError.hs | 15 +- .../CLI/Types/Errors/RegistrationError.hs | 10 +- .../CLI/Types/Errors/ScriptDecodeError.hs | 6 +- .../CLI/Types/Errors/StakeAddressCmdError.hs | 16 +- .../Errors/StakeAddressDelegationError.hs | 5 +- .../Errors/StakeAddressRegistrationError.hs | 2 +- .../CLI/Types/Errors/StakeCredentialError.hs | 8 +- .../CLI/Types/Errors/StakePoolCmdError.hs | 13 +- .../CLI/Types/Errors/TextViewFileError.hs | 16 +- .../Cardano/CLI/Types/Errors/TxCmdError.hs | 240 ++++++------ .../CLI/Types/Errors/TxValidationError.hs | 65 +-- cardano-cli/src/Cardano/CLI/Types/Key.hs | 7 +- cardano-cli/src/Cardano/CLI/Types/Output.hs | 28 +- .../Test/Golden/Byron/Tx.hs | 4 +- .../Test/Golden/Byron/UpdateProposal.hs | 7 +- .../Test/Golden/Byron/Vote.hs | 11 +- .../Golden/EraBased/Governance/VerifyPoll.hs | 5 +- .../Test/Cardano/CLI/Util.hs | 29 +- 53 files changed, 968 insertions(+), 919 deletions(-) diff --git a/cabal.project b/cabal.project index 5c176c9171..5005577255 100644 --- a/cabal.project +++ b/cabal.project @@ -43,3 +43,9 @@ write-ghc-environment-files: always -- IMPORTANT -- Do NOT add more source-repository-package stanzas here unless they are strictly -- temporary! Please read the section in CONTRIBUTING about updating dependencies. + +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-api + tag: b406ef1e24a3da86b53a2f51384d47672ff7ab18 + subdir: cardano-api diff --git a/cardano-cli/app/cardano-cli.hs b/cardano-cli/app/cardano-cli.hs index 9e7bd11a7c..b43ed34cce 100644 --- a/cardano-cli/app/cardano-cli.hs +++ b/cardano-cli/app/cardano-cli.hs @@ -5,6 +5,8 @@ #define UNIX #endif +import Cardano.CLI.Pretty + import Cardano.CLI.Environment (getEnvCli) import Cardano.CLI.Options (opts, pref) import Cardano.CLI.Run (renderClientCommandError, runClientCommand) @@ -31,4 +33,4 @@ main = toplevelExceptionHandler $ do #endif co <- Opt.customExecParser pref (opts envCli) - orDie renderClientCommandError $ runClientCommand co + orDie (prettyToText . renderClientCommandError) $ runClientCommand co diff --git a/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs b/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs index ea46815936..44577e42ae 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -13,6 +14,7 @@ module Cardano.CLI.Byron.Delegation where import Cardano.Api.Byron +import Cardano.Api.Pretty import qualified Cardano.Chain.Delegation as Dlg import Cardano.Chain.Slotting (EpochNumber) @@ -41,14 +43,14 @@ data ByronDelegationError | ByronDelegationKeyError !ByronKeyFailure deriving Show -renderByronDelegationError :: ByronDelegationError -> Text -renderByronDelegationError err = - case err of - CertificateValidationErrors certFp errs -> - "Certificate validation error(s) at: " <> textShow certFp <> " Errors: " <> textShow errs - DlgCertificateDeserialisationFailed certFp deSererr -> - "Certificate deserialisation error at: " <> textShow certFp <> " Error: " <> textShow deSererr - ByronDelegationKeyError kerr -> renderByronKeyFailure kerr +renderByronDelegationError :: ByronDelegationError -> Doc ann +renderByronDelegationError = \case + CertificateValidationErrors certFp errs -> + "Certificate validation error(s) at: " <> pshow certFp <> " Errors: " <> pshow errs + DlgCertificateDeserialisationFailed certFp deSererr -> + "Certificate deserialisation error at: " <> pshow certFp <> " Error: " <> pshow deSererr + ByronDelegationKeyError kerr -> + renderByronKeyFailure kerr -- TODO: we need to support password-protected secrets. -- | Issue a certificate for genesis delegation to a delegate key, signed by the diff --git a/cardano-cli/src/Cardano/CLI/Byron/Genesis.hs b/cardano-cli/src/Cardano/CLI/Byron/Genesis.hs index 115fb255f8..8ef60131b6 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Genesis.hs @@ -1,5 +1,5 @@ {-# LANGUAGE GeneralisedNewtypeDeriving #-} - +{-# LANGUAGE LambdaCase #-} module Cardano.CLI.Byron.Genesis ( ByronGenesisError(..) @@ -12,9 +12,10 @@ module Cardano.CLI.Byron.Genesis ) where -import Cardano.Api (Key (..), NetworkId, textShow, writeSecrets) +import Cardano.Api (Key (..), NetworkId, writeSecrets) import Cardano.Api.Byron (ByronKey, SerialiseAsRawBytes (..), SigningKey (..), toByronRequiresNetworkMagic) +import Cardano.Api.Pretty import qualified Cardano.Chain.Common as Common import Cardano.Chain.Delegation hiding (Map, epoch) @@ -59,29 +60,28 @@ data ByronGenesisError deriving Show -renderByronGenesisError :: ByronGenesisError -> Text -renderByronGenesisError err = - case err of - ProtocolParametersParseFailed pParamFp parseError -> - "Protocol parameters parse failed at: " <> textShow pParamFp <> " Error: " <> parseError - ByronDelegationCertSerializationError bDelegSerErr -> - "Error while serializing the delegation certificate: " <> textShow bDelegSerErr - ByronDelegationKeySerializationError bKeySerErr -> - "Error while serializing the delegation key: " <> textShow bKeySerErr - PoorKeyFailure bKeyFailure -> - "Error creating poor keys: " <> textShow bKeyFailure - MakeGenesisDelegationError genDelegError -> - "Error creating genesis delegation: " <> textShow genDelegError - GenesisGenerationError genDataGenError -> - "Error generating genesis: " <> textShow genDataGenError - GenesisOutputDirAlreadyExists genOutDir -> - "Genesis output directory already exists: " <> textShow genOutDir - GenesisReadError genFp genDataError -> - "Error while reading genesis file at: " <> textShow genFp <> " Error: " <> textShow genDataError - GenesisSpecError genSpecError -> - "Error while creating genesis spec" <> textShow genSpecError - NoGenesisDelegationForKey verKey -> - "Error while creating genesis, no delegation certificate for this verification key:" <> textShow verKey +renderByronGenesisError :: ByronGenesisError -> Doc ann +renderByronGenesisError = \case + ProtocolParametersParseFailed pParamFp parseError -> + "Protocol parameters parse failed at: " <> pshow pParamFp <> " Error: " <> pretty parseError + ByronDelegationCertSerializationError bDelegSerErr -> + "Error while serializing the delegation certificate: " <> pshow bDelegSerErr + ByronDelegationKeySerializationError bKeySerErr -> + "Error while serializing the delegation key: " <> pshow bKeySerErr + PoorKeyFailure bKeyFailure -> + "Error creating poor keys: " <> pshow bKeyFailure + MakeGenesisDelegationError genDelegError -> + "Error creating genesis delegation: " <> pshow genDelegError + GenesisGenerationError genDataGenError -> + "Error generating genesis: " <> pshow genDataGenError + GenesisOutputDirAlreadyExists genOutDir -> + "Genesis output directory already exists: " <> pshow genOutDir + GenesisReadError genFp genDataError -> + "Error while reading genesis file at: " <> pshow genFp <> " Error: " <> pshow genDataError + GenesisSpecError genSpecError -> + "Error while creating genesis spec" <> pshow genSpecError + NoGenesisDelegationForKey verKey -> + "Error while creating genesis, no delegation certificate for this verification key:" <> pshow verKey newtype NewDirectory = NewDirectory FilePath diff --git a/cardano-cli/src/Cardano/CLI/Byron/Key.hs b/cardano-cli/src/Cardano/CLI/Byron/Key.hs index 13eb57d499..6bf0df5b7b 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Key.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Key.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} module Cardano.CLI.Byron.Key ( -- * Keys @@ -16,6 +17,7 @@ module Cardano.CLI.Byron.Key where import Cardano.Api.Byron +import Cardano.Api.Pretty import qualified Cardano.Chain.Common as Common import Cardano.CLI.Types.Common @@ -32,7 +34,6 @@ import Data.Text (Text) import qualified Data.Text as T import Formatting (build, sformat, (%)) - data ByronKeyFailure = ReadSigningKeyFailure !FilePath !Text | ReadVerificationKeyFailure !FilePath !Text @@ -42,21 +43,20 @@ data ByronKeyFailure | CannotMigrateFromNonLegacySigningKey !FilePath deriving Show -renderByronKeyFailure :: ByronKeyFailure -> Text -renderByronKeyFailure err = - case err of - CannotMigrateFromNonLegacySigningKey fp -> - "Migrate from non-legacy Byron key unnecessary: " <> textShow fp - ReadSigningKeyFailure sKeyFp readErr -> - "Error reading signing key at: " <> textShow sKeyFp <> " Error: " <> textShow readErr - ReadVerificationKeyFailure vKeyFp readErr -> - "Error reading verification key at: " <> textShow vKeyFp <> " Error: " <> textShow readErr - LegacySigningKeyDeserialisationFailed fp -> - "Error attempting to deserialise a legacy signing key at: " <> textShow fp - SigningKeyDeserialisationFailed sKeyFp -> - "Error deserialising signing key at: " <> textShow sKeyFp - VerificationKeyDeserialisationFailed vKeyFp deSerError -> - "Error deserialising verification key at: " <> textShow vKeyFp <> " Error: " <> textShow deSerError +renderByronKeyFailure :: ByronKeyFailure -> Doc ann +renderByronKeyFailure = \case + CannotMigrateFromNonLegacySigningKey fp -> + "Migrate from non-legacy Byron key unnecessary: " <> pshow fp + ReadSigningKeyFailure sKeyFp readErr -> + "Error reading signing key at: " <> pshow sKeyFp <> " Error: " <> pshow readErr + ReadVerificationKeyFailure vKeyFp readErr -> + "Error reading verification key at: " <> pshow vKeyFp <> " Error: " <> pshow readErr + LegacySigningKeyDeserialisationFailed fp -> + "Error attempting to deserialise a legacy signing key at: " <> pshow fp + SigningKeyDeserialisationFailed sKeyFp -> + "Error deserialising signing key at: " <> pshow sKeyFp + VerificationKeyDeserialisationFailed vKeyFp deSerError -> + "Error deserialising verification key at: " <> pshow vKeyFp <> " Error: " <> pshow deSerError newtype NewSigningKeyFile = NewSigningKeyFile FilePath diff --git a/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs b/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs index ff6b1250f1..23f09134a2 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs @@ -27,6 +27,7 @@ module Cardano.CLI.Byron.Parsers import Cardano.Api hiding (GenesisParameters, UpdateProposal) import Cardano.Api.Byron (Address (..), ByronProtocolParametersUpdate (..), toByronLovelace) +import Cardano.Api.Pretty import Cardano.Api.Shelley (ReferenceScript (ReferenceScriptNone)) import Cardano.Chain.Common (BlockCount (..), TxFeePolicy (..), TxSizeLinear (..), @@ -265,7 +266,7 @@ parseTxIdAtto = ( "Transaction ID (hexadecimal)") $ do bstr <- Atto.takeWhile1 Char.isHexDigit case deserialiseFromRawBytesHex AsTxId bstr of Right addr -> return addr - Left e -> fail $ "Incorrect transaction id format: " ++ displayError e + Left e -> fail $ prettyToString $ "Incorrect transaction id format: " <> prettyError e parseTxIxAtto :: Atto.Parser TxIx parseTxIxAtto = toEnum <$> Atto.decimal diff --git a/cardano-cli/src/Cardano/CLI/Byron/Run.hs b/cardano-cli/src/Cardano/CLI/Byron/Run.hs index 3437ff00a3..a08642917c 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Run.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Run.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} module Cardano.CLI.Byron.Run ( ByronClientCmdError @@ -33,6 +34,7 @@ import qualified Data.Text.IO as Text import qualified Data.Text.Lazy.Builder as Builder import qualified Data.Text.Lazy.IO as TL import qualified Formatting as F +import Prettyprinter -- | Data type that encompasses all the possible errors of the -- Byron client. @@ -46,16 +48,15 @@ data ByronClientCmdError | ByronCmdVoteError !ByronVoteError deriving Show -renderByronClientCmdError :: ByronClientCmdError -> Text -renderByronClientCmdError err = - case err of - ByronCmdDelegationError e -> renderByronDelegationError e - ByronCmdGenesisError e -> renderByronGenesisError e - ByronCmdHelpersError e -> renderHelpersError e - ByronCmdKeyFailure e -> renderByronKeyFailure e - ByronCmdTxError e -> renderByronTxError e - ByronCmdUpdateProposalError e -> renderByronUpdateProposalError e - ByronCmdVoteError e -> renderByronVoteError e +renderByronClientCmdError :: ByronClientCmdError -> Doc ann +renderByronClientCmdError = \case + ByronCmdDelegationError e -> renderByronDelegationError e + ByronCmdGenesisError e -> renderByronGenesisError e + ByronCmdHelpersError e -> renderHelpersError e + ByronCmdKeyFailure e -> renderByronKeyFailure e + ByronCmdTxError e -> renderByronTxError e + ByronCmdUpdateProposalError e -> renderByronUpdateProposalError e + ByronCmdVoteError e -> renderByronVoteError e runByronClientCommand :: ByronCommand -> ExceptT ByronClientCmdError IO () runByronClientCommand c = diff --git a/cardano-cli/src/Cardano/CLI/Byron/Tx.hs b/cardano-cli/src/Cardano/CLI/Byron/Tx.hs index a70be26fdf..9ca0d274b2 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Tx.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Tx.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} module Cardano.CLI.Byron.Tx @@ -26,6 +27,7 @@ where import Cardano.Api import Cardano.Api.Byron +import Cardano.Api.Pretty import qualified Cardano.Binary as Binary import qualified Cardano.Chain.Common as Common @@ -63,16 +65,15 @@ data ByronTxError | ByronTxSubmitErrorEraMismatch !EraMismatch deriving Show -renderByronTxError :: ByronTxError -> Text -renderByronTxError err = - case err of - ByronTxSubmitError res -> "Error while submitting tx: " <> res - ByronTxSubmitErrorEraMismatch EraMismatch{ledgerEraName, otherEraName} -> - "The era of the node and the tx do not match. " <> - "The node is running in the " <> ledgerEraName <> - " era, but the transaction is for the " <> otherEraName <> " era." - TxDeserialisationFailed txFp decErr -> - "Transaction deserialisation failed at " <> textShow txFp <> " Error: " <> textShow decErr +renderByronTxError :: ByronTxError -> Doc ann +renderByronTxError = \case + ByronTxSubmitError res -> "Error while submitting tx: " <> pretty res + ByronTxSubmitErrorEraMismatch EraMismatch{ledgerEraName, otherEraName} -> + "The era of the node and the tx do not match. " <> + "The node is running in the " <> pretty ledgerEraName <> + " era, but the transaction is for the " <> pretty otherEraName <> " era." + TxDeserialisationFailed txFp decErr -> + "Transaction deserialisation failed at " <> pshow txFp <> " Error: " <> pshow decErr newtype NewTxFile = NewTxFile FilePath diff --git a/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs b/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs index 12addf70c0..c96450721e 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} module Cardano.CLI.Byron.UpdateProposal ( ByronUpdateProposalError(..) @@ -9,9 +10,10 @@ module Cardano.CLI.Byron.UpdateProposal , submitByronUpdateProposal ) where -import Cardano.Api (NetworkId, SerialiseAsRawBytes (..), SocketPath, textShow) +import Cardano.Api (NetworkId, SerialiseAsRawBytes (..), SocketPath) import Cardano.Api.Byron (AsType (AsByronUpdateProposal), ByronProtocolParametersUpdate, ByronUpdateProposal, makeByronUpdateProposal, toByronLedgerUpdateProposal) +import Cardano.Api.Pretty import Cardano.Chain.Update (InstallerHash (..), ProtocolVersion (..), SoftwareVersion (..), SystemTag (..)) @@ -41,21 +43,20 @@ data ByronUpdateProposalError | UpdateProposalDecodingError !FilePath deriving Show -renderByronUpdateProposalError :: ByronUpdateProposalError -> Text -renderByronUpdateProposalError err = - case err of - ByronReadUpdateProposalFileFailure fp rErr -> - "Error reading update proposal at " <> textShow fp <> " Error: " <> textShow rErr - ByronUpdateProposalWriteError hErr -> - "Error writing update proposal: " <> renderHelpersError hErr - ByronUpdateProposalGenesisReadError fp rErr -> - "Error reading update proposal at: " <> textShow fp <> " Error: " <> textShow rErr - ByronUpdateProposalTxError txErr -> - "Error submitting update proposal: " <> textShow txErr - ReadSigningKeyFailure fp rErr -> - "Error reading signing key at: " <> textShow fp <> " Error: " <> textShow rErr - UpdateProposalDecodingError fp -> - "Error decoding update proposal at: " <> textShow fp +renderByronUpdateProposalError :: ByronUpdateProposalError -> Doc ann +renderByronUpdateProposalError = \case + ByronReadUpdateProposalFileFailure fp rErr -> + "Error reading update proposal at " <> pshow fp <> " Error: " <> pshow rErr + ByronUpdateProposalWriteError hErr -> + "Error writing update proposal: " <> renderHelpersError hErr + ByronUpdateProposalGenesisReadError fp rErr -> + "Error reading update proposal at: " <> pshow fp <> " Error: " <> pshow rErr + ByronUpdateProposalTxError txErr -> + "Error submitting update proposal: " <> pshow txErr + ReadSigningKeyFailure fp rErr -> + "Error reading signing key at: " <> pshow fp <> " Error: " <> pshow rErr + UpdateProposalDecodingError fp -> + "Error decoding update proposal at: " <> pshow fp runProposalCreation :: NetworkId diff --git a/cardano-cli/src/Cardano/CLI/Byron/Vote.hs b/cardano-cli/src/Cardano/CLI/Byron/Vote.hs index 5878e062e0..17d56e1683 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Vote.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Vote.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} module Cardano.CLI.Byron.Vote ( ByronVoteError(..) @@ -10,6 +11,7 @@ module Cardano.CLI.Byron.Vote ) where import Cardano.Api.Byron +import Cardano.Api.Pretty import qualified Cardano.Binary as Binary import Cardano.CLI.Byron.Genesis (ByronGenesisError) @@ -29,8 +31,6 @@ import Control.Tracer (stdoutTracer, traceWith) import Data.Bifunctor (first) import qualified Data.ByteString as BS import Data.Text (Text) -import qualified Data.Text as Text - data ByronVoteError = ByronVoteDecodingError !FilePath @@ -43,17 +43,24 @@ data ByronVoteError | ByronVoteUpdateHelperError !HelpersError deriving Show -renderByronVoteError :: ByronVoteError -> Text -renderByronVoteError bVerr = - case bVerr of - ByronVoteDecodingError fp -> "Error decoding Byron vote at " <> Text.pack fp - ByronVoteGenesisReadError genErr -> "Error reading the genesis file:" <> Text.pack (show genErr) - ByronVoteReadFileFailure fp err -> "Error reading Byron vote at " <> Text.pack fp <> " Error: " <> err - ByronVoteTxSubmissionError txErr -> "Error submitting the transaction: " <> Text.pack (show txErr) - ByronVoteUpdateProposalDecodingError err -> "Error decoding Byron update proposal: " <> Text.pack (show err) - ByronVoteUpdateProposalFailure err -> "Error reading the update proposal: " <> Text.pack (show err) - ByronVoteUpdateHelperError err ->"Error creating the vote: " <> Text.pack (show err) - ByronVoteKeyReadFailure err -> "Error reading the signing key: " <> Text.pack (show err) +renderByronVoteError :: ByronVoteError -> Doc ann +renderByronVoteError = \case + ByronVoteDecodingError fp -> + "Error decoding Byron vote at " <> pretty fp + ByronVoteGenesisReadError genErr -> + "Error reading the genesis file:" <> pshow genErr + ByronVoteReadFileFailure fp err -> + "Error reading Byron vote at " <> pretty fp <> " Error: " <> pretty err + ByronVoteTxSubmissionError txErr -> + "Error submitting the transaction: " <> pshow txErr + ByronVoteUpdateProposalDecodingError err -> + "Error decoding Byron update proposal: " <> pshow err + ByronVoteUpdateProposalFailure err -> + "Error reading the update proposal: " <> pshow err + ByronVoteUpdateHelperError err -> + "Error creating the vote: " <> pshow err + ByronVoteKeyReadFailure err -> + "Error reading the signing key: " <> pshow err runVoteCreation diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs index 55de5b44d0..9d9a881ca3 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs @@ -13,6 +13,7 @@ module Cardano.CLI.EraBased.Options.Common where import Cardano.Api import qualified Cardano.Api.Ledger as Ledger +import Cardano.Api.Pretty import Cardano.Api.Shelley import Cardano.CLI.Environment (EnvCli (..), envCliAnyShelleyBasedEra, @@ -177,7 +178,7 @@ parseTxId = do str' <- some Parsec.hexDigit "transaction id (hexadecimal)" case deserialiseFromRawBytesHex AsTxId (BSC.pack str') of Right addr -> return addr - Left e -> fail $ "Incorrect transaction id format: " ++ displayError e + Left e -> fail $ prettyToString $ "Incorrect transaction id format: " <> prettyError e parseTxIx :: Parsec.Parser TxIx parseTxIx = TxIx . fromIntegral <$> decimal @@ -259,7 +260,7 @@ readVerificationKey asType = :: String -> Either String (VerificationKey keyrole) deserialiseFromBech32OrHex str' = - first (Text.unpack . renderInputDecodeError) $ + first (prettyToString . renderInputDecodeError) $ deserialiseInput (AsVerificationKey asType) keyFormats (BSC.pack str') -- | The first argument is the optional prefix. @@ -497,14 +498,14 @@ pHexHash :: SerialiseAsRawBytes (Hash a) => AsType a -> ReadM (Hash a) pHexHash a = Opt.eitherReader $ - first displayError + first (prettyToString . prettyError) . deserialiseFromRawBytesHex (AsHash a) . BSC.pack pBech32KeyHash :: SerialiseAsBech32 (Hash a) => AsType a -> ReadM (Hash a) pBech32KeyHash a = Opt.eitherReader $ - first displayError + first (prettyToString . prettyError) . deserialiseFromBech32 (AsHash a) . Text.pack @@ -521,7 +522,7 @@ pGenesisDelegateVerificationKey = -> Either String (VerificationKey GenesisDelegateKey) deserialiseFromHex = first - (\e -> "Invalid genesis delegate verification key: " ++ displayError e) + (\e -> prettyToString $ "Invalid genesis delegate verification key: " <> prettyError e) . deserialiseFromRawBytesHex (AsVerificationKey AsGenesisDelegateKey) . BSC.pack @@ -618,7 +619,7 @@ pAddCommitteeColdVerificationKeyHash = where deserialiseFromHex :: String -> Either String (Hash CommitteeColdKey) deserialiseFromHex = - first (\e -> "Invalid Consitutional Committee cold key hash: " ++ displayError e) + first (\e -> prettyToString $ "Invalid Consitutional Committee cold key hash: " <> prettyError e) . deserialiseFromRawBytesHex (AsHash AsCommitteeColdKey) . BSC.pack @@ -639,7 +640,7 @@ pAddCommitteeColdVerificationKey = where deserialiseFromHex :: String -> Either String (VerificationKey CommitteeColdKey) deserialiseFromHex = - first (\e -> "Invalid Constitutional Committee cold key: " ++ displayError e) + first (\e -> prettyToString $ "Invalid Constitutional Committee cold key: " <> prettyError e) . deserialiseFromRawBytesHex (AsVerificationKey AsCommitteeColdKey) . BSC.pack @@ -670,7 +671,7 @@ pRemoveCommitteeColdVerificationKeyHash = where deserialiseFromHex :: String -> Either String (Hash CommitteeColdKey) deserialiseFromHex = - first (\e -> "Invalid Consitutional Committee cold key hash: " ++ displayError e) + first (\e -> prettyToString $ "Invalid Consitutional Committee cold key hash: " <> prettyError e) . deserialiseFromRawBytesHex (AsHash AsCommitteeColdKey) . BSC.pack @@ -691,7 +692,7 @@ pRemoveCommitteeColdVerificationKey = where deserialiseFromHex :: String -> Either String (VerificationKey CommitteeColdKey) deserialiseFromHex = - first (\e -> "Invalid Constitutional Committee cold key: " ++ displayError e) + first (\e -> prettyToString $ "Invalid Constitutional Committee cold key: " <> prettyError e) . deserialiseFromRawBytesHex (AsVerificationKey AsCommitteeColdKey) . BSC.pack @@ -730,7 +731,7 @@ pCommitteeColdVerificationKey = where deserialiseFromHex :: String -> Either String (VerificationKey CommitteeColdKey) deserialiseFromHex = - first (\e -> "Invalid Constitutional Committee cold key: " ++ displayError e) + first (\e -> prettyToString $ "Invalid Constitutional Committee cold key: " <> prettyError e) . deserialiseFromRawBytesHex (AsVerificationKey AsCommitteeColdKey) . BSC.pack @@ -744,7 +745,7 @@ pCommitteeColdVerificationKeyHash = where deserialiseFromHex :: String -> Either String (Hash CommitteeColdKey) deserialiseFromHex = - first (\e -> "Invalid Consitutional Committee cold key hash: " ++ displayError e) + first (\e -> prettyToString $ "Invalid Consitutional Committee cold key hash: " <> prettyError e) . deserialiseFromRawBytesHex (AsHash AsCommitteeColdKey) . BSC.pack @@ -808,7 +809,7 @@ pCommitteeHotVerificationKey = deserialiseHotCCKeyFromHex :: String -> Either String (VerificationKey CommitteeHotKey) deserialiseHotCCKeyFromHex = - first (\e -> "Invalid Constitutional Committee hot key: " ++ displayError e) + first (\e -> prettyToString $ "Invalid Constitutional Committee hot key: " <> prettyError e) . deserialiseFromRawBytesHex (AsVerificationKey AsCommitteeHotKey) . BSC.pack @@ -841,7 +842,7 @@ pCommitteeHotKeyHash prefix = where deserialiseFromHex :: String -> Either String (Hash CommitteeHotKey) deserialiseFromHex = - first (\e -> "Invalid Consitutional Committee hot key hash: " ++ displayError e) + first (\e -> prettyToString $ "Invalid Consitutional Committee hot key hash: " <> prettyError e) . deserialiseFromRawBytesHex (AsHash AsCommitteeHotKey) . BSC.pack @@ -1171,7 +1172,7 @@ pScriptDataOrFile dataFlagPrefix helpTextForValue helpTextForFile = Left e -> fail $ "readerScriptData: " <> e Right sDataValue -> case scriptDataJsonToHashable ScriptDataJsonNoSchema sDataValue of - Left err -> fail (displayError err) + Left err -> fail $ prettyToString $ prettyError err Right sd -> return sd -------------------------------------------------------------------------------- @@ -1654,7 +1655,7 @@ pGenesisVerificationKeyHash = where deserialiseFromHex :: String -> Either String (Hash GenesisKey) deserialiseFromHex = - first (\e -> "Invalid genesis verification key hash: " ++ displayError e) + first (\e -> prettyToString $ "Invalid genesis verification key hash: " <> prettyError e) . deserialiseFromRawBytesHex (AsHash AsGenesisKey) . BSC.pack @@ -1668,7 +1669,7 @@ pGenesisVerificationKey = where deserialiseFromHex :: String -> Either String (VerificationKey GenesisKey) deserialiseFromHex = - first (\e -> "Invalid genesis verification key: " ++ displayError e) + first (\e -> prettyToString $ "Invalid genesis verification key: " <> prettyError e) . deserialiseFromRawBytesHex (AsVerificationKey AsGenesisKey) . BSC.pack @@ -1707,7 +1708,7 @@ pGenesisDelegateVerificationKeyHash = deserialiseFromHex = first (\e -> - "Invalid genesis delegate verification key hash: " ++ displayError e) + prettyToString $ "Invalid genesis delegate verification key hash: " <> prettyError e) . deserialiseFromRawBytesHex (AsHash AsGenesisDelegateKey) . BSC.pack @@ -1751,15 +1752,15 @@ pKesVerificationKey = Right res -> Right res -- The input was valid Bech32, but some other error occurred. - Left err@(Bech32UnexpectedPrefix _ _) -> Left (displayError err) - Left err@(Bech32DataPartToBytesError _) -> Left (displayError err) - Left err@(Bech32DeserialiseFromBytesError _) -> Left (displayError err) - Left err@(Bech32WrongPrefix _ _) -> Left (displayError err) + Left err@(Bech32UnexpectedPrefix _ _) -> Left (prettyToString $ prettyError err) + Left err@(Bech32DataPartToBytesError _) -> Left (prettyToString $ prettyError err) + Left err@(Bech32DeserialiseFromBytesError _) -> Left (prettyToString $ prettyError err) + Left err@(Bech32WrongPrefix _ _) -> Left (prettyToString $ prettyError err) -- The input was not valid Bech32. Attempt to deserialise it as hex. Left (Bech32DecodingError _) -> first - (\e -> "Invalid stake pool verification key: " ++ displayError e) $ + (\e -> prettyToString $ "Invalid stake pool verification key: " <> prettyError e) $ deserialiseFromRawBytesHex asType (BSC.pack str) pKesVerificationKeyFile :: Parser (VerificationKeyFile In) @@ -2314,7 +2315,7 @@ pVrfVerificationKeyHash = where deserialiseFromHex :: String -> Either String (Hash VrfKey) deserialiseFromHex = - first (\e -> "Invalid VRF verification key hash: " ++ displayError e) + first (\e -> prettyToString $ "Invalid VRF verification key hash: " <> prettyError e) . deserialiseFromRawBytesHex (AsHash AsVrfKey) . BSC.pack @@ -2531,7 +2532,7 @@ pStakePoolMetadataHash = where metadataHash :: String -> Either String (Hash StakePoolMetadata) metadataHash = - first displayError + first (prettyToString . prettyError) . deserialiseFromRawBytesHex (AsHash AsStakePoolMetadata) . BSC.pack diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs index 04476164d3..8be97115a0 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs @@ -41,12 +41,12 @@ import Cardano.Api hiding (QueryInShelleyBasedEra (..)) import qualified Cardano.Api as Api import Cardano.Api.Byron hiding (QueryInShelleyBasedEra (..)) import qualified Cardano.Api.Ledger as Ledger +import Cardano.Api.Pretty import Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..)) import qualified Cardano.CLI.EraBased.Commands.Query as Cmd import Cardano.CLI.EraBased.Run.Genesis (readAndDecodeShelleyGenesis) import Cardano.CLI.Helpers -import Cardano.CLI.Pretty import Cardano.CLI.Read import Cardano.CLI.Types.Common import Cardano.CLI.Types.Errors.QueryCmdError @@ -98,10 +98,12 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.IO as T import qualified Data.Text.IO as Text +import qualified Data.Text.Lazy.IO as LT import Data.Time.Clock import Lens.Micro ((^.)) import Numeric (showEFloat) import Prettyprinter +import Prettyprinter.Render.Terminal (AnsiStyle) import qualified System.IO as IO import Text.Printf (printf) @@ -259,7 +261,7 @@ runQueryTipCmd } mLocalState <- hushM (first QueryCmdAcquireFailure eLocalState) $ \e -> - liftIO . T.hPutStrLn IO.stderr $ "Warning: Local state unavailable: " <> renderQueryCmdError e + liftIO . LT.hPutStrLn IO.stderr $ prettyToLazyText $ "Warning: Local state unavailable: " <> renderQueryCmdError e chainTip <- pure (mLocalState >>= O.mChainTip) -- The chain tip is unavailable via local state query because we are connecting with an older @@ -275,7 +277,7 @@ runQueryTipCmd localStateOutput <- forM mLocalState $ \localState -> do case slotToEpoch tipSlotNo (O.eraHistory localState) of Left e -> do - liftIO . T.hPutStrLn IO.stderr $ + liftIO . LT.hPutStrLn IO.stderr $ prettyToLazyText $ "Warning: Epoch unavailable: " <> renderQueryCmdError (QueryCmdPastHorizon e) return $ O.QueryTipLocalStateOutput { O.localStateChainTip = chainTip @@ -297,7 +299,7 @@ runQueryTipCmd return $ flip (percentage tolerance) nowSeconds tipTimeResult mSyncProgress <- hushM syncProgressResult $ \e -> do - liftIO . T.hPutStrLn IO.stderr $ "Warning: Sync progress unavailable: " <> renderQueryCmdError e + liftIO . LT.hPutStrLn IO.stderr $ prettyToLazyText $ "Warning: Sync progress unavailable: " <> renderQueryCmdError e return $ O.QueryTipLocalStateOutput { O.localStateChainTip = chainTip @@ -399,8 +401,8 @@ runQueryKesPeriodInfoCmd let counterInformation = opCertNodeAndOnDiskCounters onDiskC stateC -- Always render diagnostic information - liftIO . putStrLn $ renderOpCertIntervalInformation (unFile nodeOpCertFp) opCertIntervalInformation - liftIO . putStrLn $ renderOpCertNodeAndOnDiskCounterInformation (unFile nodeOpCertFp) counterInformation + liftIO . putStrLn $ prettyToString $ renderOpCertIntervalInformation (unFile nodeOpCertFp) opCertIntervalInformation + liftIO . putStrLn $ prettyToString $ renderOpCertNodeAndOnDiskCounterInformation (unFile nodeOpCertFp) counterInformation let qKesInfoOutput = createQueryKesPeriodInfoOutput opCertIntervalInformation counterInformation eInfo gParams kesPeriodInfoJSON = encodePretty qKesInfoOutput @@ -413,205 +415,195 @@ runQueryKesPeriodInfoCmd & onLeft (left . QueryCmdAcquireFailure) & onLeft left - where - currentKesPeriod :: ChainTip -> GenesisParameters era -> CurrentKesPeriod - currentKesPeriod ChainTipAtGenesis _ = CurrentKesPeriod 0 - currentKesPeriod (ChainTip currSlot _ _) gParams = - let slotsPerKesPeriod = fromIntegral $ protocolParamSlotsPerKESPeriod gParams - in CurrentKesPeriod $ unSlotNo currSlot `div` slotsPerKesPeriod - - opCertStartingKesPeriod :: OperationalCertificate -> OpCertStartingKesPeriod - opCertStartingKesPeriod = OpCertStartingKesPeriod . fromIntegral . getKesPeriod - - opCertEndKesPeriod :: GenesisParameters era -> OperationalCertificate -> OpCertEndingKesPeriod - opCertEndKesPeriod gParams oCert = - let OpCertStartingKesPeriod start = opCertStartingKesPeriod oCert - maxKesEvo = fromIntegral $ protocolParamMaxKESEvolutions gParams - in OpCertEndingKesPeriod $ start + maxKesEvo - - -- See OCERT rule in Shelley Spec: https://hydra.iohk.io/job/Cardano/cardano-ledger-specs/shelleyLedgerSpec/latest/download-by-type/doc-pdf/ledger-spec - opCertIntervalInfo - :: GenesisParameters era - -> ChainTip - -> CurrentKesPeriod - -> OpCertStartingKesPeriod - -> OpCertEndingKesPeriod - -> OpCertIntervalInformation - opCertIntervalInfo gParams currSlot' c s e@(OpCertEndingKesPeriod oCertEnd) = - let cSlot = case currSlot' of - (ChainTip cSlotN _ _) -> unSlotNo cSlotN - ChainTipAtGenesis -> 0 - slotsTillExp = SlotsTillKesKeyExpiry . SlotNo $ (oCertEnd * fromIntegral (protocolParamSlotsPerKESPeriod gParams)) - cSlot - in O.createOpCertIntervalInfo c s e (Just slotsTillExp) - - opCertNodeAndOnDiskCounters - :: OpCertOnDiskCounter - -> Maybe OpCertNodeStateCounter - -> OpCertNodeAndOnDiskCounterInformation - opCertNodeAndOnDiskCounters o@(OpCertOnDiskCounter odc) (Just n@(OpCertNodeStateCounter nsc)) - | odc < nsc = OpCertOnDiskCounterBehindNodeState o n - | odc > nsc + 1 = OpCertOnDiskCounterTooFarAheadOfNodeState o n - | odc == nsc + 1 = OpCertOnDiskCounterAheadOfNodeState o n - | otherwise = OpCertOnDiskCounterEqualToNodeState o n - opCertNodeAndOnDiskCounters o Nothing = OpCertNoBlocksMintedYet o - - opCertExpiryUtcTime - :: Tentative (EpochInfo (Either Text)) - -> GenesisParameters era - -> OpCertEndingKesPeriod - -> Maybe UTCTime - opCertExpiryUtcTime eInfo gParams (OpCertEndingKesPeriod oCertExpiryKesPeriod) = - let time = epochInfoSlotToUTCTime - (tentative eInfo) - (SystemStart $ protocolParamSystemStart gParams) - (fromIntegral $ oCertExpiryKesPeriod * fromIntegral (protocolParamSlotsPerKESPeriod gParams)) - in case time of - Left _ -> Nothing - Right t -> Just t - - renderOpCertNodeAndOnDiskCounterInformation :: FilePath -> OpCertNodeAndOnDiskCounterInformation -> String - renderOpCertNodeAndOnDiskCounterInformation opCertFile opCertCounterInfo = - case opCertCounterInfo of + where + currentKesPeriod :: ChainTip -> GenesisParameters era -> CurrentKesPeriod + currentKesPeriod ChainTipAtGenesis _ = CurrentKesPeriod 0 + currentKesPeriod (ChainTip currSlot _ _) gParams = + let slotsPerKesPeriod = fromIntegral $ protocolParamSlotsPerKESPeriod gParams + in CurrentKesPeriod $ unSlotNo currSlot `div` slotsPerKesPeriod + + opCertStartingKesPeriod :: OperationalCertificate -> OpCertStartingKesPeriod + opCertStartingKesPeriod = OpCertStartingKesPeriod . fromIntegral . getKesPeriod + + opCertEndKesPeriod :: GenesisParameters era -> OperationalCertificate -> OpCertEndingKesPeriod + opCertEndKesPeriod gParams oCert = + let OpCertStartingKesPeriod start = opCertStartingKesPeriod oCert + maxKesEvo = fromIntegral $ protocolParamMaxKESEvolutions gParams + in OpCertEndingKesPeriod $ start + maxKesEvo + + -- See OCERT rule in Shelley Spec: https://hydra.iohk.io/job/Cardano/cardano-ledger-specs/shelleyLedgerSpec/latest/download-by-type/doc-pdf/ledger-spec + opCertIntervalInfo + :: GenesisParameters era + -> ChainTip + -> CurrentKesPeriod + -> OpCertStartingKesPeriod + -> OpCertEndingKesPeriod + -> OpCertIntervalInformation + opCertIntervalInfo gParams currSlot' c s e@(OpCertEndingKesPeriod oCertEnd) = + let cSlot = case currSlot' of + (ChainTip cSlotN _ _) -> unSlotNo cSlotN + ChainTipAtGenesis -> 0 + slotsTillExp = SlotsTillKesKeyExpiry . SlotNo $ (oCertEnd * fromIntegral (protocolParamSlotsPerKESPeriod gParams)) - cSlot + in O.createOpCertIntervalInfo c s e (Just slotsTillExp) + + opCertNodeAndOnDiskCounters + :: OpCertOnDiskCounter + -> Maybe OpCertNodeStateCounter + -> OpCertNodeAndOnDiskCounterInformation + opCertNodeAndOnDiskCounters o@(OpCertOnDiskCounter odc) (Just n@(OpCertNodeStateCounter nsc)) + | odc < nsc = OpCertOnDiskCounterBehindNodeState o n + | odc > nsc + 1 = OpCertOnDiskCounterTooFarAheadOfNodeState o n + | odc == nsc + 1 = OpCertOnDiskCounterAheadOfNodeState o n + | otherwise = OpCertOnDiskCounterEqualToNodeState o n + opCertNodeAndOnDiskCounters o Nothing = OpCertNoBlocksMintedYet o + + opCertExpiryUtcTime + :: Tentative (EpochInfo (Either Text)) + -> GenesisParameters era + -> OpCertEndingKesPeriod + -> Maybe UTCTime + opCertExpiryUtcTime eInfo gParams (OpCertEndingKesPeriod oCertExpiryKesPeriod) = + let time = epochInfoSlotToUTCTime + (tentative eInfo) + (SystemStart $ protocolParamSystemStart gParams) + (fromIntegral $ oCertExpiryKesPeriod * fromIntegral (protocolParamSlotsPerKESPeriod gParams)) + in case time of + Left _ -> Nothing + Right t -> Just t + + renderOpCertNodeAndOnDiskCounterInformation :: FilePath -> OpCertNodeAndOnDiskCounterInformation -> Doc AnsiStyle + renderOpCertNodeAndOnDiskCounterInformation opCertFile = \case OpCertOnDiskCounterEqualToNodeState _ _ -> - renderStringDefault $ - green "✓" <+> hang 0 - ( vsep - [ "The operational certificate counter agrees with the node protocol state counter" - ] - ) - OpCertOnDiskCounterAheadOfNodeState _ _ -> - renderStringDefault $ - green "✓" <+> hang 0 - ( vsep - [ "The operational certificate counter ahead of the node protocol state counter by 1" - ] - ) - OpCertOnDiskCounterTooFarAheadOfNodeState onDiskC nodeStateC -> - renderStringDefault $ - red "✗" <+> hang 0 + green "✓" <+> hang 0 ( vsep - [ "The operational certificate counter too far ahead of the node protocol state counter in the operational certificate at: " <> pretty opCertFile - , "On disk operational certificate counter: " <> pretty (unOpCertOnDiskCounter onDiskC) - , "Protocol state counter: " <> pretty (unOpCertNodeStateCounter nodeStateC) + [ "The operational certificate counter agrees with the node protocol state counter" ] ) - OpCertOnDiskCounterBehindNodeState onDiskC nodeStateC -> - renderStringDefault $ - red "✗" <+> hang 0 + OpCertOnDiskCounterAheadOfNodeState _ _ -> + green "✓" <+> hang 0 ( vsep - [ "The protocol state counter is greater than the counter in the operational certificate at: " <> pretty opCertFile - , "On disk operational certificate counter: " <> pretty (unOpCertOnDiskCounter onDiskC) - , "Protocol state counter: " <> pretty (unOpCertNodeStateCounter nodeStateC) + [ "The operational certificate counter ahead of the node protocol state counter by 1" ] ) + OpCertOnDiskCounterTooFarAheadOfNodeState onDiskC nodeStateC -> + red "✗" <+> hang 0 + ( vsep + [ "The operational certificate counter too far ahead of the node protocol state counter in the operational certificate at: " <> pretty opCertFile + , "On disk operational certificate counter: " <> pretty (unOpCertOnDiskCounter onDiskC) + , "Protocol state counter: " <> pretty (unOpCertNodeStateCounter nodeStateC) + ] + ) + OpCertOnDiskCounterBehindNodeState onDiskC nodeStateC -> + red "✗" <+> hang 0 + ( vsep + [ "The protocol state counter is greater than the counter in the operational certificate at: " <> pretty opCertFile + , "On disk operational certificate counter: " <> pretty (unOpCertOnDiskCounter onDiskC) + , "Protocol state counter: " <> pretty (unOpCertNodeStateCounter nodeStateC) + ] + ) OpCertNoBlocksMintedYet (OpCertOnDiskCounter onDiskC) -> - renderStringDefault $ - red "✗" <+> hang 0 - ( vsep - [ "No blocks minted so far with the operational certificate at: " <> pretty opCertFile - , "On disk operational certificate counter: " <> pretty onDiskC - ] - ) - + red "✗" <+> hang 0 + ( vsep + [ "No blocks minted so far with the operational certificate at: " <> pretty opCertFile + , "On disk operational certificate counter: " <> pretty onDiskC + ] + ) - createQueryKesPeriodInfoOutput - :: OpCertIntervalInformation - -> OpCertNodeAndOnDiskCounterInformation - -> Tentative (EpochInfo (Either Text)) - -> GenesisParameters era - -> O.QueryKesPeriodInfoOutput - createQueryKesPeriodInfoOutput oCertIntervalInfo oCertCounterInfo eInfo gParams = - let (e, mStillExp) = case oCertIntervalInfo of - OpCertWithinInterval _ end _ sTillExp -> (end, Just sTillExp) - OpCertStartingKesPeriodIsInTheFuture _ end _ -> (end, Nothing) - OpCertExpired _ end _ -> (end, Nothing) - OpCertSomeOtherError _ end _ -> (end, Nothing) - (onDiskCounter, mNodeCounter) = case oCertCounterInfo of - OpCertOnDiskCounterEqualToNodeState d n -> (d, Just n) - OpCertOnDiskCounterAheadOfNodeState d n -> (d, Just n) - OpCertOnDiskCounterTooFarAheadOfNodeState d n -> (d, Just n) - OpCertOnDiskCounterBehindNodeState d n -> (d, Just n) - OpCertNoBlocksMintedYet d -> (d, Nothing) - - in O.QueryKesPeriodInfoOutput - { O.qKesOpCertIntervalInformation = oCertIntervalInfo - , O.qKesInfoNodeStateOperationalCertNo = mNodeCounter - , O.qKesInfoOnDiskOperationalCertNo = onDiskCounter - , O.qKesInfoMaxKesKeyEvolutions = fromIntegral $ protocolParamMaxKESEvolutions gParams - , O.qKesInfoSlotsPerKesPeriod = fromIntegral $ protocolParamSlotsPerKESPeriod gParams - , O.qKesInfoKesKeyExpiry = - case mStillExp of - Just _ -> opCertExpiryUtcTime eInfo gParams e - Nothing -> Nothing - } - -- We get the operational certificate counter from the protocol state and check that - -- it is equivalent to what we have on disk. - opCertOnDiskAndStateCounters :: forall era . () - => Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) - => FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) - => Crypto.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 - => ProtocolState era - -> OperationalCertificate - -> ExceptT QueryCmdError IO (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter) - opCertOnDiskAndStateCounters ptclState opCert@(OperationalCertificate _ stakePoolVKey) = do - let onDiskOpCertCount = fromIntegral $ getOpCertCount opCert - - chainDepState <- pure (decodeProtocolState ptclState) - & onLeft (left . QueryCmdProtocolStateDecodeFailure) - - -- We need the stake pool id to determine what the counter of our SPO - -- should be. - let opCertCounterMap = Consensus.getOpCertCounters (Proxy @(ConsensusProtocol era)) chainDepState - StakePoolKeyHash blockIssuerHash = verificationKeyHash stakePoolVKey - - case Map.lookup (coerce blockIssuerHash) opCertCounterMap of - -- Operational certificate exists in the protocol state - -- so our ondisk op cert counter must be greater than or - -- equal to what is in the node state - Just ptclStateCounter -> return (OpCertOnDiskCounter onDiskOpCertCount, Just $ OpCertNodeStateCounter ptclStateCounter) - Nothing -> return (OpCertOnDiskCounter onDiskOpCertCount, Nothing) - - -renderOpCertIntervalInformation :: FilePath -> OpCertIntervalInformation -> String + createQueryKesPeriodInfoOutput + :: OpCertIntervalInformation + -> OpCertNodeAndOnDiskCounterInformation + -> Tentative (EpochInfo (Either Text)) + -> GenesisParameters era + -> O.QueryKesPeriodInfoOutput + createQueryKesPeriodInfoOutput oCertIntervalInfo oCertCounterInfo eInfo gParams = + let (e, mStillExp) = case oCertIntervalInfo of + OpCertWithinInterval _ end _ sTillExp -> (end, Just sTillExp) + OpCertStartingKesPeriodIsInTheFuture _ end _ -> (end, Nothing) + OpCertExpired _ end _ -> (end, Nothing) + OpCertSomeOtherError _ end _ -> (end, Nothing) + (onDiskCounter, mNodeCounter) = case oCertCounterInfo of + OpCertOnDiskCounterEqualToNodeState d n -> (d, Just n) + OpCertOnDiskCounterAheadOfNodeState d n -> (d, Just n) + OpCertOnDiskCounterTooFarAheadOfNodeState d n -> (d, Just n) + OpCertOnDiskCounterBehindNodeState d n -> (d, Just n) + OpCertNoBlocksMintedYet d -> (d, Nothing) + + in O.QueryKesPeriodInfoOutput + { O.qKesOpCertIntervalInformation = oCertIntervalInfo + , O.qKesInfoNodeStateOperationalCertNo = mNodeCounter + , O.qKesInfoOnDiskOperationalCertNo = onDiskCounter + , O.qKesInfoMaxKesKeyEvolutions = fromIntegral $ protocolParamMaxKESEvolutions gParams + , O.qKesInfoSlotsPerKesPeriod = fromIntegral $ protocolParamSlotsPerKESPeriod gParams + , O.qKesInfoKesKeyExpiry = + case mStillExp of + Just _ -> opCertExpiryUtcTime eInfo gParams e + Nothing -> Nothing + } + + -- We get the operational certificate counter from the protocol state and check that + -- it is equivalent to what we have on disk. + opCertOnDiskAndStateCounters :: forall era . () + => Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + => FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) + => Crypto.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 + => ProtocolState era + -> OperationalCertificate + -> ExceptT QueryCmdError IO (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter) + opCertOnDiskAndStateCounters ptclState opCert@(OperationalCertificate _ stakePoolVKey) = do + let onDiskOpCertCount = fromIntegral $ getOpCertCount opCert + + chainDepState <- pure (decodeProtocolState ptclState) + & onLeft (left . QueryCmdProtocolStateDecodeFailure) + + -- We need the stake pool id to determine what the counter of our SPO + -- should be. + let opCertCounterMap = Consensus.getOpCertCounters (Proxy @(ConsensusProtocol era)) chainDepState + StakePoolKeyHash blockIssuerHash = verificationKeyHash stakePoolVKey + + case Map.lookup (coerce blockIssuerHash) opCertCounterMap of + -- Operational certificate exists in the protocol state + -- so our ondisk op cert counter must be greater than or + -- equal to what is in the node state + Just ptclStateCounter -> return (OpCertOnDiskCounter onDiskOpCertCount, Just $ OpCertNodeStateCounter ptclStateCounter) + Nothing -> return (OpCertOnDiskCounter onDiskOpCertCount, Nothing) + + +renderOpCertIntervalInformation :: FilePath -> OpCertIntervalInformation -> Doc AnsiStyle renderOpCertIntervalInformation opCertFile opCertInfo = case opCertInfo of OpCertWithinInterval _start _end _current _stillExp -> - renderStringDefault $ - green "✓" <+> hang 0 - ( vsep - [ "Operational certificate's KES period is within the correct KES period interval" - ] - ) + green "✓" <+> hang 0 + ( vsep + [ "Operational certificate's KES period is within the correct KES period interval" + ] + ) OpCertStartingKesPeriodIsInTheFuture (OpCertStartingKesPeriod start) (OpCertEndingKesPeriod end) (CurrentKesPeriod current) -> - renderStringDefault $ - red "✗" <+> hang 0 - ( vsep - [ "Node operational certificate at: " <> pretty opCertFile <> " has an incorrectly specified starting KES period. " - , "Current KES period: " <> pretty current - , "Operational certificate's starting KES period: " <> pretty start - , "Operational certificate's expiry KES period: " <> pretty end - ] - ) + red "✗" <+> hang 0 + ( vsep + [ "Node operational certificate at: " <> pretty opCertFile <> " has an incorrectly specified starting KES period. " + , "Current KES period: " <> pretty current + , "Operational certificate's starting KES period: " <> pretty start + , "Operational certificate's expiry KES period: " <> pretty end + ] + ) OpCertExpired _ (OpCertEndingKesPeriod end) (CurrentKesPeriod current) -> - renderStringDefault $ - red "✗" <+> hang 0 - ( vsep - [ "Node operational certificate at: " <> pretty opCertFile <> " has expired. " - , "Current KES period: " <> pretty current - , "Operational certificate's expiry KES period: " <> pretty end - ] - ) + red "✗" <+> hang 0 + ( vsep + [ "Node operational certificate at: " <> pretty opCertFile <> " has expired. " + , "Current KES period: " <> pretty current + , "Operational certificate's expiry KES period: " <> pretty end + ] + ) OpCertSomeOtherError (OpCertStartingKesPeriod start) (OpCertEndingKesPeriod end) (CurrentKesPeriod current) -> - renderStringDefault $ - red "✗" <+> hang 0 - ( vsep - [ "An unknown error occurred with operational certificate at: " <> pretty opCertFile - , "Current KES period: " <> pretty current - , "Operational certificate's starting KES period: " <> pretty start - , "Operational certificate's expiry KES period: " <> pretty end - ] - ) + red "✗" <+> hang 0 + ( vsep + [ "An unknown error occurred with operational certificate at: " <> pretty opCertFile + , "Current KES period: " <> pretty current + , "Operational certificate's starting KES period: " <> pretty start + , "Operational certificate's expiry KES period: " <> pretty end + ] + ) -- | Query the current and future parameters for a stake pool, including the retirement date. -- Any of these may be empty (in which case a null will be displayed). diff --git a/cardano-cli/src/Cardano/CLI/Helpers.hs b/cardano-cli/src/Cardano/CLI/Helpers.hs index 475a218f14..02473017d6 100644 --- a/cardano-cli/src/Cardano/CLI/Helpers.hs +++ b/cardano-cli/src/Cardano/CLI/Helpers.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -15,6 +16,8 @@ module Cardano.CLI.Helpers , validateCBOR ) where +import Cardano.Api.Pretty + import Cardano.Chain.Block (decCBORABlockOrBoundary) import qualified Cardano.Chain.Delegation as Delegation import qualified Cardano.Chain.Update as Update @@ -52,14 +55,18 @@ data HelpersError | ReadCBORFileFailure !FilePath !Text deriving Show -renderHelpersError :: HelpersError -> Text -renderHelpersError err = - case err of - OutputMustNotAlreadyExist fp -> "Output file/directory must not already exist: " <> Text.pack fp - ReadCBORFileFailure fp err' -> "CBOR read failure at: " <> Text.pack fp <> Text.pack (show err') - CBORPrettyPrintError err' -> "Error with CBOR decoding: " <> Text.pack (show err') - CBORDecodingError err' -> "Error with CBOR decoding: " <> Text.pack (show err') - IOError' fp ioE -> "Error at: " <> Text.pack fp <> " Error: " <> Text.pack (show ioE) +renderHelpersError :: HelpersError -> Doc ann +renderHelpersError = \case + OutputMustNotAlreadyExist fp -> + "Output file/directory must not already exist: " <> pretty fp + ReadCBORFileFailure fp err' -> + "CBOR read failure at: " <> pretty fp <> pshow err' + CBORPrettyPrintError err' -> + "Error with CBOR decoding: " <> pshow err' + CBORDecodingError err' -> + "Error with CBOR decoding: " <> pshow err' + IOError' fp ioE -> + "Error at: " <> pretty fp <> " Error: " <> pshow ioE decodeCBOR :: LB.ByteString diff --git a/cardano-cli/src/Cardano/CLI/Pretty.hs b/cardano-cli/src/Cardano/CLI/Pretty.hs index a0f5829bd4..d9a5fa98e1 100644 --- a/cardano-cli/src/Cardano/CLI/Pretty.hs +++ b/cardano-cli/src/Cardano/CLI/Pretty.hs @@ -1,32 +1,20 @@ module Cardano.CLI.Pretty - ( Ann, - putLn, - hPutLn, - renderDefault, - renderStringDefault, - - black, - red, - green, - yellow, - blue, - magenta, - cyan, - white, + ( module Pretty + , putLn + , hPutLn ) where +import Cardano.Api.Pretty +import qualified Cardano.Api.Pretty as Pretty + import qualified Control.Concurrent.QSem as IO import Control.Exception (bracket_) import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Data.Text.Lazy as TextLazy import qualified Data.Text.Lazy.IO as TextLazy -import Prettyprinter import Prettyprinter.Render.Terminal import qualified System.IO as IO import qualified System.IO.Unsafe as IO -type Ann = AnsiStyle - sem :: IO.QSem sem = IO.unsafePerformIO $ IO.newQSem 1 {-# NOINLINE sem #-} @@ -35,37 +23,7 @@ consoleBracket :: IO a -> IO a consoleBracket = bracket_ (IO.waitQSem sem) (IO.signalQSem sem) putLn :: MonadIO m => Doc AnsiStyle -> m () -putLn = liftIO . consoleBracket . TextLazy.putStrLn . renderDefault +putLn = liftIO . consoleBracket . TextLazy.putStrLn . prettyToLazyText hPutLn :: MonadIO m => IO.Handle -> Doc AnsiStyle -> m () -hPutLn h = liftIO . consoleBracket . TextLazy.hPutStr h . renderDefault - -renderStringDefault :: Doc AnsiStyle -> String -renderStringDefault = TextLazy.unpack . renderDefault - -renderDefault :: Doc AnsiStyle -> TextLazy.Text -renderDefault = renderLazy . layoutPretty defaultLayoutOptions - -black :: Doc AnsiStyle -> Doc AnsiStyle -black = annotate (color Black) - -red :: Doc AnsiStyle -> Doc AnsiStyle -red = annotate (color Red) - -green :: Doc AnsiStyle -> Doc AnsiStyle -green = annotate (color Green) - -yellow :: Doc AnsiStyle -> Doc AnsiStyle -yellow = annotate (color Yellow) - -blue :: Doc AnsiStyle -> Doc AnsiStyle -blue = annotate (color Blue) - -magenta :: Doc AnsiStyle -> Doc AnsiStyle -magenta = annotate (color Magenta) - -cyan :: Doc AnsiStyle -> Doc AnsiStyle -cyan = annotate (color Cyan) - -white :: Doc AnsiStyle -> Doc AnsiStyle -white = annotate (color White) +hPutLn h = liftIO . consoleBracket . TextLazy.hPutStr h . prettyToLazyText diff --git a/cardano-cli/src/Cardano/CLI/Read.hs b/cardano-cli/src/Cardano/CLI/Read.hs index 8c41b071f7..d160a9111e 100644 --- a/cardano-cli/src/Cardano/CLI/Read.hs +++ b/cardano-cli/src/Cardano/CLI/Read.hs @@ -97,6 +97,7 @@ module Cardano.CLI.Read import Cardano.Api as Api import qualified Cardano.Api.Ledger as L +import Cardano.Api.Pretty import Cardano.Api.Shelley as Api import qualified Cardano.Binary as CBOR @@ -147,7 +148,6 @@ import GHC.IO.Handle.FD (openFileBlocking) import qualified Options.Applicative as Opt import System.IO (IOMode (ReadMode)) - -- Metadata data MetadataError @@ -159,25 +159,29 @@ data MetadataError | MetadataErrorNotAvailableInEra AnyCardanoEra deriving Show -renderMetadataError :: MetadataError -> Text -renderMetadataError (MetadataErrorFile fileErr) = - Text.pack $ displayError fileErr -renderMetadataError (MetadataErrorJsonParseError fp jsonErr) = - Text.pack $ "Invalid JSON format in file: " <> show fp <> - "\nJSON parse error: " <> jsonErr -renderMetadataError (MetadataErrorConversionError fp metadataErr) = - Text.pack $ "Error reading metadata at: " <> show fp <> - "\n" <> displayError metadataErr -renderMetadataError (MetadataErrorValidationError fp errs) = - Text.pack $ "Error validating transaction metadata at: " <> fp <> "\n" <> - List.intercalate "\n" - [ "key " <> show k <> ":" <> displayError valErr - | (k, valErr) <- errs ] -renderMetadataError (MetadataErrorDecodeError fp metadataErr) = - Text.pack $ "Error decoding CBOR metadata at: " <> show fp <> - " Error: " <> show metadataErr -renderMetadataError (MetadataErrorNotAvailableInEra e) = - "Transaction metadata not supported in " <> renderEra e +renderMetadataError :: MetadataError -> Doc ann +renderMetadataError = \case + MetadataErrorFile fileErr -> + prettyError fileErr + MetadataErrorJsonParseError fp jsonErr -> + "Invalid JSON format in file: " <> pshow fp <> + "\nJSON parse error: " <> pretty jsonErr + MetadataErrorConversionError fp metadataErr -> + "Error reading metadata at: " <> pshow fp <> + "\n" <> prettyError metadataErr + MetadataErrorValidationError fp errs -> + mconcat + [ "Error validating transaction metadata at: " <> pretty fp <> "\n" + , mconcat $ List.intersperse "\n" + [ "key " <> pshow k <> ":" <> prettyError valErr + | (k, valErr) <- errs + ] + ] + MetadataErrorDecodeError fp metadataErr -> + "Error decoding CBOR metadata at: " <> pshow fp <> + " Error: " <> pshow metadataErr + MetadataErrorNotAvailableInEra e -> + "Transaction metadata not supported in " <> pretty (renderEra e) readTxMetadata :: CardanoEra era -> TxMetadataJsonSchema @@ -225,24 +229,25 @@ data ScriptWitnessError | ScriptWitnessErrorReferenceScriptsNotSupportedInEra !AnyCardanoEra | ScriptWitnessErrorScriptData ScriptDataError -renderScriptWitnessError :: ScriptWitnessError -> Text -renderScriptWitnessError (ScriptWitnessErrorFile err) = - Text.pack $ displayError err -renderScriptWitnessError (ScriptWitnessErrorScriptLanguageNotSupportedInEra (AnyScriptLanguage lang) anyEra) = - "The script language " <> Text.pack (show lang) <> " is not supported in the " <> - renderEra anyEra <> " era." -renderScriptWitnessError (ScriptWitnessErrorExpectedSimple file (AnyScriptLanguage lang)) = - Text.pack $ file <> ": expected a script in the simple script language, " <> - "but it is actually using " <> show lang <> ". Alternatively, to use " <> - "a Plutus script, you must also specify the redeemer " <> - "(datum if appropriate) and script execution units." -renderScriptWitnessError (ScriptWitnessErrorExpectedPlutus file (AnyScriptLanguage lang)) = - Text.pack $ file <> ": expected a script in the Plutus script language, " <> - "but it is actually using " <> show lang <> "." -renderScriptWitnessError (ScriptWitnessErrorReferenceScriptsNotSupportedInEra anyEra) = - "Reference scripts not supported in era: " <> renderEra anyEra -renderScriptWitnessError (ScriptWitnessErrorScriptData sDataError) = - renderScriptDataError sDataError +renderScriptWitnessError :: ScriptWitnessError -> Doc ann +renderScriptWitnessError = \case + ScriptWitnessErrorFile err -> + prettyError err + ScriptWitnessErrorScriptLanguageNotSupportedInEra (AnyScriptLanguage lang) anyEra -> + "The script language " <> pshow lang <> " is not supported in the " <> + pretty (renderEra anyEra) <> " era." + ScriptWitnessErrorExpectedSimple file (AnyScriptLanguage lang) -> + pretty file <> ": expected a script in the simple script language, " <> + "but it is actually using " <> pshow lang <> ". Alternatively, to use " <> + "a Plutus script, you must also specify the redeemer " <> + "(datum if appropriate) and script execution units." + ScriptWitnessErrorExpectedPlutus file (AnyScriptLanguage lang) -> + pretty file <> ": expected a script in the Plutus script language, " <> + "but it is actually using " <> pshow lang <> "." + ScriptWitnessErrorReferenceScriptsNotSupportedInEra anyEra -> + "Reference scripts not supported in era: " <> pretty (renderEra anyEra) + ScriptWitnessErrorScriptData sDataError -> + renderScriptDataError sDataError readScriptWitnessFiles :: CardanoEra era @@ -382,23 +387,20 @@ data ScriptDataError = | ScriptDataErrorMetadataDecode !FilePath !CBOR.DecoderError | ScriptDataErrorJsonBytes !ScriptDataJsonBytesError -renderScriptDataError :: ScriptDataError -> Text -renderScriptDataError (ScriptDataErrorFile err) = - Text.pack $ displayError err -renderScriptDataError (ScriptDataErrorJsonParse fp jsonErr) = - Text.pack $ "Invalid JSON format in file: " <> show fp <> - "\nJSON parse error: " <> jsonErr -renderScriptDataError (ScriptDataErrorConversion fp sDataJsonErr) = - Text.pack $ "Error reading metadata at: " <> show fp <> - "\n" <> displayError sDataJsonErr -renderScriptDataError (ScriptDataErrorValidation fp sDataRangeErr) = - Text.pack $ "Error validating script data at: " <> show fp <> ":\n" <> - displayError sDataRangeErr -renderScriptDataError (ScriptDataErrorMetadataDecode fp decoderErr) = - Text.pack $ "Error decoding CBOR metadata at: " <> show fp <> - " Error: " <> show decoderErr -renderScriptDataError (ScriptDataErrorJsonBytes e) = - Text.pack $ displayError e +renderScriptDataError :: ScriptDataError -> Doc ann +renderScriptDataError = \case + ScriptDataErrorFile err -> + prettyError err + ScriptDataErrorJsonParse fp jsonErr-> + "Invalid JSON format in file: " <> pshow fp <> "\nJSON parse error: " <> pretty jsonErr + ScriptDataErrorConversion fp sDataJsonErr-> + "Error reading metadata at: " <> pshow fp <> "\n" <> prettyError sDataJsonErr + ScriptDataErrorValidation fp sDataRangeErr-> + "Error validating script data at: " <> pshow fp <> ":\n" <> prettyError sDataRangeErr + ScriptDataErrorMetadataDecode fp decoderErr-> + "Error decoding CBOR metadata at: " <> pshow fp <> " Error: " <> pshow decoderErr + ScriptDataErrorJsonBytes e-> + prettyError e readScriptDatumOrFile :: ScriptDatumOrFile witctx @@ -513,11 +515,13 @@ data CddlError = CddlErrorTextEnv deriving Show instance Error CddlError where - displayError (CddlErrorTextEnv textEnvErr cddlErr) = - "Failed to decode neither the cli's serialisation format nor the ledger's \ - \CDDL serialisation format. TextEnvelope error: " <> displayError textEnvErr <> "\n" <> - "TextEnvelopeCddl error: " <> displayError cddlErr - displayError (CddlIOError e) = displayError e + prettyError = \case + CddlErrorTextEnv textEnvErr cddlErr -> + "Failed to decode neither the cli's serialisation format nor the ledger's " <> + "CDDL serialisation format. TextEnvelope error: " <> prettyError textEnvErr <> "\n" <> + "TextEnvelopeCddl error: " <> prettyError cddlErr + CddlIOError e -> + prettyError e acceptTxCDDLSerialisation :: FileOrPipe @@ -575,11 +579,13 @@ data CddlWitnessError deriving Show instance Error CddlWitnessError where - displayError (CddlWitnessErrorTextEnv teErr cddlErr) = - "Failed to decode neither the cli's serialisation format nor the ledger's \ - \CDDL serialisation format. TextEnvelope error: " <> displayError teErr <> "\n" <> - "TextEnvelopeCddl error: " <> displayError cddlErr - displayError (CddlWitnessIOError fileE) = displayError fileE + prettyError = \case + CddlWitnessErrorTextEnv teErr cddlErr -> + "Failed to decode neither the cli's serialisation format nor the ledger's \ + \CDDL serialisation format. TextEnvelope error: " <> prettyError teErr <> "\n" <> + "TextEnvelopeCddl error: " <> prettyError cddlErr + CddlWitnessIOError fileE -> + prettyError fileE -- TODO: This is a stop gap to avoid modifying the TextEnvelope @@ -680,15 +686,14 @@ data ReadWitnessSigningDataError deriving Show -- | Render an error message for a 'ReadWitnessSigningDataError'. -renderReadWitnessSigningDataError :: ReadWitnessSigningDataError -> Text -renderReadWitnessSigningDataError err = - case err of - ReadWitnessSigningDataSigningKeyDecodeError fileErr -> - "Error reading signing key: " <> Text.pack (displayError fileErr) - ReadWitnessSigningDataScriptError fileErr -> - "Error reading script: " <> Text.pack (displayError fileErr) - ReadWitnessSigningDataSigningKeyAndAddressMismatch -> - "Only a Byron signing key may be accompanied by a Byron address." +renderReadWitnessSigningDataError :: ReadWitnessSigningDataError -> Doc ann +renderReadWitnessSigningDataError = \case + ReadWitnessSigningDataSigningKeyDecodeError fileErr -> + "Error reading signing key: " <> prettyError fileErr + ReadWitnessSigningDataScriptError fileErr -> + "Error reading script: " <> prettyError fileErr + ReadWitnessSigningDataSigningKeyAndAddressMismatch -> + "Only a Byron signing key may be accompanied by a Byron address." readWitnessSigningData :: WitnessSigningData @@ -739,9 +744,11 @@ data RequiredSignerError deriving Show instance Error RequiredSignerError where - displayError (RequiredSignerErrorFile e) = displayError e - displayError (RequiredSignerErrorByronKey (File byronSkeyfile)) = - "Byron witnesses cannot be used for required signers: " <> byronSkeyfile + prettyError = \case + RequiredSignerErrorFile e -> + prettyError e + RequiredSignerErrorByronKey (File byronSkeyfile) -> + "Byron witnesses cannot be used for required signers: " <> pretty byronSkeyfile readRequiredSigner :: RequiredSigner -> IO (Either RequiredSignerError (Hash PaymentKey)) readRequiredSigner (RequiredSignerHash h) = return $ Right h @@ -777,9 +784,11 @@ data VoteError deriving Show instance Error VoteError where - displayError = \case - VoteErrorFile e -> displayError e - VoteErrorTextNotUnicode e -> "Vote text file not UTF8-encoded: " <> displayException e + prettyError = \case + VoteErrorFile e -> + prettyError e + VoteErrorTextNotUnicode e -> + "Vote text file not UTF8-encoded: " <> pretty (displayException e) readVotingProceduresFiles :: () => ConwayEraOnwards era diff --git a/cardano-cli/src/Cardano/CLI/Run.hs b/cardano-cli/src/Cardano/CLI/Run.hs index cf963e1049..6b1d971881 100644 --- a/cardano-cli/src/Cardano/CLI/Run.hs +++ b/cardano-cli/src/Cardano/CLI/Run.hs @@ -34,6 +34,7 @@ import Data.Version (showVersion) import Options.Applicative.Help.Core import Options.Applicative.Types (OptReader (..), Option (..), Parser (..), ParserInfo (..), ParserPrefs (..)) +import Prettyprinter import System.Info (arch, compilerName, compilerVersion, os) import qualified System.IO as IO @@ -74,7 +75,7 @@ runClientCommand = \case DisplayVersion -> runDisplayVersion -renderClientCommandError :: ClientCommandErrors -> Text +renderClientCommandError :: ClientCommandErrors -> Doc ann renderClientCommandError = \case CmdError cmdText err -> renderCmdError cmdText err diff --git a/cardano-cli/src/Cardano/CLI/Run/Ping.hs b/cardano-cli/src/Cardano/CLI/Run/Ping.hs index bbaef0ba72..b466f82ea8 100644 --- a/cardano-cli/src/Cardano/CLI/Run/Ping.hs +++ b/cardano-cli/src/Cardano/CLI/Run/Ping.hs @@ -11,6 +11,8 @@ module Cardano.CLI.Run.Ping , parsePingCmd ) where +import Cardano.Api.Pretty + import qualified Cardano.Network.Ping as CNP import Control.Applicative ((<|>)) @@ -25,8 +27,7 @@ import Control.Monad.Trans.Except.Extra (left) import Control.Tracer (Tracer (..)) import Data.List (foldl') import qualified Data.List as L -import Data.Text (Text) -import qualified Data.Text as T +import qualified Data.List as List import Data.Word (Word32) import Network.Socket (AddrInfo) import qualified Network.Socket as Socket @@ -122,9 +123,9 @@ runPingCmd options = do doErrLog :: String -> IO () doErrLog = IO.hPutStrLn IO.stderr -renderPingClientCmdError :: PingClientCmdError -> Text +renderPingClientCmdError :: PingClientCmdError -> Doc ann renderPingClientCmdError = \case - PingClientCmdError es -> T.intercalate "\n" $ T.pack . show <$> es + PingClientCmdError es -> mconcat $ List.intersperse "\n" $ pshow <$> es parsePingCmd :: Opt.Parser PingCmd parsePingCmd = Opt.hsubparser $ mconcat diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/AddressCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/AddressCmdError.hs index 4a26883393..06bd8dd80d 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/AddressCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/AddressCmdError.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -16,8 +17,7 @@ import Cardano.CLI.Types.Errors.AddressInfoError import Cardano.CLI.Types.Key (VerificationKeyTextOrFileError (..), renderVerificationKeyTextOrFileError) -import Data.Text (Text) -import qualified Data.Text as Text +import Prettyprinter data AddressCmdError = AddressCmdAddressInfoError !AddressInfoError @@ -28,17 +28,17 @@ data AddressCmdError | AddressCmdExpectedPaymentVerificationKey SomeAddressVerificationKey deriving Show -renderAddressCmdError :: AddressCmdError -> Text -renderAddressCmdError err = - case err of - AddressCmdAddressInfoError addrInfoErr -> - Text.pack (displayError addrInfoErr) - AddressCmdReadKeyFileError fileErr -> - Text.pack (displayError fileErr) - AddressCmdVerificationKeyTextOrFileError vkTextOrFileErr -> - renderVerificationKeyTextOrFileError vkTextOrFileErr - AddressCmdReadScriptFileError fileErr -> - Text.pack (displayError fileErr) - AddressCmdWriteFileError fileErr -> Text.pack (displayError fileErr) - AddressCmdExpectedPaymentVerificationKey someAddress -> - "Expected payment verification key but got: " <> renderSomeAddressVerificationKey someAddress +renderAddressCmdError :: AddressCmdError -> Doc ann +renderAddressCmdError = \case + AddressCmdAddressInfoError addrInfoErr -> + prettyError addrInfoErr + AddressCmdReadKeyFileError fileErr -> + prettyError fileErr + AddressCmdVerificationKeyTextOrFileError vkTextOrFileErr -> + renderVerificationKeyTextOrFileError vkTextOrFileErr + AddressCmdReadScriptFileError fileErr -> + prettyError fileErr + AddressCmdWriteFileError fileErr -> + prettyError fileErr + AddressCmdExpectedPaymentVerificationKey someAddress -> + "Expected payment verification key but got: " <> pretty (renderSomeAddressVerificationKey someAddress) diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/AddressInfoError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/AddressInfoError.hs index 19912630da..7c1001a037 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/AddressInfoError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/AddressInfoError.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE LambdaCase #-} + module Cardano.CLI.Types.Errors.AddressInfoError ( AddressInfoError(..) ) where import Cardano.Api +import Cardano.Api.Pretty import Data.Text (Text) @@ -10,5 +13,6 @@ newtype AddressInfoError = ShelleyAddressInvalid Text deriving Show instance Error AddressInfoError where - displayError (ShelleyAddressInvalid addrTxt) = - "Invalid address: " <> show addrTxt + prettyError = \case + ShelleyAddressInvalid addrTxt -> + "Invalid address: " <> pshow addrTxt diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/BootstrapWitnessError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/BootstrapWitnessError.hs index 29f94b367f..759adb9176 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/BootstrapWitnessError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/BootstrapWitnessError.hs @@ -3,7 +3,7 @@ module Cardano.CLI.Types.Errors.BootstrapWitnessError , renderBootstrapWitnessError ) where -import Data.Text (Text) +import Prettyprinter -- | Error constructing a Shelley bootstrap witness (i.e. a Byron key witness -- in the Shelley era). @@ -14,7 +14,7 @@ data BootstrapWitnessError deriving Show -- | Render an error message for a 'BootstrapWitnessError'. -renderBootstrapWitnessError :: BootstrapWitnessError -> Text +renderBootstrapWitnessError :: BootstrapWitnessError -> Doc ann renderBootstrapWitnessError MissingNetworkIdOrByronAddressError = "Transactions witnessed by a Byron signing key must be accompanied by a " <> "network ID. Either provide a network ID or provide a Byron " diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/CardanoAddressSigningKeyConversionError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/CardanoAddressSigningKeyConversionError.hs index 37826ab8d3..8c8ba84aae 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/CardanoAddressSigningKeyConversionError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/CardanoAddressSigningKeyConversionError.hs @@ -1,13 +1,12 @@ +{-# LANGUAGE LambdaCase #-} + module Cardano.CLI.Types.Errors.CardanoAddressSigningKeyConversionError ( CardanoAddressSigningKeyConversionError(..) - , renderCardanoAddressSigningKeyConversionError ) where import Cardano.Api import Data.ByteString (ByteString) -import Data.Text (Text) -import qualified Data.Text as Text -- | An error that can occur while converting a @cardano-address@ extended -- signing key. @@ -20,16 +19,9 @@ data CardanoAddressSigningKeyConversionError deriving (Show, Eq) instance Error CardanoAddressSigningKeyConversionError where - displayError = Text.unpack . renderCardanoAddressSigningKeyConversionError - --- | Render an error message for a 'CardanoAddressSigningKeyConversionError'. -renderCardanoAddressSigningKeyConversionError - :: CardanoAddressSigningKeyConversionError - -> Text -renderCardanoAddressSigningKeyConversionError err = - case err of + prettyError = \case CardanoAddressSigningKeyBech32DecodeError decErr -> - Text.pack (displayError decErr) + prettyError decErr CardanoAddressSigningKeyDeserialisationError _bs -> -- Sensitive data, such as the signing key, is purposely not included in -- the error message. diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/CmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/CmdError.hs index 8a8032fed0..fb9e482040 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/CmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/CmdError.hs @@ -7,25 +7,25 @@ module Cardano.CLI.Types.Errors.CmdError import Cardano.Api +import Cardano.CLI.Types.Errors.AddressCmdError import Cardano.CLI.Types.Errors.DelegationError +import Cardano.CLI.Types.Errors.GenesisCmdError import Cardano.CLI.Types.Errors.GovernanceActionsError import Cardano.CLI.Types.Errors.GovernanceCmdError import Cardano.CLI.Types.Errors.GovernanceCommitteeError import Cardano.CLI.Types.Errors.GovernanceQueryError import Cardano.CLI.Types.Errors.GovernanceVoteCmdError -import Cardano.CLI.Types.Errors.RegistrationError -import Cardano.CLI.Types.Errors.AddressCmdError -import Cardano.CLI.Types.Errors.GenesisCmdError import Cardano.CLI.Types.Errors.KeyCmdError import Cardano.CLI.Types.Errors.NodeCmdError import Cardano.CLI.Types.Errors.QueryCmdError +import Cardano.CLI.Types.Errors.RegistrationError import Cardano.CLI.Types.Errors.StakeAddressCmdError +import Cardano.CLI.Types.Errors.StakePoolCmdError import Cardano.CLI.Types.Errors.TextViewFileError import Cardano.CLI.Types.Errors.TxCmdError -import Cardano.CLI.Types.Errors.StakePoolCmdError import Data.Text (Text) -import qualified Data.Text as Text +import Prettyprinter data CmdError = CmdAddressError !AddressCmdError @@ -45,30 +45,30 @@ data CmdError | CmdTextViewError !TextViewFileError | CmdTransactionError !TxCmdError -renderCmdError :: Text -> CmdError -> Text +renderCmdError :: Text -> CmdError -> Doc ann renderCmdError cmdText = \case CmdAddressError e -> renderError renderAddressCmdError e - CmdEraDelegationError e -> renderError (Text.pack . displayError) e - CmdGenesisError e -> renderError (Text.pack . displayError) e - CmdGovernanceActionError e -> renderError (Text.pack . displayError) e - CmdGovernanceCmdError e -> renderError (Text.pack . displayError) e - CmdGovernanceCommitteeError e -> renderError (Text.pack . displayError) e - CmdGovernanceQueryError e -> renderError (Text.pack . displayError) e - CmdGovernanceVoteError e -> renderError (Text.pack . displayError) e + CmdEraDelegationError e -> renderError prettyError e + CmdGenesisError e -> renderError prettyError e + CmdGovernanceActionError e -> renderError prettyError e + CmdGovernanceCmdError e -> renderError prettyError e + CmdGovernanceCommitteeError e -> renderError prettyError e + CmdGovernanceQueryError e -> renderError prettyError e + CmdGovernanceVoteError e -> renderError prettyError e CmdKeyError e -> renderError renderKeyCmdError e CmdNodeError e -> renderError renderNodeCmdError e CmdQueryError e -> renderError renderQueryCmdError e - CmdRegistrationError e -> renderError (Text.pack . displayError) e - CmdStakeAddressError e -> renderError (Text.pack . displayError) e + CmdRegistrationError e -> renderError prettyError e + CmdStakeAddressError e -> renderError prettyError e CmdStakePoolError e -> renderError renderStakePoolCmdError e CmdTextViewError e -> renderError renderTextViewFileError e CmdTransactionError e -> renderError renderTxCmdError e where - renderError :: (a -> Text) -> a -> Text + renderError :: (a -> Doc ann) -> a -> Doc ann renderError renderer shelCliCmdErr = mconcat [ "Command failed: " - , cmdText + , pretty cmdText , " Error: " , renderer shelCliCmdErr ] diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/DelegationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/DelegationError.hs index 5d1d5090fd..f6b7fca1f7 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/DelegationError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/DelegationError.hs @@ -20,12 +20,12 @@ data DelegationError deriving (Show, Generic) instance Error DelegationError where - displayError = \case + prettyError = \case DelegationReadError e -> - "Cannot read delegation target: " <> displayError e + "Cannot read delegation target: " <> prettyError e DelegationStakeCredentialError e -> - "Cannot get stake credential: " <> displayError e + "Cannot get stake credential: " <> prettyError e DelegationCertificateWriteFileError e -> - "Cannot write certificate: " <> displayError e + "Cannot write certificate: " <> prettyError e DelegationDRepReadError e -> - "Cannot read DRep key: " <> displayError e + "Cannot read DRep key: " <> prettyError e diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs index e693e53e26..9e24d357f5 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs @@ -6,6 +6,7 @@ module Cardano.CLI.Types.Errors.GenesisCmdError ) where import Cardano.Api +import Cardano.Api.Pretty import Cardano.CLI.Byron.Genesis as Byron import Cardano.CLI.Types.Common @@ -16,7 +17,7 @@ import Cardano.CLI.Types.Errors.StakePoolCmdError import Control.Exception (IOException) import Data.Text (Text) -import qualified Data.Text as Text +import Prettyprinter data GenesisCmdError = GenesisCmdAesonDecodeError !FilePath !Text @@ -41,51 +42,56 @@ data GenesisCmdError deriving Show instance Error GenesisCmdError where - displayError = - \case - GenesisCmdAesonDecodeError fp decErr -> - "Error while decoding Shelley genesis at: " <> fp <> " Error: " <> Text.unpack decErr - GenesisCmdGenesisFileError fe -> displayError fe - GenesisCmdFileError fe -> displayError fe - GenesisCmdMismatchedGenesisKeyFiles gfiles dfiles vfiles -> - "Mismatch between the files found:\n" - <> "Genesis key file indexes: " <> show gfiles <> "\n" - <> "Delegate key file indexes: " <> show dfiles <> "\n" - <> "Delegate VRF key file indexes: " <> show vfiles - GenesisCmdFilesNoIndex files -> - "The genesis keys files are expected to have a numeric index but these do not:\n" - <> unlines files - GenesisCmdFilesDupIndex files -> - "The genesis keys files are expected to have a unique numeric index but these do not:\n" - <> unlines files - GenesisCmdTextEnvReadFileError fileErr -> displayError fileErr - GenesisCmdUnexpectedAddressVerificationKey (File file) expect got -> mconcat - [ "Unexpected address verification key type in file ", file - , ", expected: ", Text.unpack expect, ", got: ", Text.unpack (renderSomeAddressVerificationKey got) + prettyError = \case + GenesisCmdAesonDecodeError fp decErr -> + "Error while decoding Shelley genesis at: " <> pretty fp <> " Error: " <> pretty decErr + GenesisCmdGenesisFileError fe -> + prettyError fe + GenesisCmdFileError fe -> + prettyError fe + GenesisCmdMismatchedGenesisKeyFiles gfiles dfiles vfiles -> + "Mismatch between the files found:\n" + <> "Genesis key file indexes: " <> pshow gfiles <> "\n" + <> "Delegate key file indexes: " <> pshow dfiles <> "\n" + <> "Delegate VRF key file indexes: " <> pshow vfiles + GenesisCmdFilesNoIndex files -> + "The genesis keys files are expected to have a numeric index but these do not:\n" + <> vsep (fmap pretty files) + GenesisCmdFilesDupIndex files -> + "The genesis keys files are expected to have a unique numeric index but these do not:\n" + <> vsep (fmap pretty files) + GenesisCmdTextEnvReadFileError fileErr -> + prettyError fileErr + GenesisCmdUnexpectedAddressVerificationKey (File file) expect got -> + mconcat + [ "Unexpected address verification key type in file ", pretty file + , ", expected: ", pretty expect, ", got: ", pretty (renderSomeAddressVerificationKey got) ] - GenesisCmdTooFewPoolsForBulkCreds pools files perPool -> mconcat - [ "Number of pools requested for generation (", show pools - , ") is insufficient to fill ", show files - , " bulk files, with ", show perPool, " pools per file." + GenesisCmdTooFewPoolsForBulkCreds pools files perPool -> + mconcat + [ "Number of pools requested for generation (", pshow pools + , ") is insufficient to fill ", pshow files + , " bulk files, with ", pshow perPool, " pools per file." ] - GenesisCmdAddressCmdError e -> - Text.unpack $ renderAddressCmdError e - GenesisCmdNodeCmdError e -> - Text.unpack $ renderNodeCmdError e - GenesisCmdStakePoolCmdError e -> - Text.unpack $ renderStakePoolCmdError e - GenesisCmdStakeAddressCmdError e -> - displayError e - GenesisCmdCostModelsError fp -> - "Cost model is invalid: " <> fp - GenesisCmdGenesisFileDecodeError fp e -> - "Error while decoding Shelley genesis at: " <> fp <> - " Error: " <> Text.unpack e - GenesisCmdGenesisFileReadError e -> displayError e - GenesisCmdByronError e -> show e - GenesisCmdStakePoolRelayFileError fp e -> - "Error occurred while reading the stake pool relay specification file: " <> fp <> - " Error: " <> show e - GenesisCmdStakePoolRelayJsonDecodeError fp e -> - "Error occurred while decoding the stake pool relay specification file: " <> fp <> - " Error: " <> e + GenesisCmdAddressCmdError e -> + renderAddressCmdError e + GenesisCmdNodeCmdError e -> + renderNodeCmdError e + GenesisCmdStakePoolCmdError e -> + renderStakePoolCmdError e + GenesisCmdStakeAddressCmdError e -> + prettyError e + GenesisCmdCostModelsError fp -> + "Cost model is invalid: " <> pretty fp + GenesisCmdGenesisFileDecodeError fp e -> + "Error while decoding Shelley genesis at: " <> pretty fp <> + " Error: " <> pretty e + GenesisCmdGenesisFileReadError e -> + prettyError e + GenesisCmdByronError e -> pshow e + GenesisCmdStakePoolRelayFileError fp e -> + "Error occurred while reading the stake pool relay specification file: " <> pretty fp <> + " Error: " <> pshow e + GenesisCmdStakePoolRelayJsonDecodeError fp e -> + "Error occurred while decoding the stake pool relay specification file: " <> pretty fp <> + " Error: " <> pretty e diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceActionsError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceActionsError.hs index 962bc54d2f..3a0feafd13 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceActionsError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceActionsError.hs @@ -5,6 +5,7 @@ module Cardano.CLI.Types.Errors.GovernanceActionsError ) where import Cardano.Api +import Cardano.Api.Pretty import Cardano.CLI.Read @@ -18,19 +19,19 @@ data GovernanceActionsError deriving Show instance Error GovernanceActionsError where - displayError = \case + prettyError = \case GovernanceActionsCmdProposalError e -> - "Cannot read proposal: " <> show e -- TODO Conway render this properly + "Cannot read proposal: " <> pshow e -- TODO Conway render this properly GovernanceActionsCmdConstitutionError e -> - "Cannot read constitution: " <> show e -- TODO Conway render this properly + "Cannot read constitution: " <> pshow e -- TODO Conway render this properly GovernanceActionsCmdReadFileError e -> - "Cannot read file: " <> displayError e + "Cannot read file: " <> prettyError e GovernanceActionsCmdReadTextEnvelopeFileError e -> - "Cannot read text envelope file: " <> displayError e + "Cannot read text envelope file: " <> prettyError e GovernanceActionsCmdWriteFileError e -> - "Cannot write file: " <> displayError e + "Cannot write file: " <> prettyError e GovernanceActionsValueUpdateProtocolParametersNotFound (AnyShelleyBasedEra expectedShelleyEra) -> mconcat - [ "Protocol parameters update value for " <> show (toCardanoEra expectedShelleyEra) + [ "Protocol parameters update value for " <> pshow (toCardanoEra expectedShelleyEra) , " was not found." ] diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCmdError.hs index 07d3878e62..cce1d5492d 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCmdError.hs @@ -5,6 +5,7 @@ module Cardano.CLI.Types.Errors.GovernanceCmdError where import Cardano.Api +import Cardano.Api.Pretty import Cardano.Api.Shelley import Cardano.Binary (DecoderError) @@ -14,8 +15,6 @@ import Cardano.CLI.Types.Errors.StakeAddressCmdError import qualified Data.List as List import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TL import qualified Formatting.Buildable as B @@ -60,60 +59,62 @@ data GovernanceCmdError deriving Show instance Error GovernanceCmdError where - displayError = \case + prettyError = \case StakeCredGovCmdError stakeAddressCmdError -> - "Stake credential error: " <> displayError stakeAddressCmdError + "Stake credential error: " <> prettyError stakeAddressCmdError VotingCredentialDecodeGovCmdEror decoderError -> "Could not decode voting credential: " <> renderDecoderError decoderError WriteFileError fileError -> - displayError fileError + prettyError fileError ReadFileError fileError -> - displayError fileError + prettyError fileError GovernanceCmdConstitutionError e -> - "Constitution error " <> show e -- TODO Conway render this properly + "Constitution error " <> pshow e -- TODO Conway render this properly GovernanceCmdHashError e -> - "Hash error " <> displayError e + "Hash error " <> prettyError e GovernanceCmdProposalError e -> - "Proposal error " <> show e -- TODO Conway render this properly + "Proposal error " <> pshow e -- TODO Conway render this properly GovernanceCmdTextEnvReadError fileError -> - "Cannot read text envelope: " <> displayError fileError + "Cannot read text envelope: " <> prettyError fileError GovernanceCmdCddlError cddlError -> - "Reading transaction CDDL file error: " <> displayError cddlError + "Reading transaction CDDL file error: " <> prettyError cddlError GovernanceCmdKeyReadError fileError -> - "Cannot read key: " <> displayError fileError + "Cannot read key: " <> prettyError fileError GovernanceCmdCostModelReadError fileError -> - "Cannot read cost model: " <> displayError fileError + "Cannot read cost model: " <> prettyError fileError GovernanceCmdTextEnvWriteError fileError -> - displayError fileError + prettyError fileError GovernanceCmdEmptyUpdateProposalError -> "Empty update proposals are not allowed." GovernanceCmdMIRCertificateKeyRewardMistmach fp nStakeVerKeys nRewards -> - "Error creating the MIR certificate at: " <> fp - <> " The number of staking keys: " <> show nStakeVerKeys - <> " and the number of reward amounts: " <> show nRewards + "Error creating the MIR certificate at: " <> pretty fp + <> " The number of staking keys: " <> pshow nStakeVerKeys + <> " and the number of reward amounts: " <> pshow nRewards <> " are not equivalent." GovernanceCmdCostModelsJsonDecodeErr fp msg -> - "Error decoding cost model: " <> Text.unpack msg <> " at: " <> fp + "Error decoding cost model: " <> pretty msg <> " at: " <> pretty fp GovernanceCmdEmptyCostModel fp -> - "The decoded cost model was empty at: " <> fp + "The decoded cost model was empty at: " <> pretty fp GovernanceCmdUnexpectedKeyType expectedTypes -> - "Unexpected poll key type; expected one of: " - <> List.intercalate ", " (show <$> expectedTypes) + mconcat + [ "Unexpected poll key type; expected one of: " + , mconcat $ List.intersperse ", " (pshow <$> expectedTypes) + ] GovernanceCmdPollOutOfBoundAnswer maxIdx -> - "Poll answer out of bounds. Choices are between 0 and " <> show maxIdx + "Poll answer out of bounds. Choices are between 0 and " <> pshow maxIdx GovernanceCmdPollInvalidChoice -> "Invalid choice. Please choose from the available answers." GovernanceCmdDecoderError decoderError -> "Unable to decode metadata: " <> renderDecoderError decoderError GovernanceCmdVerifyPollError pollError -> - Text.unpack (renderGovernancePollError pollError) + pretty $ renderGovernancePollError pollError GovernanceCmdWriteFileError fileError -> - "Cannot write file: " <> displayError fileError + "Cannot write file: " <> prettyError fileError GovernanceCmdDRepMetadataValidationError e -> - "DRep metadata validation error: " <> displayError e + "DRep metadata validation error: " <> prettyError e GovernanceCmdMIRCertNotSupportedInConway -> "MIR certificates are not supported in Conway era onwards." GovernanceCmdGenesisDelegationNotSupportedInConway -> "Genesis delegation is not supported in Conway era onwards." where - renderDecoderError = TL.unpack . TL.toLazyText . B.build + renderDecoderError = pretty . TL.toLazyText . B.build diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCommitteeError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCommitteeError.hs index f53a87d5b6..d2a1b0b2f9 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCommitteeError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCommitteeError.hs @@ -15,14 +15,14 @@ data GovernanceCommitteeError deriving Show instance Error GovernanceCommitteeError where - displayError = \case + prettyError = \case GovernanceCommitteeCmdKeyDecodeError e -> - "Cannot decode key: " <> displayError e + "Cannot decode key: " <> prettyError e GovernanceCommitteeCmdKeyReadError e -> - "Cannot read key: " <> displayError e + "Cannot read key: " <> prettyError e GovernanceCommitteeCmdWriteFileError e -> - "Cannot write file: " <> displayError e + "Cannot write file: " <> prettyError e GovernanceCommitteeCmdTextEnvReadFileError e -> - "Cannot read text envelope file: " <> displayError e + "Cannot read text envelope file: " <> prettyError e GovernanceCommitteeCmdTextEnvWriteError e -> - "Cannot write text envelope file: " <> displayError e + "Cannot write text envelope file: " <> prettyError e diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceHashError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceHashError.hs index f65c52453d..03061e0af2 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceHashError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceHashError.hs @@ -4,6 +4,7 @@ module Cardano.CLI.Types.Errors.GovernanceHashError ) where import Cardano.Api +import Cardano.Api.Pretty import Cardano.Prelude (Exception (displayException), IOException) @@ -13,8 +14,9 @@ data GovernanceHashError deriving Show instance Error GovernanceHashError where - displayError = \case + prettyError = \case GovernanceHashReadFileError filepath exc -> + "Cannot read " <> pretty filepath <> ": " <> pretty (displayException exc) "Cannot read " <> filepath <> ": " <> displayException exc GovernanceHashWriteFileError fileErr -> displayError fileErr diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceQueryError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceQueryError.hs index e02b362e4d..eaae47d401 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceQueryError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceQueryError.hs @@ -2,10 +2,13 @@ module Cardano.CLI.Types.Errors.GovernanceQueryError where import Cardano.Api +import Cardano.Api.Pretty import Cardano.Api.Shelley import Ouroboros.Consensus.Cardano.Block (EraMismatch) +import Prettyprinter + data GovernanceQueryError = GovernanceQueryWriteFileError !(FileError ()) | GovernanceQueryAcqireFailureError !AcquiringFailure @@ -15,17 +18,18 @@ data GovernanceQueryError deriving Show instance Error GovernanceQueryError where - displayError = \case + prettyError = \case GovernanceQueryWriteFileError err -> - displayError err + prettyError err GovernanceQueryAcqireFailureError err -> - show err - GovernanceQueryUnsupportedNtcVersion (UnsupportedNtcVersionError minNtcVersion ntcVersion) -> unlines - [ "Unsupported feature for the node-to-client protocol version." - , "This query requires at least " <> show minNtcVersion <> " but the node negotiated " <> show ntcVersion <> "." - , "Later node versions support later protocol versions (but development protocol versions are not enabled in the node by default)." - ] + pshow err + GovernanceQueryUnsupportedNtcVersion (UnsupportedNtcVersionError minNtcVersion ntcVersion) -> + vsep + [ "Unsupported feature for the node-to-client protocol version." + , "This query requires at least " <> pshow minNtcVersion <> " but the node negotiated " <> pshow ntcVersion <> "." + , "Later node versions support later protocol versions (but development protocol versions are not enabled in the node by default)." + ] GovernanceQueryEraMismatch err -> - "A query from a certain era was applied to a ledger from a different era: " <> show err + "A query from a certain era was applied to a ledger from a different era: " <> pshow err GovernanceQueryDRepKeyError err -> - "Error reading delegation representative key: " <> displayError err + "Error reading delegation representative key: " <> prettyError err diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceVoteCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceVoteCmdError.hs index b35b3788b4..2cca84fe12 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceVoteCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceVoteCmdError.hs @@ -9,9 +9,9 @@ import Cardano.Api.Shelley import Cardano.Binary (DecoderError) import Cardano.CLI.Read (VoteError) -import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TL import qualified Formatting.Buildable as B +import Prettyprinter data GovernanceVoteCmdError = GovernanceVoteCmdReadVerificationKeyError !(FileError InputDecodeError) @@ -22,16 +22,16 @@ data GovernanceVoteCmdError deriving Show instance Error GovernanceVoteCmdError where - displayError = \case + prettyError = \case GovernanceVoteCmdReadVerificationKeyError e -> - "Cannot read verification key: " <> displayError e + "Cannot read verification key: " <> prettyError e GovernanceVoteCmdReadVoteFileError e -> - "Cannot read vote file: " <> displayError e + "Cannot read vote file: " <> prettyError e GovernanceVoteCmdCredentialDecodeError e -> "Cannot decode voting credential: " <> renderDecoderError e GovernanceVoteCmdWriteError e -> - "Cannot write vote: " <> displayError e + "Cannot write vote: " <> prettyError e GovernanceVoteCmdReadVoteTextError e -> - "Cannot read vote text: " <> displayError e + "Cannot read vote text: " <> prettyError e where - renderDecoderError = TL.unpack . TL.toLazyText . B.build + renderDecoderError = pretty . TL.toLazyText . B.build diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/ItnKeyConversionError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/ItnKeyConversionError.hs index 74c8c69352..62a8c221ba 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/ItnKeyConversionError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/ItnKeyConversionError.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,12 +10,11 @@ module Cardano.CLI.Types.Errors.ItnKeyConversionError ) where import Cardano.Api +import Cardano.Api.Pretty import Control.Exception (Exception (..), IOException) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BSC -import Data.Text (Text) -import qualified Data.Text as Text -- | An error that can occur while converting an Incentivized Testnet (ITN) -- key. @@ -26,17 +26,16 @@ data ItnKeyConversionError deriving Show -- | Render an error message for an 'ItnKeyConversionError'. -renderConversionError :: ItnKeyConversionError -> Text -renderConversionError err = - case err of - ItnKeyBech32DecodeError decErr -> - "Error decoding Bech32 key: " <> Text.pack (displayError decErr) - ItnReadBech32FileError fp readErr -> - "Error reading Bech32 key at: " <> textShow fp - <> " Error: " <> Text.pack (displayException readErr) - ItnSigningKeyDeserialisationError _sKey -> - -- Sensitive data, such as the signing key, is purposely not included in - -- the error message. - "Error deserialising signing key." - ItnVerificationKeyDeserialisationError vKey -> - "Error deserialising verification key: " <> textShow (BSC.unpack vKey) +renderConversionError :: ItnKeyConversionError -> Doc ann +renderConversionError = \case + ItnKeyBech32DecodeError decErr -> + "Error decoding Bech32 key: " <> prettyError decErr + ItnReadBech32FileError fp readErr -> + "Error reading Bech32 key at: " <> pshow fp + <> " Error: " <> pshow (displayException readErr) + ItnSigningKeyDeserialisationError _sKey -> + -- Sensitive data, such as the signing key, is purposely not included in + -- the error message. + "Error deserialising signing key." + ItnVerificationKeyDeserialisationError vKey -> + "Error deserialising verification key: " <> pshow (BSC.unpack vKey) diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/KeyCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/KeyCmdError.hs index 0cd573ed55..3b498c1c9a 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/KeyCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/KeyCmdError.hs @@ -9,6 +9,7 @@ module Cardano.CLI.Types.Errors.KeyCmdError ) where import Cardano.Api +import Cardano.Api.Pretty import qualified Cardano.CLI.Byron.Key as Byron import Cardano.CLI.Types.Errors.CardanoAddressSigningKeyConversionError @@ -16,7 +17,6 @@ import Cardano.CLI.Types.Errors.ItnKeyConversionError import Cardano.CLI.Types.Key import Data.Text (Text) -import qualified Data.Text as Text data KeyCmdError = KeyCmdReadFileError !(FileError TextEnvelopeError) @@ -36,21 +36,28 @@ data KeyCmdError | KeyCmdVerificationKeyReadError VerificationKeyTextOrFileError deriving Show -renderKeyCmdError :: KeyCmdError -> Text +renderKeyCmdError :: KeyCmdError -> Doc ann renderKeyCmdError err = case err of - KeyCmdReadFileError fileErr -> Text.pack (displayError fileErr) - KeyCmdReadKeyFileError fileErr -> Text.pack (displayError fileErr) - KeyCmdWriteFileError fileErr -> Text.pack (displayError fileErr) - KeyCmdByronKeyFailure e -> Byron.renderByronKeyFailure e - KeyCmdByronKeyParseError errTxt -> errTxt - KeyCmdItnKeyConvError convErr -> renderConversionError convErr + KeyCmdReadFileError fileErr -> + prettyError fileErr + KeyCmdReadKeyFileError fileErr -> + prettyError fileErr + KeyCmdWriteFileError fileErr -> + prettyError fileErr + KeyCmdByronKeyFailure e -> + Byron.renderByronKeyFailure e + KeyCmdByronKeyParseError errTxt -> + pretty errTxt + KeyCmdItnKeyConvError convErr -> + renderConversionError convErr KeyCmdWrongKeyTypeError -> - Text.pack "Please use a signing key file when converting ITN BIP32 or Extended keys" + "Please use a signing key file when converting ITN BIP32 or Extended keys" KeyCmdCardanoAddressSigningKeyFileError fileErr -> - Text.pack (displayError fileErr) + prettyError fileErr KeyCmdNonLegacyKey fp -> - "Signing key at: " <> Text.pack fp <> " is not a legacy Byron signing key and should not need to be converted." - KeyCmdVerificationKeyReadError e -> renderVerificationKeyTextOrFileError e + "Signing key at: " <> pretty fp <> " is not a legacy Byron signing key and should not need to be converted." + KeyCmdVerificationKeyReadError e -> + renderVerificationKeyTextOrFileError e KeyCmdExpectedExtendedVerificationKey someVerKey -> - "Expected an extended verification key but got: " <> renderSomeAddressVerificationKey someVerKey + "Expected an extended verification key but got: " <> pretty (renderSomeAddressVerificationKey someVerKey) diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/NodeCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/NodeCmdError.hs index 0eddacbee2..08ac21b308 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/NodeCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/NodeCmdError.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.NodeCmdError ( NodeCmdError(..) @@ -6,9 +7,7 @@ module Cardano.CLI.Types.Errors.NodeCmdError ) where import Cardano.Api - -import Data.Text (Text) -import qualified Data.Text as Text +import Cardano.Api.Pretty {- HLINT ignore "Reduce duplication" -} @@ -24,18 +23,16 @@ data NodeCmdError -- ^ Temp path deriving Show -renderNodeCmdError :: NodeCmdError -> Text -renderNodeCmdError err = - case err of +renderNodeCmdError :: NodeCmdError -> Doc ann +renderNodeCmdError = \case NodeCmdVrfSigningKeyCreationError targetPath tempPath -> - Text.pack $ "Error creating VRF signing key file. Target path: " <> targetPath - <> " Temporary path: " <> tempPath - - NodeCmdReadFileError fileErr -> Text.pack (displayError fileErr) - - NodeCmdReadKeyFileError fileErr -> Text.pack (displayError fileErr) - - NodeCmdWriteFileError fileErr -> Text.pack (displayError fileErr) - + "Error creating VRF signing key file. Target path: " <> pshow targetPath + <> " Temporary path: " <> pshow tempPath + NodeCmdReadFileError fileErr -> + prettyError fileErr + NodeCmdReadKeyFileError fileErr -> + prettyError fileErr + NodeCmdWriteFileError fileErr -> + prettyError fileErr NodeCmdOperationalCertificateIssueError issueErr -> - Text.pack (displayError issueErr) + prettyError issueErr diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/ProtocolParamsError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/ProtocolParamsError.hs index 44b766cfd4..91490aef6c 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/ProtocolParamsError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/ProtocolParamsError.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,16 +10,17 @@ module Cardano.CLI.Types.Errors.ProtocolParamsError ) where import Cardano.Api +import Cardano.Api.Pretty import Data.Text (Text) -import qualified Data.Text as Text data ProtocolParamsError = ProtocolParamsErrorFile (FileError ()) | ProtocolParamsErrorJSON !FilePath !Text -renderProtocolParamsError :: ProtocolParamsError -> Text -renderProtocolParamsError (ProtocolParamsErrorFile fileErr) = - Text.pack $ displayError fileErr -renderProtocolParamsError (ProtocolParamsErrorJSON fp jsonErr) = - "Error while decoding the protocol parameters at: " <> Text.pack fp <> " Error: " <> jsonErr +renderProtocolParamsError :: ProtocolParamsError -> Doc ann +renderProtocolParamsError = \case + ProtocolParamsErrorFile fileErr -> + prettyError fileErr + ProtocolParamsErrorJSON fp jsonErr -> + "Error while decoding the protocol parameters at: " <> pshow fp <> " Error: " <> pshow jsonErr diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdError.hs index f11530fa23..a46e3353c7 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdError.hs @@ -14,6 +14,7 @@ module Cardano.CLI.Types.Errors.QueryCmdError ) where import Cardano.Api hiding (QueryInShelleyBasedEra (..)) +import Cardano.Api.Pretty import Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..)) import Cardano.Binary (DecoderError) @@ -24,9 +25,6 @@ import Ouroboros.Consensus.Cardano.Block as Consensus (EraMismatch (.. import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry import qualified Data.ByteString.Lazy.Char8 as LBS -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (toLazyText) import Formatting.Buildable (build) @@ -58,39 +56,52 @@ data QueryCmdError | QueryCmdCommitteeHotKeyError !(FileError InputDecodeError) deriving Show -renderQueryCmdError :: QueryCmdError -> Text +renderQueryCmdError :: QueryCmdError -> Doc ann renderQueryCmdError = \case - QueryCmdLocalStateQueryError lsqErr -> renderLocalStateQueryError lsqErr - QueryCmdWriteFileError fileErr -> Text.pack (displayError fileErr) - QueryCmdHelpersError helpersErr -> renderHelpersError helpersErr - QueryCmdAcquireFailure acquireFail -> Text.pack $ show acquireFail - QueryCmdByronEra -> "This query cannot be used for the Byron era" + QueryCmdLocalStateQueryError lsqErr -> + renderLocalStateQueryError lsqErr + QueryCmdWriteFileError fileErr -> + prettyError fileErr + QueryCmdHelpersError helpersErr -> + renderHelpersError helpersErr + QueryCmdAcquireFailure acquireFail -> + pshow acquireFail + QueryCmdByronEra -> + "This query cannot be used for the Byron era" QueryCmdEraMismatch (EraMismatch ledgerEra queryEra) -> - "\nAn error mismatch occurred." <> "\nSpecified query era: " <> queryEra <> - "\nCurrent ledger era: " <> ledgerEra - QueryCmdPastHorizon e -> "Past horizon: " <> textShow e - QueryCmdSystemStartUnavailable -> "System start unavailable" - QueryCmdGenesisReadError err' -> Text.pack $ displayError err' - QueryCmdLeaderShipError e -> Text.pack $ displayError e - QueryCmdTextEnvelopeReadError e -> Text.pack $ displayError e - QueryCmdTextReadError e -> Text.pack $ displayError e - QueryCmdOpCertCounterReadError e -> Text.pack $ displayError e + "\nAn error mismatch occurred." <> "\nSpecified query era: " <> pretty queryEra <> + "\nCurrent ledger era: " <> pretty ledgerEra + QueryCmdPastHorizon e -> + "Past horizon: " <> pshow e + QueryCmdSystemStartUnavailable -> + "System start unavailable" + QueryCmdGenesisReadError err' -> + prettyError err' + QueryCmdLeaderShipError e -> + prettyError e + QueryCmdTextEnvelopeReadError e -> + prettyError e + QueryCmdTextReadError e -> + prettyError e + QueryCmdOpCertCounterReadError e -> + prettyError e QueryCmdProtocolStateDecodeFailure (_, decErr) -> - "Failed to decode the protocol state: " <> toStrict (toLazyText $ build decErr) + "Failed to decode the protocol state: " <> pretty (toLazyText $ build decErr) QueryCmdPoolStateDecodeError decoderError -> - "Failed to decode PoolState. Error: " <> Text.pack (show decoderError) + "Failed to decode PoolState. Error: " <> pshow decoderError QueryCmdStakeSnapshotDecodeError decoderError -> - "Failed to decode StakeSnapshot. Error: " <> Text.pack (show decoderError) + "Failed to decode StakeSnapshot. Error: " <> pshow decoderError QueryCmdUnsupportedNtcVersion (UnsupportedNtcVersionError minNtcVersion ntcVersion) -> "Unsupported feature for the node-to-client protocol version.\n" <> - "This query requires at least " <> textShow minNtcVersion <> " but the node negotiated " <> textShow ntcVersion <> ".\n" <> + "This query requires at least " <> pshow minNtcVersion <> " but the node negotiated " <> pshow ntcVersion <> ".\n" <> "Later node versions support later protocol versions (but development protocol versions are not enabled in the node by default)." QueryCmdProtocolParameterConversionError ppce -> - Text.pack $ "Failed to convert protocol parameter: " <> displayError ppce - QueryCmdConvenienceError qce -> renderQueryConvenienceError qce + "Failed to convert protocol parameter: " <> prettyError ppce + QueryCmdConvenienceError qce -> + pretty $ renderQueryConvenienceError qce QueryCmdDRepKeyError e -> - "Error reading delegation representative key: " <> Text.pack (displayError e) + "Error reading delegation representative key: " <> prettyError e QueryCmdCommitteeColdKeyError e -> - "Error reading committee cold key: " <> Text.pack (displayError e) + "Error reading committee cold key: " <> prettyError e QueryCmdCommitteeHotKeyError e -> - "Error reading committee hot key: " <> Text.pack (displayError e) + "Error reading committee hot key: " <> prettyError e diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdLocalStateQueryError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdLocalStateQueryError.hs index 1e4fec2f8e..47b2f271c8 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdLocalStateQueryError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdLocalStateQueryError.hs @@ -1,14 +1,14 @@ +{-# LANGUAGE LambdaCase #-} + module Cardano.CLI.Types.Errors.QueryCmdLocalStateQueryError ( QueryCmdLocalStateQueryError(..) , renderLocalStateQueryError ) where -import Cardano.Api +import Cardano.Api.Pretty import Ouroboros.Consensus.Cardano.Block (EraMismatch (..)) -import Data.Text (Text) - -- | An error that can occur while querying a node's local state. newtype QueryCmdLocalStateQueryError = EraMismatchError EraMismatch @@ -16,8 +16,7 @@ newtype QueryCmdLocalStateQueryError -- era. deriving (Eq, Show) -renderLocalStateQueryError :: QueryCmdLocalStateQueryError -> Text -renderLocalStateQueryError lsqErr = - case lsqErr of - EraMismatchError err -> - "A query from a certain era was applied to a ledger from a different era: " <> textShow err +renderLocalStateQueryError :: QueryCmdLocalStateQueryError -> Doc ann +renderLocalStateQueryError = \case + EraMismatchError err -> + "A query from a certain era was applied to a ledger from a different era: " <> pshow err diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/RegistrationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/RegistrationError.hs index 3aa2cdf664..1336f3e1a7 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/RegistrationError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/RegistrationError.hs @@ -17,12 +17,12 @@ data RegistrationError deriving Show instance Error RegistrationError where - displayError = \case + prettyError = \case RegistrationReadError e -> - "Cannot read registration certificate: " <> displayError e + "Cannot read registration certificate: " <> prettyError e RegistrationWriteFileError e -> - "Cannot write registration certificate: " <> displayError e + "Cannot write registration certificate: " <> prettyError e RegistrationStakeCredentialError e -> - "Cannot read stake credential: " <> displayError e + "Cannot read stake credential: " <> prettyError e RegistrationStakeError e -> - "Stake address registation error: " <> displayError e + "Stake address registation error: " <> prettyError e diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/ScriptDecodeError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/ScriptDecodeError.hs index 24081cd177..9ab441eade 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/ScriptDecodeError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/ScriptDecodeError.hs @@ -16,8 +16,8 @@ data ScriptDecodeError = deriving Show instance Error ScriptDecodeError where - displayError = \case + prettyError = \case ScriptDecodeTextEnvelopeError err -> - "Error decoding script: " ++ displayError err + "Error decoding script: " <> prettyError err ScriptDecodeSimpleScriptError err -> - "Syntax error in script: " ++ displayError err + "Syntax error in script: " <> prettyError err diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressCmdError.hs index f0abec87c2..077cd19007 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressCmdError.hs @@ -6,10 +6,10 @@ module Cardano.CLI.Types.Errors.StakeAddressCmdError import Cardano.Api +import Cardano.CLI.Types.Errors.DelegationError import Cardano.CLI.Types.Errors.ScriptDecodeError import Cardano.CLI.Types.Errors.StakeAddressRegistrationError import Cardano.CLI.Types.Errors.StakeCredentialError -import Cardano.CLI.Types.Errors.DelegationError data StakeAddressCmdError = StakeAddressCmdReadKeyFileError !(FileError InputDecodeError) @@ -21,10 +21,10 @@ data StakeAddressCmdError deriving Show instance Error StakeAddressCmdError where - displayError = \case - StakeAddressCmdReadKeyFileError e -> displayError e - StakeAddressCmdReadScriptFileError e -> displayError e - StakeAddressCmdStakeCredentialError e -> displayError e - StakeAddressCmdWriteFileError e -> displayError e - StakeAddressCmdDelegationError e -> displayError e - StakeAddressCmdRegistrationError e -> displayError e + prettyError = \case + StakeAddressCmdReadKeyFileError e -> prettyError e + StakeAddressCmdReadScriptFileError e -> prettyError e + StakeAddressCmdStakeCredentialError e -> prettyError e + StakeAddressCmdWriteFileError e -> prettyError e + StakeAddressCmdDelegationError e -> prettyError e + StakeAddressCmdRegistrationError e -> prettyError e diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressDelegationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressDelegationError.hs index 1586b4a3f8..aa6eb4c44e 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressDelegationError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressDelegationError.hs @@ -6,14 +6,15 @@ module Cardano.CLI.Types.Errors.StakeAddressDelegationError ) where import Cardano.Api +import Cardano.Api.Pretty import qualified Data.Text as Text newtype StakeAddressDelegationError = VoteDelegationNotSupported (EraInEon ShelleyToBabbageEra) deriving Show instance Error StakeAddressDelegationError where - displayError = \case - VoteDelegationNotSupported (EraInEon eraInEon) -> "Vote delegation not supported in " <> eraTxt <> " era." + prettyError = \case + VoteDelegationNotSupported (EraInEon eraInEon) -> "Vote delegation not supported in " <> pshow eraTxt <> " era." where cEra = toCardanoEra eraInEon eraTxt = cardanoEraConstraints cEra $ Text.unpack . renderEra $ AnyCardanoEra cEra diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressRegistrationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressRegistrationError.hs index 9262164bb0..a32eae31cb 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressRegistrationError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressRegistrationError.hs @@ -10,5 +10,5 @@ data StakeAddressRegistrationError = StakeAddressRegistrationDepositRequired deriving Show instance Error StakeAddressRegistrationError where - displayError = \case + prettyError = \case StakeAddressRegistrationDepositRequired -> "Stake address deposit required." diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeCredentialError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeCredentialError.hs index c2954f22be..83e0db13ed 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeCredentialError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeCredentialError.hs @@ -14,6 +14,8 @@ data StakeCredentialError deriving Show instance Error StakeCredentialError where - displayError = \case - StakeCredentialScriptDecodeError e -> displayError e - StakeCredentialInputDecodeError e -> displayError e + prettyError = \case + StakeCredentialScriptDecodeError e -> + prettyError e + StakeCredentialInputDecodeError e -> + prettyError e diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/StakePoolCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/StakePoolCmdError.hs index f4fab7ae66..b10526f92f 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/StakePoolCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/StakePoolCmdError.hs @@ -10,8 +10,7 @@ module Cardano.CLI.Types.Errors.StakePoolCmdError import Cardano.Api -import Data.Text (Text) -import qualified Data.Text as Text +import Prettyprinter data StakePoolCmdError = StakePoolCmdReadFileError !(FileError TextEnvelopeError) @@ -20,13 +19,13 @@ data StakePoolCmdError | StakePoolCmdMetadataValidationError !StakePoolMetadataValidationError deriving Show -renderStakePoolCmdError :: StakePoolCmdError -> Text +renderStakePoolCmdError :: StakePoolCmdError -> Doc ann renderStakePoolCmdError = \case StakePoolCmdMetadataValidationError validationErr -> - "Error validating stake pool metadata: " <> Text.pack (displayError validationErr) + "Error validating stake pool metadata: " <> prettyError validationErr StakePoolCmdReadFileError fileErr -> - Text.pack (displayError fileErr) + prettyError fileErr StakePoolCmdReadKeyFileError fileErr -> - Text.pack (displayError fileErr) + prettyError fileErr StakePoolCmdWriteFileError fileErr -> - Text.pack (displayError fileErr) + prettyError fileErr diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TextViewFileError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TextViewFileError.hs index e3ecd15b7c..caba8b44b0 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TextViewFileError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TextViewFileError.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.TextViewFileError ( TextViewFileError(..) @@ -9,17 +10,16 @@ import Cardano.Api import Cardano.CLI.Helpers (HelpersError, renderHelpersError) -import Data.Text (Text) -import qualified Data.Text as Text +import Prettyprinter data TextViewFileError = TextViewReadFileError (FileError TextEnvelopeError) | TextViewCBORPrettyPrintError !HelpersError deriving Show -renderTextViewFileError :: TextViewFileError -> Text -renderTextViewFileError err = - case err of - TextViewReadFileError fileErr -> Text.pack (displayError fileErr) - TextViewCBORPrettyPrintError hlprsErr -> - "Error pretty printing CBOR: " <> renderHelpersError hlprsErr +renderTextViewFileError :: TextViewFileError -> Doc ann +renderTextViewFileError = \case + TextViewReadFileError fileErr -> + prettyError fileErr + TextViewCBORPrettyPrintError hlprsErr -> + "Error pretty printing CBOR: " <> renderHelpersError hlprsErr diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs index 6df48f652d..975be200ca 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -11,6 +12,7 @@ module Cardano.CLI.Types.Errors.TxCmdError ) where import Cardano.Api +import Cardano.Api.Pretty import Cardano.Api.Shelley import Cardano.CLI.Read @@ -21,10 +23,10 @@ import Cardano.CLI.Types.Errors.ProtocolParamsError import Cardano.CLI.Types.Errors.TxValidationError import Cardano.CLI.Types.Output import Cardano.CLI.Types.TxFeature +import qualified Cardano.Prelude as List import Ouroboros.Consensus.Cardano.Block (EraMismatch (..)) import Data.Text (Text) -import qualified Data.Text as Text {- HLINT ignore "Use let" -} @@ -81,119 +83,139 @@ data TxCmdError | TxCmdScriptValidityValidationError TxScriptValidityValidationError | TxCmdProtocolParamsConverstionError ProtocolParametersConversionError -renderTxCmdError :: TxCmdError -> Text -renderTxCmdError err = - case err of - TxCmdProtocolParamsConverstionError err' -> - "Error while converting protocol parameters: " <> Text.pack (displayError err') - TxCmdVoteError voteErr -> Text.pack $ show voteErr - TxCmdConstitutionError constErr -> Text.pack $ show constErr - TxCmdReadTextViewFileError fileErr -> Text.pack (displayError fileErr) - TxCmdScriptFileError fileErr -> Text.pack (displayError fileErr) - TxCmdReadWitnessSigningDataError witSignDataErr -> - renderReadWitnessSigningDataError witSignDataErr - TxCmdWriteFileError fileErr -> Text.pack (displayError fileErr) - TxCmdTxSubmitError res -> "Error while submitting tx: " <> res - TxCmdTxSubmitErrorEraMismatch EraMismatch{ledgerEraName, otherEraName} -> - "The era of the node and the tx do not match. " <> - "The node is running in the " <> ledgerEraName <> - " era, but the transaction is for the " <> otherEraName <> " era." - TxCmdBootstrapWitnessError sbwErr -> - renderBootstrapWitnessError sbwErr - TxCmdTxFeatureMismatch era TxFeatureImplicitFees -> - "An explicit transaction fee must be specified for " <> - renderEra era <> " era transactions." +renderTxCmdError :: TxCmdError -> Doc ann +renderTxCmdError = \case + TxCmdProtocolParamsConverstionError err' -> + "Error while converting protocol parameters: " <> prettyError err' + TxCmdVoteError voteErr -> + pshow voteErr + TxCmdConstitutionError constErr -> + pshow constErr + TxCmdReadTextViewFileError fileErr -> + prettyError fileErr + TxCmdScriptFileError fileErr -> + prettyError fileErr + TxCmdReadWitnessSigningDataError witSignDataErr -> + renderReadWitnessSigningDataError witSignDataErr + TxCmdWriteFileError fileErr -> + prettyError fileErr + TxCmdTxSubmitError res -> + "Error while submitting tx: " <> pretty res + TxCmdTxSubmitErrorEraMismatch EraMismatch{ledgerEraName, otherEraName} -> + "The era of the node and the tx do not match. " <> + "The node is running in the " <> pretty ledgerEraName <> + " era, but the transaction is for the " <> pretty otherEraName <> " era." + TxCmdBootstrapWitnessError sbwErr -> + renderBootstrapWitnessError sbwErr + TxCmdTxFeatureMismatch era TxFeatureImplicitFees -> + "An explicit transaction fee must be specified for " <> + pretty (renderEra era) <> " era transactions." - TxCmdTxFeatureMismatch (AnyCardanoEra ShelleyEra) - TxFeatureValidityNoUpperBound -> - "A TTL must be specified for Shelley era transactions." + TxCmdTxFeatureMismatch (AnyCardanoEra ShelleyEra) TxFeatureValidityNoUpperBound -> + "A TTL must be specified for Shelley era transactions." - TxCmdTxFeatureMismatch era feature -> - renderFeature feature <> " cannot be used for " <> renderEra era <> - " era transactions." + TxCmdTxFeatureMismatch era feature -> + pretty (renderFeature feature) <> " cannot be used for " <> pretty (renderEra era) <> + " era transactions." - TxCmdTxBodyError err' -> - "Transaction validaton error: " <> Text.pack (displayError err') + TxCmdTxBodyError err' -> + "Transaction validaton error: " <> prettyError err' - TxCmdNotImplemented msg -> - "Feature not yet implemented: " <> msg + TxCmdNotImplemented msg -> + "Feature not yet implemented: " <> pretty msg - TxCmdWitnessEraMismatch era era' (WitnessFile file) -> - "The era of a witness does not match the era of the transaction. " <> - "The transaction is for the " <> renderEra era <> " era, but the " <> - "witness in " <> textShow file <> " is for the " <> renderEra era' <> " era." + TxCmdWitnessEraMismatch era era' (WitnessFile file) -> + "The era of a witness does not match the era of the transaction. " <> + "The transaction is for the " <> pretty (renderEra era) <> " era, but the " <> + "witness in " <> pshow file <> " is for the " <> pretty (renderEra era') <> " era." - TxCmdPolicyIdsMissing policyids -> mconcat - [ "The \"--mint\" flag specifies an asset with a policy Id, but no " - , "corresponding monetary policy script has been provided as a witness " - , "(via the \"--mint-script-file\" flag). The policy Id in question is: " - , Text.intercalate ", " (map serialiseToRawBytesHexText policyids) - ] + TxCmdPolicyIdsMissing policyids -> + mconcat + [ "The \"--mint\" flag specifies an asset with a policy Id, but no " + , "corresponding monetary policy script has been provided as a witness " + , "(via the \"--mint-script-file\" flag). The policy Id in question is: " + , mconcat $ List.intersperse ", " (map (pretty . serialiseToRawBytesHexText) policyids) + ] - TxCmdPolicyIdsExcess policyids -> mconcat - [ "A script provided to witness minting does not correspond to the policy " - , "id of any asset specified in the \"--mint\" field. The script hash is: " - , Text.intercalate ", " (map serialiseToRawBytesHexText policyids) - ] - TxCmdByronEra -> "This query cannot be used for the Byron era" - TxCmdBalanceTxBody err' -> Text.pack $ displayError err' - TxCmdTxInsDoNotExist e -> - renderTxInsExistError e - TxCmdPParamsErr err' -> Text.pack $ displayError err' - TxCmdTextEnvCddlError textEnvErr cddlErr -> mconcat - [ "Failed to decode neither the cli's serialisation format nor the ledger's " - , "CDDL serialisation format. TextEnvelope error: " <> Text.pack (displayError textEnvErr) <> "\n" - , "TextEnvelopeCddl error: " <> Text.pack (displayError cddlErr) + TxCmdPolicyIdsExcess policyids -> + mconcat + [ "A script provided to witness minting does not correspond to the policy " + , "id of any asset specified in the \"--mint\" field. The script hash is: " + , mconcat $ List.intersperse ", " (map (pretty . serialiseToRawBytesHexText) policyids) + ] + TxCmdByronEra -> + "This query cannot be used for the Byron era" + TxCmdBalanceTxBody err' -> + prettyError err' + TxCmdTxInsDoNotExist e -> + pretty $ renderTxInsExistError e + TxCmdPParamsErr err' -> + prettyError err' + TxCmdTextEnvCddlError textEnvErr cddlErr -> + mconcat + [ "Failed to decode neither the cli's serialisation format nor the ledger's " + , "CDDL serialisation format. TextEnvelope error: " <> prettyError textEnvErr <> "\n" + , "TextEnvelopeCddl error: " <> prettyError cddlErr + ] + TxCmdTxExecUnitsErr err' -> + prettyError err' + TxCmdPlutusScriptCostErr err'-> + prettyError err' + TxCmdPParamExecutionUnitsNotAvailable -> + mconcat + [ "Execution units not available in the protocol parameters. This is " + , "likely due to not being in the Alonzo era" + ] + TxCmdTxNodeEraMismatchError (NodeEraMismatchError nodeEra valueEra) -> + cardanoEraConstraints nodeEra $ cardanoEraConstraints valueEra $ mconcat + [ "Transactions can only be produced in the same era as the node. Requested era: " + , pretty (renderEra (AnyCardanoEra valueEra)) <> ", node era: " + , pretty (renderEra (AnyCardanoEra nodeEra)) <> "." ] - TxCmdTxExecUnitsErr err' -> Text.pack $ displayError err' - TxCmdPlutusScriptCostErr err'-> Text.pack $ displayError err' - TxCmdPParamExecutionUnitsNotAvailable -> mconcat - [ "Execution units not available in the protocol parameters. This is " - , "likely due to not being in the Alonzo era" - ] - TxCmdTxNodeEraMismatchError (NodeEraMismatchError nodeEra valueEra) -> - cardanoEraConstraints nodeEra $ cardanoEraConstraints valueEra $ mconcat - [ "Transactions can only be produced in the same era as the node. Requested era: " - , renderEra (AnyCardanoEra valueEra) <> ", node era: " - , renderEra (AnyCardanoEra nodeEra) <> "." - ] - TxCmdQueryConvenienceError e -> - renderQueryConvenienceError e - TxCmdQueryNotScriptLocked e -> - renderNotScriptLockedTxInsError e - TxCmdPlutusScriptsRequireCardanoMode -> - "Plutus scripts are only available in CardanoMode" - TxCmdProtocolParametersNotPresentInTxBody -> - "Protocol parameters were not found in transaction body" - TxCmdMetadataError e -> renderMetadataError e - TxCmdScriptWitnessError e -> renderScriptWitnessError e - TxCmdScriptDataError e -> renderScriptDataError e - TxCmdProtocolParamsError e -> renderProtocolParamsError e - TxCmdCddlError e -> Text.pack $ displayError e - TxCmdCddlWitnessError e -> Text.pack $ displayError e - TxCmdRequiredSignerError e -> Text.pack $ displayError e - -- Validation errors - TxCmdAuxScriptsValidationError e -> - Text.pack $ displayError e - TxCmdTotalCollateralValidationError e -> - Text.pack $ displayError e - TxCmdReturnCollateralValidationError e -> - Text.pack $ displayError e - TxCmdTxFeeValidationError e -> - Text.pack $ displayError e - TxCmdTxValidityLowerBoundValidationError e -> - Text.pack $ displayError e - TxCmdTxValidityUpperBoundValidationError e -> - Text.pack $ displayError e - TxCmdRequiredSignersValidationError e -> - Text.pack $ displayError e - TxCmdProtocolParametersValidationError e -> - Text.pack $ displayError e - TxCmdTxWithdrawalsValidationError e -> - Text.pack $ displayError e - TxCmdTxCertificatesValidationError e -> - Text.pack $ displayError e - TxCmdTxUpdateProposalValidationError e -> - Text.pack $ displayError e - TxCmdScriptValidityValidationError e -> - Text.pack $ displayError e + TxCmdQueryConvenienceError e -> + pretty $ renderQueryConvenienceError e + TxCmdQueryNotScriptLocked e -> + pretty $ renderNotScriptLockedTxInsError e + TxCmdPlutusScriptsRequireCardanoMode -> + "Plutus scripts are only available in CardanoMode" + TxCmdProtocolParametersNotPresentInTxBody -> + "Protocol parameters were not found in transaction body" + TxCmdMetadataError e -> + renderMetadataError e + TxCmdScriptWitnessError e -> + renderScriptWitnessError e + TxCmdScriptDataError e -> + renderScriptDataError e + TxCmdProtocolParamsError e -> + renderProtocolParamsError e + TxCmdCddlError e -> + prettyError e + TxCmdCddlWitnessError e -> + prettyError e + TxCmdRequiredSignerError e -> + prettyError e + -- Validation errors + TxCmdAuxScriptsValidationError e -> + prettyError e + TxCmdTotalCollateralValidationError e -> + prettyError e + TxCmdReturnCollateralValidationError e -> + prettyError e + TxCmdTxFeeValidationError e -> + prettyError e + TxCmdTxValidityLowerBoundValidationError e -> + prettyError e + TxCmdTxValidityUpperBoundValidationError e -> + prettyError e + TxCmdRequiredSignersValidationError e -> + prettyError e + TxCmdProtocolParametersValidationError e -> + prettyError e + TxCmdTxWithdrawalsValidationError e -> + prettyError e + TxCmdTxCertificatesValidationError e -> + prettyError e + TxCmdTxUpdateProposalValidationError e -> + prettyError e + TxCmdScriptValidityValidationError e -> + prettyError e diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs index b825dda6a4..dc7af5cae1 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs @@ -36,6 +36,7 @@ module Cardano.CLI.Types.Errors.TxValidationError import Cardano.Api import qualified Cardano.Api.Ledger as L +import Cardano.Api.Pretty import Cardano.Api.Shelley import Cardano.CLI.Types.Common @@ -45,16 +46,16 @@ import Prelude import Data.Bifunctor (first) import qualified Data.Map.Strict as Map import Data.Maybe -import qualified Data.Text as Text data ScriptLanguageValidationError = ScriptLanguageValidationError AnyScriptLanguage AnyCardanoEra deriving Show instance Error ScriptLanguageValidationError where - displayError (ScriptLanguageValidationError lang era) = - "The script language " <> show lang <> " is not supported in the " <> - Text.unpack (renderEra era) <> " era." + prettyError = \case + ScriptLanguageValidationError lang era -> + "The script language " <> pshow lang <> " is not supported in the " <> + pretty (renderEra era) <> " era." validateScriptSupportedInEra :: CardanoEra era @@ -73,10 +74,10 @@ data TxFeeValidationError deriving Show instance Error TxFeeValidationError where - displayError (TxFeatureImplicitFeesE era) = - "Implicit transaction fee not supported in " <> Text.unpack (renderEra era) - displayError (TxFeatureExplicitFeesE era) = - "Explicit transaction fee not supported in " <> Text.unpack (renderEra era) + prettyError (TxFeatureImplicitFeesE era) = + "Implicit transaction fee not supported in " <> pretty (renderEra era) + prettyError (TxFeatureExplicitFeesE era) = + "Explicit transaction fee not supported in " <> pretty (renderEra era) validateTxFee :: CardanoEra era -> Maybe Lovelace @@ -98,8 +99,8 @@ newtype TxTotalCollateralValidationError deriving Show instance Error TxTotalCollateralValidationError where - displayError (TxTotalCollateralNotSupported era) = - "Transaction collateral not supported in " <> Text.unpack (renderEra era) + prettyError (TxTotalCollateralNotSupported era) = + "Transaction collateral not supported in " <> pretty (renderEra era) validateTxTotalCollateral :: CardanoEra era -> Maybe Lovelace @@ -114,8 +115,8 @@ newtype TxReturnCollateralValidationError deriving Show instance Error TxReturnCollateralValidationError where - displayError (TxReturnCollateralNotSupported era) = - "Transaction return collateral not supported in " <> Text.unpack (renderEra era) + prettyError (TxReturnCollateralNotSupported era) = + "Transaction return collateral not supported in " <> pretty (renderEra era) validateTxReturnCollateral :: CardanoEra era -> Maybe (TxOut CtxTx era) @@ -130,8 +131,8 @@ newtype TxValidityLowerBoundValidationError deriving Show instance Error TxValidityLowerBoundValidationError where - displayError (TxValidityLowerBoundNotSupported era) = - "Transaction validity lower bound not supported in " <> Text.unpack (renderEra era) + prettyError (TxValidityLowerBoundNotSupported era) = + "Transaction validity lower bound not supported in " <> pretty (renderEra era) validateTxValidityLowerBound :: CardanoEra era @@ -147,8 +148,8 @@ newtype TxValidityUpperBoundValidationError deriving Show instance Error TxValidityUpperBoundValidationError where - displayError (TxValidityUpperBoundNotSupported era) = - "Transaction validity upper bound must be specified in " <> Text.unpack (renderEra era) + prettyError (TxValidityUpperBoundNotSupported era) = + "Transaction validity upper bound must be specified in " <> pretty (renderEra era) validateTxValidityUpperBound :: CardanoEra era @@ -168,10 +169,10 @@ data TxAuxScriptsValidationError deriving Show instance Error TxAuxScriptsValidationError where - displayError (TxAuxScriptsNotSupportedInEra era) = - "Transaction auxiliary scripts are not supported in " <> Text.unpack (renderEra era) - displayError (TxAuxScriptsLanguageError e) = - "Transaction auxiliary scripts error: " <> displayError e + prettyError (TxAuxScriptsNotSupportedInEra era) = + "Transaction auxiliary scripts are not supported in " <> pretty (renderEra era) + prettyError (TxAuxScriptsLanguageError e) = + "Transaction auxiliary scripts error: " <> prettyError e validateTxAuxScripts :: CardanoEra era @@ -188,8 +189,8 @@ newtype TxRequiredSignersValidationError deriving Show instance Error TxRequiredSignersValidationError where - displayError (TxRequiredSignersValidationError e) = - "Transaction required signers are not supported in " <> Text.unpack (renderEra e) + prettyError (TxRequiredSignersValidationError e) = + "Transaction required signers are not supported in " <> pretty (renderEra e) validateRequiredSigners :: CardanoEra era @@ -205,8 +206,8 @@ newtype TxWithdrawalsValidationError deriving Show instance Error TxWithdrawalsValidationError where - displayError (TxWithdrawalsNotSupported e) = - "Transaction withdrawals are not supported in " <> Text.unpack (renderEra e) + prettyError (TxWithdrawalsNotSupported e) = + "Transaction withdrawals are not supported in " <> pretty (renderEra e) validateTxWithdrawals :: forall era. @@ -233,8 +234,8 @@ newtype TxCertificatesValidationError deriving Show instance Error TxCertificatesValidationError where - displayError (TxCertificatesValidationNotSupported e) = - "Transaction certificates are not supported in " <> Text.unpack (renderEra e) + prettyError (TxCertificatesValidationNotSupported e) = + "Transaction certificates are not supported in " <> pretty (renderEra e) validateTxCertificates :: forall era. @@ -298,8 +299,8 @@ newtype TxProtocolParametersValidationError deriving Show instance Error TxProtocolParametersValidationError where - displayError (ProtocolParametersNotSupported e) = - "Transaction protocol parameters are not supported in " <> Text.unpack (renderEra e) + prettyError (ProtocolParametersNotSupported e) = + "Transaction protocol parameters are not supported in " <> pretty (renderEra e) validateProtocolParameters :: CardanoEra era @@ -315,16 +316,16 @@ newtype TxUpdateProposalValidationError deriving Show instance Error TxUpdateProposalValidationError where - displayError (TxUpdateProposalNotSupported e) = - "Transaction update proposal is not supported in " <> Text.unpack (renderEra e) + prettyError (TxUpdateProposalNotSupported e) = + "Transaction update proposal is not supported in " <> pretty (renderEra e) newtype TxScriptValidityValidationError = ScriptValidityNotSupported AnyCardanoEra deriving Show instance Error TxScriptValidityValidationError where - displayError (ScriptValidityNotSupported e) = - "Transaction script validity is not supported in " <> Text.unpack (renderEra e) + prettyError (ScriptValidityNotSupported e) = + "Transaction script validity is not supported in " <> pretty (renderEra e) validateTxScriptValidity :: CardanoEra era diff --git a/cardano-cli/src/Cardano/CLI/Types/Key.hs b/cardano-cli/src/Cardano/CLI/Types/Key.hs index ad2b432da7..97784b22e5 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Key.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Key.hs @@ -48,6 +48,7 @@ module Cardano.CLI.Types.Key import Cardano.Api import qualified Cardano.Api.Ledger as L +import Cardano.Api.Pretty import Cardano.Api.Shelley import Cardano.CLI.Types.Common @@ -61,10 +62,8 @@ import qualified Data.ByteString as BS import Data.Function import qualified Data.List.NonEmpty as NE import Data.Text (Text) -import qualified Data.Text as Text import qualified Data.Text.Encoding as Text - ------------------------------------------------------------------------------ -- Verification key deserialisation ------------------------------------------------------------------------------ @@ -228,11 +227,11 @@ data VerificationKeyTextOrFileError deriving Show -- | Render an error message for a 'VerificationKeyTextOrFileError'. -renderVerificationKeyTextOrFileError :: VerificationKeyTextOrFileError -> Text +renderVerificationKeyTextOrFileError :: VerificationKeyTextOrFileError -> Doc ann renderVerificationKeyTextOrFileError vkTextOrFileErr = case vkTextOrFileErr of VerificationKeyTextError err -> renderInputDecodeError err - VerificationKeyFileError err -> Text.pack (displayError err) + VerificationKeyFileError err -> prettyError err -- | Deserialise a verification key from text or a verification key file. -- If a filepath is provided, the file can either be formatted as Bech32, hex, diff --git a/cardano-cli/src/Cardano/CLI/Types/Output.hs b/cardano-cli/src/Cardano/CLI/Types/Output.hs index d9ba4b9039..9b0644bdd2 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Output.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Output.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Output ( PlutusScriptCostError @@ -13,6 +14,7 @@ module Cardano.CLI.Types.Output import Cardano.Api import qualified Cardano.Api.Ledger as Ledger +import Cardano.Api.Pretty import Cardano.Api.Shelley import Cardano.CLI.Types.Common @@ -26,7 +28,6 @@ import qualified Data.List as List import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Text (Text) -import qualified Data.Text as Text import Data.Time.Clock (UTCTime) import Data.Word @@ -267,18 +268,19 @@ data PlutusScriptCostError instance Error PlutusScriptCostError where - displayError (PlutusScriptCostErrPlutusScriptNotFound sWitIndex) = - "No Plutus script was found at: " <> show sWitIndex - displayError (PlutusScriptCostErrExecError sWitIndex sHash sExecErro) = - "Plutus script at: " <> show sWitIndex <> " with hash: " <> show sHash <> - " errored with: " <> displayError sExecErro - displayError (PlutusScriptCostErrRationalExceedsBound eUnitPrices eUnits) = - "Either the execution unit prices: " <> show eUnitPrices <> " or the execution units: " <> - show eUnits <> " or both are either too precise or not within bounds" - displayError (PlutusScriptCostErrRefInputNoScript txin) = - "No reference script found at input: " <> Text.unpack (renderTxIn txin) - displayError (PlutusScriptCostErrRefInputNotInUTxO txin) = - "Reference input was not found in utxo: " <> Text.unpack (renderTxIn txin) + prettyError = \case + PlutusScriptCostErrPlutusScriptNotFound sWitIndex -> + "No Plutus script was found at: " <> pshow sWitIndex + PlutusScriptCostErrExecError sWitIndex sHash sExecErro -> + "Plutus script at: " <> pshow sWitIndex <> " with hash: " <> pshow sHash <> + " errored with: " <> prettyError sExecErro + PlutusScriptCostErrRationalExceedsBound eUnitPrices eUnits -> + "Either the execution unit prices: " <> pshow eUnitPrices <> " or the execution units: " <> + pshow eUnits <> " or both are either too precise or not within bounds" + PlutusScriptCostErrRefInputNoScript txin -> + "No reference script found at input: " <> pretty (renderTxIn txin) + PlutusScriptCostErrRefInputNotInUTxO txin -> + "Reference input was not found in utxo: " <> pretty (renderTxIn txin) renderScriptCosts :: UTxO era diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Tx.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Tx.hs index 7facd6aef2..0bc4f0d6f9 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Tx.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Tx.hs @@ -3,6 +3,7 @@ module Test.Golden.Byron.Tx where import Cardano.Api +import Cardano.Api.Pretty import Cardano.Chain.UTxO (ATxAux) import Cardano.CLI.Byron.Tx @@ -11,7 +12,6 @@ import Control.Monad (void) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (runExceptT) import Data.ByteString (ByteString) -import qualified Data.Text as Text import Test.Cardano.CLI.Util @@ -60,7 +60,7 @@ getTxByteString :: FilePath -> H.PropertyT IO (ATxAux ByteString) getTxByteString txFp = do eATxAuxBS <- liftIO . runExceptT $ readByronTx $ File txFp case eATxAuxBS of - Left err -> failWith Nothing . Text.unpack $ renderByronTxError err + Left err -> failWith Nothing . prettyToString $ renderByronTxError err Right aTxAuxBS -> return aTxAuxBS compareByronTxs :: FilePath -> FilePath -> H.PropertyT IO () diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/UpdateProposal.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/UpdateProposal.hs index 228c7207f1..f948ceb399 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/UpdateProposal.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/UpdateProposal.hs @@ -2,12 +2,13 @@ module Test.Golden.Byron.UpdateProposal where +import Cardano.Api.Pretty + import Cardano.CLI.Byron.UpdateProposal import Control.Monad (void) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (runExceptT) -import qualified Data.Text as Text import Test.Cardano.CLI.Util @@ -38,12 +39,12 @@ hprop_byron_update_proposal = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir eExpected <- liftIO . runExceptT $ readByronUpdateProposal expectedUpdateProposal expected <- case eExpected of - Left err -> failWith Nothing . Text.unpack $ renderByronUpdateProposalError err + Left err -> failWith Nothing . prettyToString $ renderByronUpdateProposalError err Right prop -> return prop eCreated <- liftIO . runExceptT $ readByronUpdateProposal createdUpdateProposal created <- case eCreated of - Left err -> failWith Nothing . Text.unpack $ renderByronUpdateProposalError err + Left err -> failWith Nothing . prettyToString $ renderByronUpdateProposalError err Right prop -> return prop expected === created diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Vote.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Vote.hs index d40dfc461d..7cd5d62809 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Vote.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Vote.hs @@ -2,12 +2,13 @@ module Test.Golden.Byron.Vote where +import Cardano.Api.Pretty + import Cardano.CLI.Byron.Vote import Control.Monad (void) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (runExceptT) -import qualified Data.Text as Text import Test.Cardano.CLI.Util @@ -34,12 +35,12 @@ hprop_byron_yes_vote = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do eExpected <- liftIO . runExceptT $ readByronVote expectedYesVote expected <- case eExpected of - Left err -> failWith Nothing . Text.unpack $ renderByronVoteError err + Left err -> failWith Nothing . prettyToString $ renderByronVoteError err Right prop -> return prop eCreated <- liftIO . runExceptT $ readByronVote createdYesVote created <- case eCreated of - Left err -> failWith Nothing . Text.unpack $ renderByronVoteError err + Left err -> failWith Nothing . prettyToString $ renderByronVoteError err Right prop -> return prop expected === created @@ -61,12 +62,12 @@ hprop_byron_no_vote = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do eExpected <- liftIO . runExceptT $ readByronVote expectedNoVote expected <- case eExpected of - Left err -> failWith Nothing . Text.unpack $ renderByronVoteError err + Left err -> failWith Nothing . prettyToString $ renderByronVoteError err Right prop -> return prop eCreated <- liftIO . runExceptT $ readByronVote createdNoVote created <- case eCreated of - Left err -> failWith Nothing . Text.unpack $ renderByronVoteError err + Left err -> failWith Nothing . prettyToString $ renderByronVoteError err Right prop -> return prop expected === created diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/VerifyPoll.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/VerifyPoll.hs index c3be9464d9..0d3d476e06 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/VerifyPoll.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/VerifyPoll.hs @@ -4,6 +4,7 @@ module Test.Golden.EraBased.Governance.VerifyPoll where import Cardano.Api +import Cardano.Api.Pretty import Cardano.CLI.Types.Key (VerificationKeyOrFile (..), readVerificationKeyOrTextEnvFile) @@ -15,8 +16,8 @@ import Test.Cardano.CLI.Util import Hedgehog (Property) import qualified Hedgehog as H -import qualified Hedgehog.Internal.Property as H import qualified Hedgehog.Extras as H +import qualified Hedgehog.Internal.Property as H {- HLINT ignore "Use camelCase" -} @@ -35,7 +36,7 @@ hprop_golden_governanceVerifyPoll = propertyOnce $ do liftIO (readVerificationKeyOrTextEnvFile AsStakePoolKey goldenVkFile) >>= \case Left e -> - H.failWith Nothing (displayError e) + H.failWith Nothing $ prettyToString $ prettyError e Right vk -> do let expected = prettyPrintJSON $ serialiseToRawBytesHexText <$> [verificationKeyHash vk] H.assert $ expected `BSC.isInfixOf` stdout diff --git a/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Util.hs b/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Util.hs index e18e0a36b0..5a55cdfe26 100644 --- a/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Util.hs +++ b/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} module Test.Cardano.CLI.Util ( checkTxCddlFormat , checkTextEnvelopeFormat @@ -14,6 +15,7 @@ module Test.Cardano.CLI.Util ) where import Cardano.Api +import Cardano.Api.Pretty import Cardano.CLI.Read @@ -133,18 +135,21 @@ checkTextEnvelopeFormat tve reference created = GHC.withFrozenCallStack $ do createdTextEnvelope <- handleTextEnvelope eCreatedTextEnvelope typeTitleEquivalence refTextEnvelope createdTextEnvelope - where - handleTextEnvelope :: MonadTest m - => Either (FileError TextEnvelopeError) TextEnvelope - -> m TextEnvelope - handleTextEnvelope (Right refTextEnvelope) = return refTextEnvelope - handleTextEnvelope (Left fileErr) = failWithCustom GHC.callStack Nothing . displayError $ fileErr - - typeTitleEquivalence :: (MonadTest m, HasCallStack) => TextEnvelope -> TextEnvelope -> m () - typeTitleEquivalence (TextEnvelope refType refTitle _) - (TextEnvelope createdType createdTitle _) = GHC.withFrozenCallStack $ do - equivalence refType createdType - equivalence refTitle createdTitle + where + handleTextEnvelope :: MonadTest m + => Either (FileError TextEnvelopeError) TextEnvelope + -> m TextEnvelope + handleTextEnvelope = \case + Right refTextEnvelope -> + return refTextEnvelope + Left fileErr -> + failWithCustom GHC.callStack Nothing . (prettyToString . prettyError) $ fileErr + + typeTitleEquivalence :: (MonadTest m, HasCallStack) => TextEnvelope -> TextEnvelope -> m () + typeTitleEquivalence (TextEnvelope refType refTitle _) + (TextEnvelope createdType createdTitle _) = GHC.withFrozenCallStack $ do + equivalence refType createdType + equivalence refTitle createdTitle checkTxCddlFormat :: (MonadTest m, MonadIO m, HasCallStack) From ce86bb2bd725e6aff25a516626fdb0b5da56811d Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 10 Nov 2023 14:32:33 -0400 Subject: [PATCH 2/8] Propagate removal of ByronOnlyEra era from ... --- cardano-cli/src/Cardano/CLI/Byron/Parsers.hs | 2 +- cardano-cli/src/Cardano/CLI/Byron/Tx.hs | 2 +- cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs | 2 +- cardano-cli/src/Cardano/CLI/Json/Friendly.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs b/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs index 23f09134a2..34e92bc8d9 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs @@ -294,7 +294,7 @@ parseTxOut = pLovelaceTxOut l = if l > (maxBound :: Word64) then error $ show l <> " lovelace exceeds the Word64 upper bound" - else TxOutValueByron ByronEraOnlyByron . Lovelace $ toInteger l + else TxOutValueByron . Lovelace $ toInteger l readerFromAttoParser :: Atto.Parser a -> Opt.ReadM a readerFromAttoParser p = diff --git a/cardano-cli/src/Cardano/CLI/Byron/Tx.hs b/cardano-cli/src/Cardano/CLI/Byron/Tx.hs index 9ca0d274b2..f36b9f11c6 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Tx.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Tx.hs @@ -245,7 +245,7 @@ nodeSubmitTx nodeSocketPath network gentx = do localNodeNetworkId = network, localConsensusModeParams = CardanoModeParams (EpochSlots 21600) } - res <- liftIO $ submitTxToNodeLocal connctInfo (TxInByronSpecial ByronEraOnlyByron gentx) + res <- liftIO $ submitTxToNodeLocal connctInfo (TxInByronSpecial gentx) case res of Net.Tx.SubmitSuccess -> liftIO $ Text.putStrLn "Transaction successfully submitted." Net.Tx.SubmitFail reason -> diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs index 8be97115a0..33d2c2ad32 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs @@ -1041,7 +1041,7 @@ printUtxo sbe txInOutTuple = printableValue :: TxOutValue era -> Text printableValue = \case - TxOutValueByron _ (Lovelace i) -> Text.pack $ show i + TxOutValueByron (Lovelace i) -> Text.pack $ show i TxOutValueShelleyBased sbe2 val -> renderValue $ Api.fromLedgerValue sbe2 val runQueryStakePoolsCmd :: () diff --git a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs index 9f14a99723..338fc0e7ad 100644 --- a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs +++ b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs @@ -566,7 +566,7 @@ friendlyMintValue = \case friendlyTxOutValue :: TxOutValue era -> Aeson.Value friendlyTxOutValue = \case - TxOutValueByron _ lovelace -> friendlyLovelace $ toShelleyLovelace lovelace + TxOutValueByron lovelace -> friendlyLovelace $ toShelleyLovelace lovelace TxOutValueShelleyBased sbe v -> friendlyLedgerValue sbe v friendlyLedgerValue :: () From e6a9acce5edf4017860319ef713ce2d958ed9c3a Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Tue, 14 Nov 2023 12:40:38 -0400 Subject: [PATCH 3/8] runTransactionCalculateMinValueCmd was never Byron compatible Remove support for Byron by only accepting shelley based tx outputs --- .../Cardano/CLI/EraBased/Commands/Transaction.hs | 4 ++-- .../src/Cardano/CLI/EraBased/Run/Transaction.hs | 14 +++++++------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs index 2002f6fdb5..d90691db3b 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs @@ -168,9 +168,9 @@ data TransactionCalculateMinFeeCmdArgs = TransactionCalculateMinFeeCmdArgs } deriving Show data TransactionCalculateMinValueCmdArgs era = TransactionCalculateMinValueCmdArgs - { eon :: !(CardanoEra era) + { eon :: !(ShelleyBasedEra era) , protocolParamsFile :: !ProtocolParamsFile - , txOut :: !TxOutAnyEra + , txOut :: !TxOutShelleyBasedEra } deriving Show newtype TransactionHashScriptDataCmdArgs = TransactionHashScriptDataCmdArgs diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index d7280bed46..da9ee3913e 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs @@ -1023,14 +1023,14 @@ runTransactionCalculateMinValueCmd , txOut } = do pp <- firstExceptT TxCmdProtocolParamsError (readProtocolParameters protocolParamsFile) - out <- toTxOutInAnyEra eon txOut + out <- toTxOutInShelleyBasedEra eon txOut -- TODO: shouldn't we just require shelley based era here instead of error-ing for byron? - forEraInEon eon (error "runTransactionCalculateMinValueCmd: Byron era not implemented yet") $ \sbe -> do - firstExceptT TxCmdPParamsErr . hoistEither - $ checkProtocolParameters sbe pp - pp' <- hoistEither . first TxCmdProtocolParamsConverstionError $ toLedgerPParams sbe pp - let minValue = calculateMinimumUTxO sbe out pp' - liftIO . IO.print $ minValue + + firstExceptT TxCmdPParamsErr . hoistEither + $ checkProtocolParameters eon pp + pp' <- hoistEither . first TxCmdProtocolParamsConverstionError $ toLedgerPParams eon pp + let minValue = calculateMinimumUTxO eon out pp' + liftIO . IO.print $ minValue runTransactionPolicyIdCmd :: () => Cmd.TransactionPolicyIdCmdArgs From 75a15e72b5481700dd2d78af3d71465618188d71 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Tue, 14 Nov 2023 12:55:16 -0400 Subject: [PATCH 4/8] Propagate minimum value calculation changes --- .../CLI/EraBased/Options/Transaction.hs | 25 +++++++++++-------- .../CLI/Legacy/Commands/Transaction.hs | 2 +- cardano-cli/src/Cardano/CLI/Legacy/Options.hs | 2 +- .../src/Cardano/CLI/Legacy/Run/Transaction.hs | 15 +++++++---- 4 files changed, 27 insertions(+), 17 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs index 13b1211dc4..22dd5b1eec 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs @@ -78,12 +78,17 @@ pTransactionCmds era envCli = $ subParser "calculate-min-fee" $ Opt.info (pTransactionCalculateMinFee envCli) $ Opt.progDesc "Calculate the minimum fee for a transaction." - , Just - $ subParser "calculate-min-required-utxo" - $ Opt.info (pTransactionCalculateMinReqUTxO era) - $ Opt.progDesc "Calculate the minimum required UTxO for a transaction output." - , Just - $ pCalculateMinRequiredUtxoBackwardCompatible era + , caseByronOrShelleyBasedEra + (const Nothing) + (\sbe -> Just $ subParser "calculate-min-required-utxo" + $ Opt.info (pTransactionCalculateMinReqUTxO sbe) + $ Opt.progDesc "Calculate the minimum required UTxO for a transaction output." + ) + era + , caseByronOrShelleyBasedEra + (const Nothing) + (Just . pCalculateMinRequiredUtxoBackwardCompatible) + era , Just $ subParser "hash-script-data" $ Opt.info pTxHashScriptData @@ -99,12 +104,12 @@ pTransactionCmds era envCli = ] -- Backwards compatible parsers -calcMinValueInfo :: CardanoEra era -> ParserInfo (TransactionCmds era) +calcMinValueInfo :: ShelleyBasedEra era -> ParserInfo (TransactionCmds era) calcMinValueInfo era = Opt.info (pTransactionCalculateMinReqUTxO era) $ Opt.progDesc "DEPRECATED: Use 'calculate-min-required-utxo' instead." -pCalculateMinRequiredUtxoBackwardCompatible :: CardanoEra era -> Parser (TransactionCmds era) +pCalculateMinRequiredUtxoBackwardCompatible :: ShelleyBasedEra era -> Parser (TransactionCmds era) pCalculateMinRequiredUtxoBackwardCompatible era = Opt.subparser $ Opt.command "calculate-min-value" (calcMinValueInfo era) <> Opt.internal @@ -275,12 +280,12 @@ pTransactionCalculateMinFee envCli = <*> pTxShelleyWitnessCount <*> pTxByronWitnessCount -pTransactionCalculateMinReqUTxO :: CardanoEra era -> Parser (TransactionCmds era) +pTransactionCalculateMinReqUTxO :: ShelleyBasedEra era -> Parser (TransactionCmds era) pTransactionCalculateMinReqUTxO era = fmap TransactionCalculateMinValueCmd $ TransactionCalculateMinValueCmdArgs era <$> pProtocolParamsFile - <*> pTxOut + <*> pTxOutShelleyBased pTxHashScriptData :: Parser (TransactionCmds era) pTxHashScriptData = diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs index 89a654c575..4b34309c58 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs @@ -125,7 +125,7 @@ data LegacyTransactionCmds | TransactionCalculateMinValueCmd AnyCardanoEra ProtocolParamsFile - TxOutAnyEra + TxOutShelleyBasedEra | TransactionHashScriptDataCmd ScriptDataOrFile | TransactionTxIdCmd diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Options.hs b/cardano-cli/src/Cardano/CLI/Legacy/Options.hs index 28966a50ca..dc025d70e5 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Options.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Options.hs @@ -425,7 +425,7 @@ pTransaction envCli = TransactionCalculateMinValueCmd <$> pLegacyCardanoEra envCli <*> pProtocolParamsFile - <*> pTxOut + <*> pTxOutShelleyBased pTxHashScriptData :: Parser LegacyTransactionCmds pTxHashScriptData = diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs index 79eca31535..ad148a7b2e 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs @@ -45,8 +45,13 @@ runLegacyTransactionCmds = \case runLegacyTransactionSubmitCmd mNodeSocketPath consensusModeParams network txFp TransactionCalculateMinFeeCmd txbody nw pParamsFile nInputs nOutputs nShelleyKeyWitnesses nByronKeyWitnesses -> runLegacyTransactionCalculateMinFeeCmd txbody nw pParamsFile nInputs nOutputs nShelleyKeyWitnesses nByronKeyWitnesses - TransactionCalculateMinValueCmd era pParamsFile txOuts' -> - runLegacyTransactionCalculateMinValueCmd era pParamsFile txOuts' + TransactionCalculateMinValueCmd (AnyCardanoEra era) pParamsFile txOuts' -> + -- We choose to not modify TransactionCalculateMinValueCmd to avoid breaking the cli + -- Although in this case specifying Byron would have resulted in a call to error. + caseByronOrShelleyBasedEra + (const $ pure ()) + (\sbe -> runLegacyTransactionCalculateMinValueCmd (AnyShelleyBasedEra sbe) pParamsFile txOuts') + era TransactionHashScriptDataCmd scriptDataOrFile -> runLegacyTransactionHashScriptDataCmd scriptDataOrFile TransactionTxIdCmd txinfile -> @@ -231,12 +236,12 @@ runLegacyTransactionCalculateMinFeeCmd ) runLegacyTransactionCalculateMinValueCmd :: () - => AnyCardanoEra + => AnyShelleyBasedEra -> ProtocolParamsFile - -> TxOutAnyEra + -> TxOutShelleyBasedEra -> ExceptT TxCmdError IO () runLegacyTransactionCalculateMinValueCmd - (AnyCardanoEra era) + (AnyShelleyBasedEra era) pParamsFile txOut = runTransactionCalculateMinValueCmd From 75bee7f48adc0baf9efbf16579c2d473d3982861 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Tue, 14 Nov 2023 12:58:39 -0400 Subject: [PATCH 5/8] Return collateral only makes sense in the context of a ShelleyBasedEra specifically Babbage era onwards Implement TxOutShelleyBasedEra and remove support for specifying a collateral return output at a Byron address --- .../src/Cardano/CLI/EraBased/Commands/Transaction.hs | 4 ++-- .../src/Cardano/CLI/Legacy/Commands/Transaction.hs | 4 ++-- cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs | 4 ++-- cardano-cli/src/Cardano/CLI/Types/Common.hs | 9 +++++++++ 4 files changed, 15 insertions(+), 6 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs index d90691db3b..501ee94ebb 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs @@ -51,7 +51,7 @@ data TransactionBuildRawCmdArgs era = TransactionBuildRawCmdArgs -- ^ Read only reference inputs , txInsCollateral :: ![TxIn] -- ^ Transaction inputs for collateral, only key witnesses, no scripts. - , mReturnCollateral :: !(Maybe TxOutAnyEra) + , mReturnCollateral :: !(Maybe TxOutShelleyBasedEra) -- ^ Return collateral , mTotalCollateral :: !(Maybe Lovelace) -- ^ Total collateral @@ -98,7 +98,7 @@ data TransactionBuildCmdArgs era = TransactionBuildCmdArgs -- ^ Required signers , txinsc :: ![TxIn] -- ^ Transaction inputs for collateral, only key witnesses, no scripts. - , mReturnCollateral :: !(Maybe TxOutAnyEra) + , mReturnCollateral :: !(Maybe TxOutShelleyBasedEra) -- ^ Return collateral , mTotalCollateral :: !(Maybe Lovelace) -- ^ Total collateral diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs index 4b34309c58..477dfe9b72 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs @@ -24,7 +24,7 @@ data LegacyTransactionCmds -- ^ Read only reference inputs [TxIn] -- ^ Transaction inputs for collateral, only key witnesses, no scripts. - (Maybe TxOutAnyEra) + (Maybe TxOutShelleyBasedEra) -- ^ Return collateral (Maybe Lovelace) -- ^ Total collateral @@ -67,7 +67,7 @@ data LegacyTransactionCmds -- ^ Required signers [TxIn] -- ^ Transaction inputs for collateral, only key witnesses, no scripts. - (Maybe TxOutAnyEra) + (Maybe TxOutShelleyBasedEra) -- ^ Return collateral (Maybe Lovelace) -- ^ Total collateral diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs index ad148a7b2e..e9a2e76bb8 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs @@ -80,7 +80,7 @@ runLegacyTransactionBuildCmd :: () -> [TxIn] -- ^ Read only reference inputs -> [RequiredSigner] -- ^ Required signers -> [TxIn] -- ^ Transaction inputs for collateral, only key witnesses, no scripts. - -> Maybe TxOutAnyEra -- ^ Return collateral + -> Maybe TxOutShelleyBasedEra -- ^ Return collateral -> Maybe Lovelace -- ^ Total collateral -> [TxOutAnyEra] -> TxOutChangeAddress @@ -125,7 +125,7 @@ runLegacyTransactionBuildRawCmd :: () -> [(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] -> [TxIn] -- ^ Read only reference inputs -> [TxIn] -- ^ Transaction inputs for collateral, only key witnesses, no scripts. - -> Maybe TxOutAnyEra + -> Maybe TxOutShelleyBasedEra -- ^ Return collateral -> Maybe Lovelace -- ^ Total collateral -> [RequiredSigner] -> [TxOutAnyEra] diff --git a/cardano-cli/src/Cardano/CLI/Types/Common.hs b/cardano-cli/src/Cardano/CLI/Types/Common.hs index 2dba412520..56c39c35e1 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Common.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Common.hs @@ -64,6 +64,7 @@ module Cardano.CLI.Types.Common , TxInCount(..) , TxMempoolQuery (..) , TxOutAnyEra (..) + , TxOutShelleyBasedEra (..) , TxOutChangeAddress (..) , TxOutCount(..) , TxOutDatumAnyEra (..) @@ -382,6 +383,14 @@ instance ToJSON SlotsTillKesKeyExpiry where instance FromJSON SlotsTillKesKeyExpiry where parseJSON v = SlotsTillKesKeyExpiry <$> parseJSON v + +data TxOutShelleyBasedEra + = TxOutShelleyBasedEra + !(Address ShelleyAddr) + Value + TxOutDatumAnyEra + ReferenceScriptAnyEra + deriving Show -- | A TxOut value that is the superset of possibilities for any era: any -- address type and allowing multi-asset values. This is used as the type for -- values passed on the command line. It can be converted into the From bc57f2e96c273b6e1d639bc230356e925e8c70c0 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Tue, 14 Nov 2023 13:01:31 -0400 Subject: [PATCH 6/8] Propagate changes related to removing support for specifying a byron collateral return output --- .../Cardano/CLI/EraBased/Options/Common.hs | 36 +++++- .../Cardano/CLI/EraBased/Run/Transaction.hs | 118 +++++++++++++----- cardano-cli/src/Cardano/CLI/Json/Friendly.hs | 1 - 3 files changed, 118 insertions(+), 37 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs index 9d9a881ca3..8bc4fa4f99 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs @@ -1849,9 +1849,9 @@ pTxInCollateral = <> Opt.help "TxId#TxIx" ) -pReturnCollateral :: Parser TxOutAnyEra +pReturnCollateral :: Parser TxOutShelleyBasedEra pReturnCollateral = - Opt.option (readerFromParsecParser parseTxOutAnyEra) + Opt.option (readerFromParsecParser parseTxOutShelleyBasedEra) ( mconcat [ Opt.long "tx-out-return-collateral" , Opt.metavar "ADDRESS VALUE" @@ -1900,6 +1900,19 @@ pTxOut = <*> pTxOutDatum <*> pRefScriptFp +pTxOutShelleyBased :: Parser TxOutShelleyBasedEra +pTxOutShelleyBased = + Opt.option (readerFromParsecParser parseTxOutShelleyBasedEra) + ( Opt.long "tx-out" + <> Opt.metavar "ADDRESS VALUE" + -- TODO alonzo: Update the help text to describe the new syntax as well. + <> Opt.help "The transaction output as ADDRESS VALUE where ADDRESS is \ + \the Bech32-encoded address followed by the value in \ + \Lovelace." + ) + <*> pTxOutDatum + <*> pRefScriptFp + pTxOutDatum :: Parser TxOutDatumAnyEra pTxOutDatum = pTxOutDatumByHashOnly @@ -2999,6 +3012,25 @@ pDRepActivity = , Opt.help "TODO" ] +parseTxOutShelleyBasedEra + :: Parsec.Parser (TxOutDatumAnyEra -> ReferenceScriptAnyEra -> TxOutShelleyBasedEra) +parseTxOutShelleyBasedEra = do + addr <- parseShelleyAddress + Parsec.spaces + -- Accept the old style of separating the address and value in a + -- transaction output: + Parsec.option () (Parsec.char '+' >> Parsec.spaces) + val <- parseValue + return (TxOutShelleyBasedEra addr val) + +parseShelleyAddress :: Parsec.Parser (Address ShelleyAddr) +parseShelleyAddress = do + str <- lexPlausibleAddressString + case deserialiseAddress AsShelleyAddress str of + Nothing -> fail $ "invalid address: " <> Text.unpack str + Just addr -> pure addr + + parseTxOutAnyEra :: Parsec.Parser (TxOutDatumAnyEra -> ReferenceScriptAnyEra -> TxOutAnyEra) parseTxOutAnyEra = do diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index da9ee3913e..75a44d5a63 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -164,7 +165,7 @@ runTransactionBuildCmd _ -> pure TxUpdateProposalNone requiredSigners <- mapM (firstExceptT TxCmdRequiredSignerError . newExceptT . readRequiredSigner) reqSigners - mReturnCollateral <- forM mReturnColl $ toTxOutInAnyEra era + mReturnCollateral <- forM mReturnColl $ toTxOutInShelleyBasedEra eon txOuts <- mapM (toTxOutInAnyEra era) txouts @@ -319,7 +320,11 @@ runTransactionBuildRawCmd _ -> pure TxUpdateProposalNone requiredSigners <- mapM (firstExceptT TxCmdRequiredSignerError . newExceptT . readRequiredSigner) reqSigners - mReturnCollateral <- forM mReturnColl $ toTxOutInAnyEra eon + + mReturnCollateral <- forEraInEon eon (pure Nothing) $ \sbe -> + forM mReturnColl $ toTxOutInShelleyBasedEra sbe + + -- NB: We need to be able to construct txs in Byron to other Byron addresses txOuts <- mapM (toTxOutInAnyEra eon) txouts -- the same collateral input can be used for several plutus scripts @@ -690,6 +695,14 @@ toAddressInAnyEra era addrAny = runExcept $ do pure (AddressInEra (ShelleyAddressInEra sbe) sAddr) +toAddressInShelleyBasedEra + :: ShelleyBasedEra era + -> Address ShelleyAddr + -> Either TxCmdError (AddressInEra era) +toAddressInShelleyBasedEra sbe sAddr = runExcept $ + pure (AddressInEra (ShelleyAddressInEra sbe) sAddr) + + lovelaceToCoin :: Lovelace -> Ledger.Coin lovelaceToCoin (Lovelace ll) = Ledger.Coin ll @@ -698,10 +711,10 @@ toTxOutValueInAnyEra -> Value -> Either TxCmdError (TxOutValue era) toTxOutValueInAnyEra era val = - caseByronOrShelleyBasedEra - (\w -> + caseByronOrShelleyBasedEra + (const $ case valueToLovelace val of - Just l -> return (TxOutValueByron w l) + Just l -> return (TxOutValueByron l) Nothing -> txFeatureMismatchPure era TxFeatureMultiAssetOutputs ) (\sbe -> @@ -715,7 +728,46 @@ toTxOutValueInAnyEra era val = sbe ) era +toTxOutValueInShelleyBasedEra + :: ShelleyBasedEra era + -> Value + -> Either TxCmdError (TxOutValue era) +toTxOutValueInShelleyBasedEra sbe val = + caseShelleyToAllegraOrMaryEraOnwards + (\_ -> case valueToLovelace val of + Just l -> return (TxOutValueShelleyBased sbe $ lovelaceToCoin l) + Nothing -> txFeatureMismatchPure (toCardanoEra sbe) TxFeatureMultiAssetOutputs + ) + (\w -> return (TxOutValueShelleyBased sbe (toLedgerValue w val)) + ) + sbe + +toTxOutInShelleyBasedEra + :: ShelleyBasedEra era + -> TxOutShelleyBasedEra + -> ExceptT TxCmdError IO (TxOut CtxTx era) +toTxOutInShelleyBasedEra era (TxOutShelleyBasedEra addr' val' mDatumHash refScriptFp) = do + addr <- hoistEither $ toAddressInShelleyBasedEra era addr' + val <- hoistEither $ toTxOutValueInShelleyBasedEra era val' + + datum <- + caseShelleyToMaryOrAlonzoEraOnwards + (const (pure TxOutDatumNone)) + (\wa -> toTxAlonzoDatum wa mDatumHash) + era + + refScript <- inEonForEra + (pure ReferenceScriptNone) + (\wb -> getReferenceScript wb refScriptFp) + (toCardanoEra era) + + pure $ TxOut addr val datum refScript + + +-- TODO: toTxOutInAnyEra eventually will not be needed because +-- byron related functionality will be treated +-- separately toTxOutInAnyEra :: CardanoEra era -> TxOutAnyEra -> ExceptT TxCmdError IO (TxOut CtxTx era) @@ -735,37 +787,35 @@ toTxOutInAnyEra era (TxOutAnyEra addr' val' mDatumHash refScriptFp) = do (const (pure ReferenceScriptNone)) (\wb -> getReferenceScript wb refScriptFp) era - pure $ TxOut addr val datum refScript - where - getReferenceScript :: () - => BabbageEraOnwards era - -> ReferenceScriptAnyEra - -> ExceptT TxCmdError IO (ReferenceScript era) - getReferenceScript w = \case - ReferenceScriptAnyEraNone -> return ReferenceScriptNone - ReferenceScriptAnyEra fp -> ReferenceScript w <$> firstExceptT TxCmdScriptFileError (readFileScriptInAnyLang fp) - - toTxAlonzoDatum :: () - => AlonzoEraOnwards era - -> TxOutDatumAnyEra - -> ExceptT TxCmdError IO (TxOutDatum CtxTx era) - toTxAlonzoDatum supp cliDatum = - case cliDatum of - TxOutDatumByNone -> pure TxOutDatumNone - TxOutDatumByHashOnly h -> pure (TxOutDatumHash supp h) - TxOutDatumByHashOf sDataOrFile -> do - sData <- firstExceptT TxCmdScriptDataError $ readScriptDataOrFile sDataOrFile - pure (TxOutDatumHash supp $ hashScriptDataBytes sData) - TxOutDatumByValue sDataOrFile -> do - sData <- firstExceptT TxCmdScriptDataError $ readScriptDataOrFile sDataOrFile - pure (TxOutDatumInTx supp sData) - TxOutInlineDatumByValue sDataOrFile -> do - let cEra = alonzoEraOnwardsToCardanoEra supp - forEraInEon cEra (txFeatureMismatch cEra TxFeatureInlineDatums) $ \babbageOnwards -> do - sData <- firstExceptT TxCmdScriptDataError $ readScriptDataOrFile sDataOrFile - pure $ TxOutDatumInline babbageOnwards sData +getReferenceScript :: () + => BabbageEraOnwards era + -> ReferenceScriptAnyEra + -> ExceptT TxCmdError IO (ReferenceScript era) +getReferenceScript w = \case + ReferenceScriptAnyEraNone -> return ReferenceScriptNone + ReferenceScriptAnyEra fp -> ReferenceScript w <$> firstExceptT TxCmdScriptFileError (readFileScriptInAnyLang fp) + +toTxAlonzoDatum :: () + => AlonzoEraOnwards era + -> TxOutDatumAnyEra + -> ExceptT TxCmdError IO (TxOutDatum CtxTx era) +toTxAlonzoDatum supp cliDatum = + case cliDatum of + TxOutDatumByNone -> pure TxOutDatumNone + TxOutDatumByHashOnly h -> pure (TxOutDatumHash supp h) + TxOutDatumByHashOf sDataOrFile -> do + sData <- firstExceptT TxCmdScriptDataError $ readScriptDataOrFile sDataOrFile + pure (TxOutDatumHash supp $ hashScriptDataBytes sData) + TxOutDatumByValue sDataOrFile -> do + sData <- firstExceptT TxCmdScriptDataError $ readScriptDataOrFile sDataOrFile + pure (TxOutDatumInTx supp sData) + TxOutInlineDatumByValue sDataOrFile -> do + let cEra = alonzoEraOnwardsToCardanoEra supp + forEraInEon cEra (txFeatureMismatch cEra TxFeatureInlineDatums) $ \babbageOnwards -> do + sData <- firstExceptT TxCmdScriptDataError $ readScriptDataOrFile sDataOrFile + pure $ TxOutDatumInline babbageOnwards sData -- TODO: Currently we specify the policyId with the '--mint' option on the cli -- and we added a separate '--policy-id' parser that parses the policy id for the diff --git a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs index 338fc0e7ad..b311d102e6 100644 --- a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs +++ b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs @@ -5,7 +5,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} From a1ec4d9bf4ea2892ffae10894a3d0dde01ba4cdb Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 15 Nov 2023 08:03:03 -0400 Subject: [PATCH 7/8] Update golden tests --- cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs index 8bc4fa4f99..fd7292eb1b 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs @@ -1908,7 +1908,7 @@ pTxOutShelleyBased = -- TODO alonzo: Update the help text to describe the new syntax as well. <> Opt.help "The transaction output as ADDRESS VALUE where ADDRESS is \ \the Bech32-encoded address followed by the value in \ - \Lovelace." + \the multi-asset syntax (including simply Lovelace)." ) <*> pTxOutDatum <*> pRefScriptFp From 7ca891042128361060260fd563b5ba5973018ded Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 7 Nov 2023 10:56:33 +0100 Subject: [PATCH 8/8] Integration work for node 8.7.0 --- cabal.project | 10 ++-------- cardano-cli/cardano-cli.cabal | 2 +- cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs | 4 ++-- cardano-cli/src/Cardano/CLI/Types/Output.hs | 4 ++-- 4 files changed, 7 insertions(+), 13 deletions(-) diff --git a/cabal.project b/cabal.project index 5005577255..4fc03f2d38 100644 --- a/cabal.project +++ b/cabal.project @@ -13,8 +13,8 @@ repository cardano-haskell-packages -- See CONTRIBUTING for information about these, including some Nix commands -- you need to run if you change them index-state: - , hackage.haskell.org 2023-08-08T19:56:09Z - , cardano-haskell-packages 2023-11-10T12:47:36Z + , hackage.haskell.org 2023-11-09T23:50:15Z + , cardano-haskell-packages 2023-11-17T15:33:21Z packages: cardano-cli @@ -43,9 +43,3 @@ write-ghc-environment-files: always -- IMPORTANT -- Do NOT add more source-repository-package stanzas here unless they are strictly -- temporary! Please read the section in CONTRIBUTING about updating dependencies. - -source-repository-package - type: git - location: https://github.com/input-output-hk/cardano-api - tag: b406ef1e24a3da86b53a2f51384d47672ff7ab18 - subdir: cardano-api diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index d9478620e5..6f761aa957 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -206,7 +206,7 @@ library , binary , bytestring , canonical-json - , cardano-api ^>= 8.31.0.0 + , cardano-api ^>= 8.33.0.0 , cardano-binary , cardano-crypto , cardano-crypto-class ^>= 2.1.2 diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs index fd7292eb1b..0f85f1fd6c 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs @@ -2980,9 +2980,9 @@ pMinCommitteeSize = , Opt.help "TODO" ] -pCommitteeTermLength :: Parser Natural +pCommitteeTermLength :: Parser EpochNo pCommitteeTermLength = - Opt.option Opt.auto $ mconcat + fmap EpochNo $ Opt.option Opt.auto $ mconcat [ Opt.long "committee-term-length" , Opt.metavar "INT" , Opt.help "TODO" diff --git a/cardano-cli/src/Cardano/CLI/Types/Output.hs b/cardano-cli/src/Cardano/CLI/Types/Output.hs index 9b0644bdd2..5f8033c749 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Output.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Output.hs @@ -158,11 +158,11 @@ data QueryTipLocalStateOutput = QueryTipLocalStateOutput } deriving Show -- | A key-value pair difference list for encoding a JSON object. -(..=) :: (KeyValue kv, ToJSON v) => Aeson.Key -> v -> [kv] -> [kv] +(..=) :: (KeyValue e kv, ToJSON v) => Aeson.Key -> v -> [kv] -> [kv] (..=) n v = (n .= v:) -- | A key-value pair difference list for encoding a JSON object where Nothing encodes absence of the key-value pair. -(..=?) :: (KeyValue kv, ToJSON v) => Aeson.Key -> Maybe v -> [kv] -> [kv] +(..=?) :: (KeyValue e kv, ToJSON v) => Aeson.Key -> Maybe v -> [kv] -> [kv] (..=?) n mv = case mv of Just v -> (n .= v:) Nothing -> id