TxValidationError: extend to support a ShelleyBasedEra constructor

IntersectMBO · Jun 18, 2024 · 36ed10b · 36ed10b
1 parent fccfd72
commit 36ed10b
Show file tree

Hide file tree

Showing 4 changed files with 36 additions and 25 deletions.
diff --git 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
@@ -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
@@ -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
@@ -9,7 +9,7 @@
 module Cardano.CLI.Types.Errors.TxValidationError
   ( TxAuxScriptsValidationError(..)
   , TxGovDuplicateVotes(..)
-  , TxNotSupportedInAnyCardanoEraValidationError(..)
+  , TxNotSupportedInEraValidationError(..)
   , convToTxProposalProcedures
   , convertToTxVotingProcedures
   , validateScriptSupportedInEra
@@ -59,38 +59,49 @@ 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"
   pure $ TxTotalCollateral supported coll
 
 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"
   pure $ TxReturnCollateral supported retColTxOut
 
 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