From 36ed10b432cdaacee35f7067f179232b367e5b41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Hurlin?= Date: Tue, 18 Jun 2024 16:34:53 +0200 Subject: [PATCH] TxValidationError: extend to support a ShelleyBasedEra constructor --- .../Cardano/CLI/EraBased/Run/Transaction.hs | 10 ++--- .../src/Cardano/CLI/Legacy/Run/Transaction.hs | 4 +- .../Cardano/CLI/Types/Errors/TxCmdError.hs | 4 +- .../CLI/Types/Errors/TxValidationError.hs | 43 ++++++++++++------- 4 files changed, 36 insertions(+), 25 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index 2f7a283bd6..1cc78241cc 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs @@ -655,13 +655,13 @@ constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits rea validatedCollateralTxIns <- validateTxInsCollateral sbe txinsc validatedRefInputs <- validateTxInsReference sbe allReferenceInputs - validatedTotCollateral <- first TxCmdNotSupportedInAnyCardanoEraValidationError $ validateTxTotalCollateral sbe mTotCollateral - validatedRetCol <- first TxCmdNotSupportedInAnyCardanoEraValidationError $ validateTxReturnCollateral sbe mReturnCollateral + validatedTotCollateral <- first TxCmdNotSupportedInEraValidationError $ validateTxTotalCollateral sbe mTotCollateral + validatedRetCol <- first TxCmdNotSupportedInEraValidationError $ validateTxReturnCollateral sbe mReturnCollateral let txFee = TxFeeExplicit sbe fee - validatedLowerBound <- first TxCmdNotSupportedInAnyCardanoEraValidationError $ validateTxValidityLowerBound sbe mLowerBound - validatedReqSigners <- first TxCmdNotSupportedInAnyCardanoEraValidationError $ validateRequiredSigners sbe reqSigners + validatedLowerBound <- first TxCmdNotSupportedInEraValidationError $ validateTxValidityLowerBound sbe mLowerBound + validatedReqSigners <- first TxCmdNotSupportedInEraValidationError $ validateRequiredSigners sbe reqSigners validatedMintValue <- createTxMintValue sbe valuesWithScriptWits - validatedTxScriptValidity <- first TxCmdNotSupportedInAnyCardanoEraValidationError $ validateTxScriptValidity sbe mScriptValidity + validatedTxScriptValidity <- first TxCmdNotSupportedInEraValidationError $ validateTxScriptValidity sbe mScriptValidity validatedVotingProcedures <- first TxCmdTxGovDuplicateVotes $ convertToTxVotingProcedures votingProcedures return $ shelleyBasedEraConstraints sbe $ (defaultTxBodyContent sbe & setTxIns (validateTxIns inputsAndMaybeScriptWits) diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs index ce417c3e78..6e06e0d834 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs @@ -103,7 +103,7 @@ runLegacyTransactionBuildCmd mUpdateProposalFile <- validateUpdateProposalFile (shelleyBasedToCardanoEra sbe) mUpdateProposal & hoistEither - & firstExceptT TxCmdNotSupportedInAnyCardanoEraValidationError + & firstExceptT TxCmdNotSupportedInEraValidationError let upperBound = TxValidityUpperBound sbe mUpperBound @@ -169,7 +169,7 @@ runLegacyTransactionBuildRawCmd (\sbe -> do mUpdateProposalFile <- validateUpdateProposalFile era mUpdateProposal & hoistEither - & firstExceptT TxCmdNotSupportedInAnyCardanoEraValidationError + & firstExceptT TxCmdNotSupportedInEraValidationError let upperBound = TxValidityUpperBound sbe mUpperBound diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs index e1eb9967f6..c4d327ed23 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs @@ -79,7 +79,7 @@ data TxCmdError | TxCmdCddlWitnessError CddlWitnessError | TxCmdRequiredSignerError RequiredSignerError -- Validation errors - | forall era. TxCmdNotSupportedInAnyCardanoEraValidationError (TxNotSupportedInAnyCardanoEraValidationError era) + | forall era. TxCmdNotSupportedInEraValidationError (TxNotSupportedInEraValidationError era) | TxCmdAuxScriptsValidationError TxAuxScriptsValidationError | TxCmdProtocolParamsConverstionError ProtocolParametersConversionError | forall era. TxCmdTxGovDuplicateVotes (TxGovDuplicateVotes era) @@ -204,7 +204,7 @@ renderTxCmdError = \case TxCmdRequiredSignerError e -> prettyError e -- Validation errors - TxCmdNotSupportedInAnyCardanoEraValidationError e -> + TxCmdNotSupportedInEraValidationError e -> prettyError e TxCmdAuxScriptsValidationError 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 a067b15d38..44d074248a 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs @@ -9,7 +9,7 @@ module Cardano.CLI.Types.Errors.TxValidationError ( TxAuxScriptsValidationError(..) , TxGovDuplicateVotes(..) - , TxNotSupportedInAnyCardanoEraValidationError(..) + , TxNotSupportedInEraValidationError(..) , convToTxProposalProcedures , convertToTxVotingProcedures , validateScriptSupportedInEra @@ -59,22 +59,33 @@ validateScriptSupportedInEra era script@(ScriptInAnyLang lang _) = (AnyScriptLanguage lang) (anyCardanoEra $ toCardanoEra era) Just script' -> pure script' -data TxNotSupportedInAnyCardanoEraValidationError era = +data TxNotSupportedInEraValidationError era = -- | First argument is the kind of data that is not supported. -- Second argument is the era that doesn't support the data. TxNotSupportedInAnyCardanoEraValidationError T.Text AnyCardanoEra - -instance Show (TxNotSupportedInAnyCardanoEraValidationError era) where - show (TxNotSupportedInAnyCardanoEraValidationError a era) = - show (pretty a) <> " not supported in " <> show era - -instance Error (TxNotSupportedInAnyCardanoEraValidationError era) where - prettyError (TxNotSupportedInAnyCardanoEraValidationError a era) = - pretty a <+> "not supported in" <+> viaShow era + -- | First argument is the kind of data that is not supported. + -- Second argument is the Shelley era that doesn't support the data. + | TxNotSupportedInShelleyBasedEraValidationError T.Text (ShelleyBasedEra era) + +instance Show (TxNotSupportedInEraValidationError era) where + show = + \case + TxNotSupportedInAnyCardanoEraValidationError a cEra -> go a cEra + TxNotSupportedInShelleyBasedEraValidationError a sbe -> go a sbe + where + go a era = show (pretty a) <> " not supported in " <> show era + +instance Error (TxNotSupportedInEraValidationError era) where + prettyError = + \case + TxNotSupportedInAnyCardanoEraValidationError a cEra -> go a cEra + TxNotSupportedInShelleyBasedEraValidationError a sbe -> go a sbe + where + go a cEra = pretty a <+> "not supported in" <+> viaShow cEra validateTxTotalCollateral :: ShelleyBasedEra era -> Maybe L.Coin - -> Either (TxNotSupportedInAnyCardanoEraValidationError era) (TxTotalCollateral era) + -> Either (TxNotSupportedInEraValidationError era) (TxTotalCollateral era) validateTxTotalCollateral _ Nothing = return TxTotalCollateralNone validateTxTotalCollateral sbe (Just coll) = do supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction collateral" @@ -82,7 +93,7 @@ validateTxTotalCollateral sbe (Just coll) = do validateTxReturnCollateral :: ShelleyBasedEra era -> Maybe (TxOut CtxTx era) - -> Either (TxNotSupportedInAnyCardanoEraValidationError era) (TxReturnCollateral CtxTx era) + -> Either (TxNotSupportedInEraValidationError era) (TxReturnCollateral CtxTx era) validateTxReturnCollateral _ Nothing = return TxReturnCollateralNone validateTxReturnCollateral sbe (Just retColTxOut) = do supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction return collateral" @@ -90,7 +101,7 @@ validateTxReturnCollateral sbe (Just retColTxOut) = do validateTxValidityLowerBound :: ShelleyBasedEra era -> Maybe SlotNo - -> Either (TxNotSupportedInAnyCardanoEraValidationError era) (TxValidityLowerBound era) + -> Either (TxNotSupportedInEraValidationError era) (TxValidityLowerBound era) validateTxValidityLowerBound _ Nothing = return TxValidityNoLowerBound validateTxValidityLowerBound sbe (Just slot) = do supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction validity lower bound" @@ -120,7 +131,7 @@ validateTxAuxScripts era scripts = do validateRequiredSigners :: ShelleyBasedEra era -> [Hash PaymentKey] - -> Either (TxNotSupportedInAnyCardanoEraValidationError era) (TxExtraKeyWitnesses era) + -> Either (TxNotSupportedInEraValidationError era) (TxExtraKeyWitnesses era) validateRequiredSigners _ [] = return TxExtraKeyWitnessesNone validateRequiredSigners sbe reqSigs = do supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction required signers" @@ -129,7 +140,7 @@ validateRequiredSigners sbe reqSigs = do validateTxScriptValidity :: ShelleyBasedEra era -> Maybe ScriptValidity - -> Either (TxNotSupportedInAnyCardanoEraValidationError era) (TxScriptValidity era) + -> Either (TxNotSupportedInEraValidationError era) (TxScriptValidity era) validateTxScriptValidity _ Nothing = pure TxScriptValidityNone validateTxScriptValidity sbe (Just scriptValidity) = do supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction script validity" @@ -139,7 +150,7 @@ validateTxScriptValidity sbe (Just scriptValidity) = do validateUpdateProposalFile :: CardanoEra era -> Maybe UpdateProposalFile - -> Either (TxNotSupportedInAnyCardanoEraValidationError era) (Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile))) + -> Either (TxNotSupportedInEraValidationError era) (Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile))) validateUpdateProposalFile era = \case Nothing -> pure Nothing Just updateProposal -> do