From 99e3ae7ee1067d97eb489c4f8f4f16ab36d550a6 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Mon, 25 Sep 2023 07:25:57 +0200 Subject: [PATCH] #299 Fix 'MissingRedeemers' error when deregistering Plutus stake address --- .../Cardano/CLI/EraBased/Run/Transaction.hs | 15 ++-- cardano-cli/src/Cardano/CLI/Read.hs | 6 +- .../Cardano/CLI/Types/Errors/TxCmdError.hs | 2 +- .../CLI/Types/Errors/TxValidationError.hs | 71 ++++++++++++------- 4 files changed, 58 insertions(+), 36 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index e40774de03..37dfd8dcff 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) -> @@ -517,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 52c5b8be1e..a5aa8cabbc 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 @@ -620,6 +621,7 @@ data SomeSigningWitness | AGenesisUTxOSigningWitness (SigningKey GenesisUTxOKey) | ADRepSigningWitness (SigningKey DRepKey) | ACommitteeSigningWitness (SigningKey CommitteeColdKey) + 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 952870dfe9..ad14c7b7de 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 #-} @@ -37,6 +35,7 @@ module Cardano.CLI.Types.Errors.TxValidationError ) where import Cardano.Api +import qualified Cardano.Api.Ledger as L import Cardano.Api.Shelley import Prelude @@ -247,30 +246,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