Merge pull request #783 from IntersectMBO/smelc/reduce-boilerplate-mo…

…dernize-TxValidationErrors Transaction.hs: reduce boilerplate and move towards ShelleyBasedEra
IntersectMBO · Jun 18, 2024 · fccfd72 · fccfd72
2 parents d39b778 + b843840
commit fccfd72
Show file tree

Hide file tree

Showing 4 changed files with 80 additions and 228 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs
@@ -68,7 +68,7 @@ import           Data.Function ((&))
 import qualified Data.List as List
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import           Data.Maybe (catMaybes, fromMaybe)
+import           Data.Maybe (catMaybes, fromMaybe, mapMaybe)
 import           Data.Set (Set)
 import qualified Data.Set as Set
 import qualified Data.Text as Text
@@ -644,8 +644,7 @@ constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits rea
                        reqSigners fee txAuxScripts txMetadata txUpdateProposal
                        votingProcedures proposals
                        = do
-  let era = toCardanoEra sbe -- TODO: Propagate SBE
-      allReferenceInputs = getAllReferenceInputs
+  let allReferenceInputs = getAllReferenceInputs
                              inputsAndMaybeScriptWits
                              (snd valuesWithScriptWits)
                              certsAndMaybeScriptWits
@@ -656,20 +655,14 @@ constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits rea
 
   validatedCollateralTxIns <- validateTxInsCollateral sbe txinsc
   validatedRefInputs <- validateTxInsReference sbe allReferenceInputs
-  validatedTotCollateral
-    <- first TxCmdTotalCollateralValidationError $ validateTxTotalCollateral era mTotCollateral
-  validatedRetCol
-    <- first TxCmdReturnCollateralValidationError $ validateTxReturnCollateral era mReturnCollateral
+  validatedTotCollateral <- first TxCmdNotSupportedInAnyCardanoEraValidationError $ validateTxTotalCollateral sbe mTotCollateral
+  validatedRetCol        <- first TxCmdNotSupportedInAnyCardanoEraValidationError $ validateTxReturnCollateral sbe mReturnCollateral
   let txFee = TxFeeExplicit sbe fee
-  validatedLowerBound <- first TxCmdTxValidityLowerBoundValidationError (validateTxValidityLowerBound era mLowerBound)
-  validatedReqSigners <- first TxCmdRequiredSignersValidationError $ validateRequiredSigners era reqSigners
-  validatedTxWtdrwls <- first TxCmdTxWithdrawalsValidationError $ validateTxWithdrawals era withdrawals
-  validatedTxCerts <- first TxCmdTxCertificatesValidationError $ validateTxCertificates era certsAndMaybeScriptWits
+  validatedLowerBound <- first TxCmdNotSupportedInAnyCardanoEraValidationError $ validateTxValidityLowerBound sbe mLowerBound
+  validatedReqSigners <- first TxCmdNotSupportedInAnyCardanoEraValidationError $ validateRequiredSigners sbe reqSigners
   validatedMintValue <- createTxMintValue sbe valuesWithScriptWits
-  validatedTxScriptValidity <- first TxCmdScriptValidityValidationError $ validateTxScriptValidity era mScriptValidity
+  validatedTxScriptValidity <- first TxCmdNotSupportedInAnyCardanoEraValidationError $ validateTxScriptValidity sbe mScriptValidity
   validatedVotingProcedures <- first TxCmdTxGovDuplicateVotes $ convertToTxVotingProcedures votingProcedures
-  validatedPParams <- first TxCmdProtocolParametersValidationError
-                                  $ validateProtocolParameters era (LedgerProtocolParameters <$> mPparams)
   return $ shelleyBasedEraConstraints sbe $ (defaultTxBodyContent sbe
              & setTxIns (validateTxIns inputsAndMaybeScriptWits)
              & setTxInsCollateral validatedCollateralTxIns
@@ -683,20 +676,24 @@ constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits rea
              & setTxMetadata txMetadata
              & setTxAuxScripts txAuxScripts
              & setTxExtraKeyWits validatedReqSigners
-             & setTxProtocolParams validatedPParams
-             & setTxWithdrawals validatedTxWtdrwls
-             & setTxCertificates validatedTxCerts
+             & setTxProtocolParams (BuildTxWith $ LedgerProtocolParameters <$> mPparams)
+             & setTxWithdrawals (TxWithdrawals sbe $ map convertWithdrawals withdrawals)
+             & setTxCertificates (convertCertificates sbe certsAndMaybeScriptWits)
              & setTxUpdateProposal txUpdateProposal
              & setTxMintValue validatedMintValue
              & setTxScriptValidity validatedTxScriptValidity)
              -- TODO: Create set* function for proposal procedures and voting procedures
-             { txProposalProcedures = forEraInEonMaybe era (`Featured` convToTxProposalProcedures proposals)
-             , txVotingProcedures = forEraInEonMaybe era (`Featured` validatedVotingProcedures)
+             { txProposalProcedures = forShelleyBasedEraInEonMaybe sbe (`Featured` convToTxProposalProcedures proposals)
+             , txVotingProcedures = forShelleyBasedEraInEonMaybe sbe (`Featured` validatedVotingProcedures)
              }
-
-
-
-
+ where
+  convertWithdrawals
+    :: (StakeAddress, L.Coin, Maybe (ScriptWitness WitCtxStake era))
+    -> (StakeAddress, L.Coin, BuildTxWith BuildTx (Witness WitCtxStake era))
+  convertWithdrawals (sAddr, ll, mScriptWitnessFiles) =
+    case mScriptWitnessFiles of
+      Just sWit -> (sAddr, ll, BuildTxWith $ ScriptWitness ScriptWitnessForStakeAddr sWit)
+      Nothing   -> (sAddr, ll, BuildTxWith $ KeyWitness KeyWitnessForStakeAddr)
 
 runTxBuild :: ()
   => ShelleyBasedEra era
@@ -773,13 +770,8 @@ runTxBuild
   Refl <- testEquality era nodeEra
     & hoistMaybe (TxCmdTxNodeEraMismatchError $ NodeEraMismatchError era nodeEra)
 
-  validatedTxCerts
-     <- hoistEither
-          . first TxCmdTxCertificatesValidationError
-          $ validateTxCertificates era certsAndMaybeScriptWits
-
   let certs =
-        case validatedTxCerts of
+        case convertCertificates sbe certsAndMaybeScriptWits of
           TxCertificates _ cs _ -> cs
           _ -> []
 
@@ -828,6 +820,23 @@ runTxBuild
 
   return balancedTxBody
 
+convertCertificates :: ()
+  => ShelleyBasedEra era
+  -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))]
+  -> TxCertificates BuildTx era
+convertCertificates sbe certsAndScriptWitnesses =
+  TxCertificates sbe certs $ BuildTxWith reqWits
+  where
+    certs = map fst certsAndScriptWitnesses
+    reqWits = Map.fromList $ mapMaybe convert certsAndScriptWitnesses
+    convert :: (Certificate era, Maybe (ScriptWitness WitCtxStake era))
+               -> Maybe (StakeCredential, Witness WitCtxStake era)
+    convert (cert, mScriptWitnessFiles) = do
+      sCred <- selectStakeCredentialWitness cert
+      Just $ case mScriptWitnessFiles of
+        Just sWit -> (sCred, ScriptWitness ScriptWitnessForStakeAddr sWit)
+        Nothing   -> (sCred, KeyWitness KeyWitnessForStakeAddr)
+
 -- ----------------------------------------------------------------------------
 -- Transaction body validation and conversion
 --

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 TxCmdTxUpdateProposalValidationError
+      & firstExceptT TxCmdNotSupportedInAnyCardanoEraValidationError
 
   let upperBound = TxValidityUpperBound sbe mUpperBound
 
@@ -169,7 +169,7 @@ runLegacyTransactionBuildRawCmd
     (\sbe -> do
        mUpdateProposalFile <- validateUpdateProposalFile era mUpdateProposal
                                  & hoistEither
-                                 & firstExceptT TxCmdTxUpdateProposalValidationError
+                                 & firstExceptT TxCmdNotSupportedInAnyCardanoEraValidationError
 
        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,17 +79,8 @@ data TxCmdError
   | TxCmdCddlWitnessError CddlWitnessError
   | TxCmdRequiredSignerError RequiredSignerError
   -- Validation errors
+  | forall era. TxCmdNotSupportedInAnyCardanoEraValidationError (TxNotSupportedInAnyCardanoEraValidationError era)
   | TxCmdAuxScriptsValidationError TxAuxScriptsValidationError
-  | TxCmdTotalCollateralValidationError TxTotalCollateralValidationError
-  | TxCmdReturnCollateralValidationError TxReturnCollateralValidationError
-  | TxCmdTxValidityLowerBoundValidationError TxValidityLowerBoundValidationError
-  | TxCmdTxValidityUpperBoundValidationError TxValidityUpperBoundValidationError
-  | TxCmdRequiredSignersValidationError TxRequiredSignersValidationError
-  | TxCmdProtocolParametersValidationError TxProtocolParametersValidationError
-  | TxCmdTxWithdrawalsValidationError TxWithdrawalsValidationError
-  | TxCmdTxCertificatesValidationError TxCertificatesValidationError
-  | TxCmdTxUpdateProposalValidationError TxUpdateProposalValidationError
-  | TxCmdScriptValidityValidationError TxScriptValidityValidationError
   | TxCmdProtocolParamsConverstionError ProtocolParametersConversionError
   | forall era. TxCmdTxGovDuplicateVotes (TxGovDuplicateVotes era)
   | forall era. TxCmdFeeEstimationError (TxFeeEstimationError era)
@@ -213,27 +204,9 @@ renderTxCmdError = \case
   TxCmdRequiredSignerError e ->
     prettyError e
   -- Validation errors
-  TxCmdAuxScriptsValidationError e ->
-    prettyError e
-  TxCmdTotalCollateralValidationError e ->
-    prettyError e
-  TxCmdReturnCollateralValidationError e ->
-    prettyError e
-  TxCmdTxValidityLowerBoundValidationError e ->
-    prettyError e
-  TxCmdTxValidityUpperBoundValidationError e ->
-    prettyError e
-  TxCmdRequiredSignersValidationError e ->
+  TxCmdNotSupportedInAnyCardanoEraValidationError e ->
     prettyError e
-  TxCmdProtocolParametersValidationError e ->
-    prettyError e
-  TxCmdTxWithdrawalsValidationError e ->
-    prettyError e
-  TxCmdTxCertificatesValidationError e ->
-    prettyError e
-  TxCmdTxUpdateProposalValidationError e ->
-    prettyError e
-  TxCmdScriptValidityValidationError e ->
+  TxCmdAuxScriptsValidationError e ->
     prettyError e
   TxCmdTxGovDuplicateVotes e ->
     prettyError e