diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index dc6c0b9450..f8fed7c324 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs @@ -71,6 +71,7 @@ import Data.Type.Equality (TestEquality (..)) import Lens.Micro ((^.)) import qualified System.IO as IO + runTransactionCmds :: TransactionCmds era -> ExceptT TxCmdError IO () runTransactionCmds cmd = case cmd of @@ -173,13 +174,13 @@ runTxBuildCmd readFileTextEnvelope AsCertificate (File certFile)) | (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits ] - withdrawalsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError - $ readScriptWitnessFilesThruple era wdrls - txMetadata <- firstExceptT TxCmdMetadataError - . newExceptT $ readTxMetadata era metadataSchema metadataFiles + withdrawalsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError $ + readScriptWitnessFilesThruple era wdrls + txMetadata <- firstExceptT TxCmdMetadataError . newExceptT $ + readTxMetadata era metadataSchema metadataFiles valuesWithScriptWits <- readValueScriptWitnesses era $ fromMaybe mempty mValue scripts <- firstExceptT TxCmdScriptFileError $ - mapM (readFileScriptInAnyLang . unScriptFile) scriptFiles + mapM (readFileScriptInAnyLang . unScriptFile) scriptFiles txAuxScripts <- hoistEither $ first TxCmdAuxScriptsValidationError $ validateTxAuxScripts era scripts mProp <- forM mUpProp $ \(UpdateProposalFile upFp) -> @@ -203,17 +204,15 @@ runTxBuildCmd let filteredTxinsc = Set.toList $ Set.fromList txinsc -- We need to construct the txBodycontent outside of runTxBuild - BalancedTxBody txBodycontent balancedTxBody _ _ <- + BalancedTxBody txBodyContent balancedTxBody _ _ <- runTxBuild era socketPath consensusModeParams nid mScriptValidity inputsAndMaybeScriptWits readOnlyRefIns filteredTxinsc mReturnCollateral mTotCollateral txOuts changeAddr valuesWithScriptWits mLowBound mUpperBound certsAndMaybeScriptWits withdrawalsAndMaybeScriptWits requiredSigners txAuxScripts txMetadata mProp mOverrideWits votes proposals outputOptions - mScriptWits <- - case cardanoEraStyle era of - LegacyByronEra -> return [] - ShelleyBasedEra sbe -> return $ collectTxBodyScriptWitnesses sbe txBodycontent + let mScriptWits = + forEraInEon era [] $ \sbe -> collectTxBodyScriptWitnesses sbe txBodyContent let allReferenceInputs = getAllReferenceInputs inputsAndMaybeScriptWits @@ -230,7 +229,7 @@ runTxBuildCmd -- the script cost vs having to build the tx body each time case outputOptions of OutputScriptCostOnly fp -> do - let BuildTxWith mTxProtocolParams = txProtocolParams txBodycontent + let BuildTxWith mTxProtocolParams = txProtocolParams txBodyContent pparams <- pure mTxProtocolParams & onNothing (left TxCmdProtocolParametersNotPresentInTxBody) executionUnitPrices <- pure (getExecutionUnitPrices era pparams) & onNothing (left TxCmdPParamExecutionUnitsNotAvailable) @@ -519,12 +518,12 @@ runTxBuild dummyFee = Just $ Lovelace 0 inputsThatRequireWitnessing = [input | (input,_) <- inputsAndMaybeScriptWits] - -- Pure let allReferenceInputs = getAllReferenceInputs inputsAndMaybeScriptWits (snd valuesWithScriptWits) certsAndMaybeScriptWits - withdrawals readOnlyRefIns + withdrawals + readOnlyRefIns validatedCollateralTxIns <- hoistEither $ validateTxInsCollateral era txinsc validatedRefInputs <- hoistEither $ validateTxInsReference era allReferenceInputs diff --git a/cardano-cli/src/Cardano/CLI/Read.hs b/cardano-cli/src/Cardano/CLI/Read.hs index 65e186e8ed..bfad5b1618 100644 --- a/cardano-cli/src/Cardano/CLI/Read.hs +++ b/cardano-cli/src/Cardano/CLI/Read.hs @@ -139,6 +139,7 @@ import GHC.IO.Handle.FD (openFileBlocking) import qualified Options.Applicative as Opt import System.IO (IOMode (ReadMode)) + -- Metadata data MetadataError @@ -288,9 +289,9 @@ readScriptWitness era (PlutusScriptWitnessFiles case script' of PlutusScript version pscript -> do datum <- firstExceptT ScriptWitnessErrorScriptData - $ readScriptDatumOrFile datumOrFile + $ readScriptDatumOrFile datumOrFile redeemer <- firstExceptT ScriptWitnessErrorScriptData - $ readScriptRedeemerOrFile redeemerOrFile + $ readScriptRedeemerOrFile redeemerOrFile return $ PlutusScriptWitness langInEra version (PScript pscript) datum @@ -619,6 +620,7 @@ data SomeSigningWitness | AGenesisDelegateExtendedSigningWitness (SigningKey GenesisDelegateExtendedKey) | AGenesisUTxOSigningWitness (SigningKey GenesisUTxOKey) | ADRepSigningWitness (SigningKey DRepKey) + deriving Show -- | Data required for constructing a Shelley bootstrap witness. diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs index 98af501e7e..29e610e7b3 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs @@ -15,8 +15,8 @@ import Cardano.Api.Shelley import Cardano.CLI.Read import Cardano.CLI.Types.Common -import Cardano.CLI.Types.Errors.ProtocolParamsError import Cardano.CLI.Types.Errors.BootstrapWitnessError +import Cardano.CLI.Types.Errors.ProtocolParamsError import Cardano.CLI.Types.Errors.TxValidationError import Cardano.CLI.Types.Output import Cardano.CLI.Types.TxFeature diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs index 068a634b45..790405879d 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -36,6 +34,7 @@ module Cardano.CLI.Types.Errors.TxValidationError ) where import Cardano.Api +import qualified Cardano.Api.Ledger as L import Cardano.Api.Shelley import Prelude @@ -270,30 +269,50 @@ validateTxCertificates era certsAndScriptWitnesses = cardanoEraConstraints era $ reqWits = Map.fromList $ mapMaybe convert certsAndScriptWitnesses pure $ TxCertificates supported certs $ BuildTxWith reqWits where - -- We get the stake credential witness for a certificate that requires it. - -- NB: Only stake address deregistration and delegation requires - -- witnessing (witness can be script or key) - deriveStakeCredentialWitness - :: Certificate era - -> Maybe StakeCredential - deriveStakeCredentialWitness _cert = Nothing - -- case cert of - -- -- TODO: Conway era - -- -- StakeAddressDeregistrationCertificate sCred -> Just sCred - -- -- StakeAddressPoolDelegationCertificate sCred _ -> Just sCred - -- _ -> Nothing - - convert - :: (Certificate era, Maybe (ScriptWitness WitCtxStake era)) - -> Maybe (StakeCredential, Witness WitCtxStake era) - convert (cert, mScriptWitnessFiles) = do - sCred <- deriveStakeCredentialWitness cert - case mScriptWitnessFiles of - Just sWit -> do - Just ( sCred - , ScriptWitness ScriptWitnessForStakeAddr sWit - ) - Nothing -> Just (sCred, KeyWitness KeyWitnessForStakeAddr) + -- We get the stake credential witness for a certificate that requires it. + -- NB: Only stake address deregistration and delegation requires + -- witnessing (witness can be script or key) + deriveStakeCredentialWitness + :: Certificate era + -> Maybe StakeCredential + deriveStakeCredentialWitness = fmap fromShelleyStakeCredential . \case + ShelleyRelatedCertificate stbEra shelleyCert -> shelleyToBabbageEraConstraints stbEra $ + case shelleyCert of + L.RegTxCert _sCred -> Nothing -- not required + L.UnRegTxCert sCred -> Just sCred + L.DelegStakeTxCert sCred _ -> Just sCred + L.RegPoolTxCert _ -> Nothing + L.RetirePoolTxCert _ _ -> Nothing + L.MirTxCert _ -> Nothing + L.GenesisDelegTxCert{} -> Nothing + + ConwayCertificate cEra conwayCert -> conwayEraOnwardsConstraints cEra $ + case conwayCert of + L.RegPoolTxCert _ -> Nothing + L.RetirePoolTxCert _ _ -> Nothing + L.RegTxCert _ -> Nothing + L.UnRegTxCert sCred -> Just sCred + L.RegDepositTxCert _ _ -> Nothing + L.UnRegDepositTxCert sCred _ -> Just sCred + L.DelegTxCert sCred _ -> Just sCred + L.RegDepositDelegTxCert sCred _ _ -> Just sCred + L.AuthCommitteeHotKeyTxCert{} -> Nothing + L.ResignCommitteeColdTxCert _ -> Nothing + L.RegDRepTxCert{} -> Nothing + L.UnRegDRepTxCert{} -> Nothing + L.UpdateDRepTxCert{} -> Nothing + + convert + :: (Certificate era, Maybe (ScriptWitness WitCtxStake era)) + -> Maybe (StakeCredential, Witness WitCtxStake era) + convert (cert, mScriptWitnessFiles) = do + sCred <- deriveStakeCredentialWitness cert + case mScriptWitnessFiles of + Just sWit -> do + Just ( sCred + , ScriptWitness ScriptWitnessForStakeAddr sWit + ) + Nothing -> Just (sCred, KeyWitness KeyWitnessForStakeAddr) newtype TxProtocolParametersValidationError = ProtocolParametersNotSupported AnyCardanoEra