From f42b8c60f180ed5e576a05a5daf424546f92d90a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Hurlin?= Date: Fri, 7 Jun 2024 11:26:35 +0200 Subject: [PATCH] Transaction: propagate ShelleyBasedEra instead of CardanoEra --- .../Cardano/CLI/EraBased/Run/Transaction.hs | 25 ++++----- .../CLI/Types/Errors/TxValidationError.hs | 56 +++++++++---------- 2 files changed, 40 insertions(+), 41 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index b308d51121..c391d091a9 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs @@ -660,8 +660,7 @@ constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits rea reqSigners fee txAuxScripts txMetadata txUpdateProposal votingProcedures proposals mCurrentTreasuryValue mTreasuryDonation = do - let era = toCardanoEra sbe -- TODO: Propagate SBE - allReferenceInputs = getAllReferenceInputs + let allReferenceInputs = getAllReferenceInputs inputsAndMaybeScriptWits (snd valuesWithScriptWits) certsAndMaybeScriptWits @@ -672,17 +671,17 @@ constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits rea validatedCollateralTxIns <- validateTxInsCollateral sbe txinsc validatedRefInputs <- validateTxInsReference sbe allReferenceInputs - validatedTotCollateral <- first TxCmdNotSupportedInEraValidationError $ validateTxTotalCollateral era mTotCollateral - validatedRetCol <- first TxCmdNotSupportedInEraValidationError $ validateTxReturnCollateral era mReturnCollateral + validatedTotCollateral <- first TxCmdNotSupportedInEraValidationError $ validateTxTotalCollateral sbe mTotCollateral + validatedRetCol <- first TxCmdNotSupportedInEraValidationError $ validateTxReturnCollateral sbe mReturnCollateral let txFee = TxFeeExplicit sbe fee - validatedLowerBound <- first TxCmdNotSupportedInEraValidationError $ validateTxValidityLowerBound era mLowerBound - validatedReqSigners <- first TxCmdNotSupportedInEraValidationError $ validateRequiredSigners era reqSigners - validatedTxWtdrwls <- first TxCmdNotSupportedInEraValidationError $ validateTxWithdrawals era withdrawals - validatedTxCerts <- first TxCmdNotSupportedInEraValidationError $ validateTxCertificates era certsAndMaybeScriptWits + validatedLowerBound <- first TxCmdNotSupportedInEraValidationError $ validateTxValidityLowerBound sbe mLowerBound + validatedReqSigners <- first TxCmdNotSupportedInEraValidationError $ validateRequiredSigners sbe reqSigners + validatedTxWtdrwls <- first TxCmdNotSupportedInEraValidationError $ validateTxWithdrawals sbe withdrawals + validatedTxCerts <- first TxCmdNotSupportedInEraValidationError $ validateTxCertificates sbe certsAndMaybeScriptWits validatedMintValue <- createTxMintValue sbe valuesWithScriptWits - validatedTxScriptValidity <- first TxCmdNotSupportedInEraValidationError $ validateTxScriptValidity era mScriptValidity + validatedTxScriptValidity <- first TxCmdNotSupportedInEraValidationError $ validateTxScriptValidity sbe mScriptValidity validatedVotingProcedures <- first TxCmdTxGovDuplicateVotes $ convertToTxVotingProcedures votingProcedures - validatedPParams <- first TxCmdNotSupportedInEraValidationError $ validateProtocolParameters era (LedgerProtocolParameters <$> mPparams) + validatedPParams <- first TxCmdNotSupportedInEraValidationError $ validateProtocolParameters sbe (LedgerProtocolParameters <$> mPparams) validatedCurrentTreasuryValue <- first TxCmdNotSupportedInEraValidationError (validateTxCurrentTreasuryValue sbe mCurrentTreasuryValue) validatedTreasuryDonation <- first TxCmdNotSupportedInEraValidationError (validateTxTreasuryDonation sbe mTreasuryDonation) return $ shelleyBasedEraConstraints sbe $ (defaultTxBodyContent sbe @@ -705,8 +704,8 @@ constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits rea & 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) } & setTxCurrentTreasuryValue validatedCurrentTreasuryValue & setTxTreasuryDonation validatedTreasuryDonation @@ -793,7 +792,7 @@ runTxBuild validatedTxCerts <- hoistEither . first TxCmdNotSupportedInEraValidationError - $ validateTxCertificates era certsAndMaybeScriptWits + $ validateTxCertificates sbe certsAndMaybeScriptWits let certs = case validatedTxCerts of diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs index 595cbf8acc..80628eb899 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs @@ -89,12 +89,12 @@ instance Error (TxNotSupportedInEraValidationError era) where where go a cEra = pretty a <+> "not supported in" <+> viaShow cEra -validateTxTotalCollateral :: CardanoEra era +validateTxTotalCollateral :: ShelleyBasedEra era -> Maybe L.Coin -> Either (TxNotSupportedInEraValidationError era) (TxTotalCollateral era) validateTxTotalCollateral _ Nothing = return TxTotalCollateralNone -validateTxTotalCollateral era (Just coll) = do - supported <- conjureWitness era $ TxNotSupportedInAnyCardanoEraValidationError "Transaction collateral" +validateTxTotalCollateral sbe (Just coll) = do + supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction collateral" pure $ TxTotalCollateral supported coll validateTxCurrentTreasuryValue :: () @@ -123,20 +123,20 @@ validateTxTreasuryDonation sbe mTreasuryDonation = (\cOnwards -> Right $ Just $ Featured cOnwards unTxTreasuryDonation ) sbe -validateTxReturnCollateral :: CardanoEra era +validateTxReturnCollateral :: ShelleyBasedEra era -> Maybe (TxOut CtxTx era) -> Either (TxNotSupportedInEraValidationError era) (TxReturnCollateral CtxTx era) validateTxReturnCollateral _ Nothing = return TxReturnCollateralNone -validateTxReturnCollateral era (Just retColTxOut) = do - supported <- conjureWitness era $ TxNotSupportedInAnyCardanoEraValidationError "Transaction return collateral" +validateTxReturnCollateral sbe (Just retColTxOut) = do + supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction return collateral" pure $ TxReturnCollateral supported retColTxOut -validateTxValidityLowerBound :: CardanoEra era +validateTxValidityLowerBound :: ShelleyBasedEra era -> Maybe SlotNo -> Either (TxNotSupportedInEraValidationError era) (TxValidityLowerBound era) validateTxValidityLowerBound _ Nothing = return TxValidityNoLowerBound -validateTxValidityLowerBound era (Just slot) = do - supported <- conjureWitness era $ TxNotSupportedInAnyCardanoEraValidationError "Transaction validity lower bound" +validateTxValidityLowerBound sbe (Just slot) = do + supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction validity lower bound" pure $ TxValidityLowerBound supported slot data TxAuxScriptsValidationError @@ -161,22 +161,21 @@ validateTxAuxScripts era scripts = do pure $ TxAuxScripts supported scriptsInEra validateRequiredSigners - :: CardanoEra era + :: ShelleyBasedEra era -> [Hash PaymentKey] -> Either (TxNotSupportedInEraValidationError era) (TxExtraKeyWitnesses era) validateRequiredSigners _ [] = return TxExtraKeyWitnessesNone -validateRequiredSigners era reqSigs = do - supported <- conjureWitness era $ TxNotSupportedInAnyCardanoEraValidationError "Transaction required signers" +validateRequiredSigners sbe reqSigs = do + supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction required signers" pure $ TxExtraKeyWitnesses supported reqSigs validateTxWithdrawals - :: forall era. - CardanoEra era + :: ShelleyBasedEra era -> [(StakeAddress, L.Coin, Maybe (ScriptWitness WitCtxStake era))] -> Either (TxNotSupportedInEraValidationError era) (TxWithdrawals BuildTx era) validateTxWithdrawals _ [] = return TxWithdrawalsNone -validateTxWithdrawals era withdrawals = do - supported <- conjureWitness era $ TxNotSupportedInAnyCardanoEraValidationError "Transaction withdrawals" +validateTxWithdrawals sbe withdrawals = do + supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction withdrawals" let convWithdrawals = map convert withdrawals pure $ TxWithdrawals supported convWithdrawals where @@ -189,16 +188,15 @@ validateTxWithdrawals era withdrawals = do Nothing -> (sAddr, ll, BuildTxWith $ KeyWitness KeyWitnessForStakeAddr) -- TODO: Because we have separated Byron related transaction --- construction into separate commands, we can parameterize this --- on ShelleyBasedEra era and remove Either TxCertificatesValidationError +-- construction into separate commands, we can remove +-- Either TxNotSupportedInEraValidationError validateTxCertificates - :: forall era. - CardanoEra era + :: ShelleyBasedEra era -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] -> Either (TxNotSupportedInEraValidationError era) (TxCertificates BuildTx era) validateTxCertificates _ [] = return TxCertificatesNone -validateTxCertificates era certsAndScriptWitnesses = cardanoEraConstraints era $ do - supported <- conjureWitness era $ TxNotSupportedInAnyCardanoEraValidationError "Transaction certificates" +validateTxCertificates sbe certsAndScriptWitnesses = shelleyBasedEraConstraints sbe $ do + supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction certificates" let certs = map fst certsAndScriptWitnesses reqWits = Map.fromList $ mapMaybe convert certsAndScriptWitnesses pure $ TxCertificates supported certs $ BuildTxWith reqWits @@ -213,21 +211,21 @@ validateTxCertificates era certsAndScriptWitnesses = cardanoEraConstraints era $ Nothing -> (sCred, KeyWitness KeyWitnessForStakeAddr) validateProtocolParameters - :: CardanoEra era + :: ShelleyBasedEra era -> Maybe (LedgerProtocolParameters era) -> Either (TxNotSupportedInEraValidationError era) (BuildTxWith BuildTx (Maybe (LedgerProtocolParameters era))) validateProtocolParameters _ Nothing = return (BuildTxWith Nothing) -validateProtocolParameters era (Just pparams) = do - _ <- conjureWitness @ShelleyBasedEra era $ TxNotSupportedInAnyCardanoEraValidationError "Transaction protocol parameters" +validateProtocolParameters sbe (Just pparams) = do + _ <- conjureWitness @ShelleyBasedEra (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction protocol parameters" pure . BuildTxWith $ Just pparams validateTxScriptValidity - :: CardanoEra era + :: ShelleyBasedEra era -> Maybe ScriptValidity -> Either (TxNotSupportedInEraValidationError era) (TxScriptValidity era) validateTxScriptValidity _ Nothing = pure TxScriptValidityNone -validateTxScriptValidity era (Just scriptValidity) = do - supported <- conjureWitness era $ TxNotSupportedInAnyCardanoEraValidationError "Transaction script validity" +validateTxScriptValidity sbe (Just scriptValidity) = do + supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction script validity" pure $ TxScriptValidity supported scriptValidity -- TODO legacy. This can be deleted when legacy commands are removed. @@ -241,6 +239,8 @@ validateUpdateProposalFile era = \case supported <- conjureWitness era $ TxNotSupportedInAnyCardanoEraValidationError "Transaction update proposal" pure $ Just $ Featured supported $ Just updateProposal +-- TODO make this function take a ShelleyBasedEra when the last +-- CardanoEra caller is removed (there remains only one). conjureWitness :: Eon eon => CardanoEra era -- ^ era to try to conjure eon from -> (AnyCardanoEra -> e) -- ^ error wrapper function