From 7965ce2b1964ee7ae60e3bbd61263bd5071f0032 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Mon, 18 Nov 2024 21:12:27 +0100 Subject: [PATCH] Add certs to compatible transaction build command --- .../src/Cardano/CLI/Compatible/Transaction.hs | 81 ++++++++++++++++++- .../Cardano/CLI/EraBased/Run/Transaction.hs | 21 ++--- 2 files changed, 83 insertions(+), 19 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs b/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs index a1ffb8cee0..b1f35324b6 100644 --- a/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Cardano.CLI.Compatible.Transaction @@ -27,10 +28,14 @@ import Cardano.CLI.Types.Common import Cardano.CLI.Types.Errors.BootstrapWitnessError import Cardano.CLI.Types.Errors.TxCmdError import Cardano.CLI.Types.Governance +import Cardano.CLI.Types.TxFeature +import Data.Bifunctor (first) import Data.Foldable import Data.Function +import Data.Maybe import Data.Text (Text) +import GHC.Exts (IsList (..)) import Options.Applicative import qualified Options.Applicative as Opt @@ -64,6 +69,7 @@ pCompatibleSignedTransaction env sbe = <*> many pWitnessSigningData <*> optional (pNetworkId env) <*> pTxFee + <*> many (pCertificateFile sbe ManualBalance) <*> pOutputFile pTxInOnly :: Parser TxIn @@ -178,13 +184,15 @@ data CompatibleTransactionCmds era (Maybe NetworkId) !Coin -- ^ Tx fee + ![(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] + -- ^ stake registering certs !(File () Out) renderCompatibleTransactionCmd :: CompatibleTransactionCmds era -> Text renderCompatibleTransactionCmd _ = "" data CompatibleTransactionError - = CompatibleTxOutError !TxCmdError + = CompatibleTxCmdError !TxCmdError | CompatibleWitnessError !ReadWitnessSigningDataError | CompatiblePParamsConversionError !ProtocolParametersConversionError | CompatibleBootstrapWitnessError !BootstrapWitnessError @@ -193,10 +201,11 @@ data CompatibleTransactionError | CompatibleProposalError !ProposalError | CompatibleVoteError !VoteError | forall era. CompatibleVoteMergeError !(VotesMergingConflict era) + | CompatibleScriptWitnessError !ScriptWitnessError instance Error CompatibleTransactionError where prettyError = \case - CompatibleTxOutError e -> renderTxCmdError e + CompatibleTxCmdError e -> renderTxCmdError e CompatibleWitnessError e -> renderReadWitnessSigningDataError e CompatiblePParamsConversionError e -> prettyError e CompatibleBootstrapWitnessError e -> renderBootstrapWitnessError e @@ -205,9 +214,12 @@ instance Error CompatibleTransactionError where CompatibleProposalError e -> pshow e CompatibleVoteError e -> pshow e CompatibleVoteMergeError e -> pshow e + CompatibleScriptWitnessError e -> renderScriptWitnessError e runCompatibleTransactionCmd - :: CompatibleTransactionCmds era -> ExceptT CompatibleTransactionError IO () + :: forall era + . CompatibleTransactionCmds era + -> ExceptT CompatibleTransactionError IO () runCompatibleTransactionCmd ( CreateCompatibleSignedTransaction sbe @@ -219,11 +231,35 @@ runCompatibleTransactionCmd witnesses mNetworkId fee + certificates outputFp ) = do sks <- firstExceptT CompatibleWitnessError $ mapM (newExceptT . readWitnessSigningData) witnesses - allOuts <- firstExceptT CompatibleTxOutError $ mapM (toTxOutInAnyEra sbe) outs + allOuts <- firstExceptT CompatibleTxCmdError $ mapM (toTxOutInAnyEra sbe) outs + + certFilesAndMaybeScriptWits <- + firstExceptT CompatibleScriptWitnessError $ + readScriptWitnessFiles sbe certificates + + certsAndMaybeScriptWits :: [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] <- + shelleyBasedEraConstraints sbe $ + sequence + [ fmap + (,mSwit) + ( firstExceptT CompatibleFileError . newExceptT $ + readFileTextEnvelope AsCertificate (File certFile) + ) + | (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits + ] + + let refInputs = + [ refInput + | (_, Just sWit) <- certsAndMaybeScriptWits + , refInput <- maybeToList $ getScriptWitnessReferenceInput sWit + ] + -- TODO is this missing something? see EraBased.Run.Transaction L907 + validatedRefInputs <- liftEither . first CompatibleTxCmdError $ validateTxInsReference refInputs apiTxBody <- firstExceptT CompatibleTxBodyError $ @@ -233,6 +269,8 @@ runCompatibleTransactionCmd & setTxIns (map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) ins) & setTxOuts allOuts & setTxFee (TxFeeExplicit sbe fee) + & setTxCertificates (convertCertificates certsAndMaybeScriptWits) + & setTxInsReference validatedRefInputs let (sksByron, sksShelley) = partitionSomeWitnesses $ map categoriseSomeSigningWitness sks @@ -265,6 +303,41 @@ runCompatibleTransactionCmd firstExceptT CompatibleFileError $ newExceptT $ writeTxFileTextEnvelopeCddl sbe outputFp signedTx + where + -- TODO it's copied from EraBased/Run/Transaction + convertCertificates + :: [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] + -> TxCertificates BuildTx era + convertCertificates certsAndScriptWitnesses = + TxCertificates sbe certs $ BuildTxWith reqWits + where + certs = map fst certsAndScriptWitnesses + reqWits = 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) + + -- TODO it's copied from EraBased.Run.Transaction. + validateTxInsReference + :: [TxIn] + -> Either TxCmdError (TxInsReference era) + validateTxInsReference [] = return TxInsReferenceNone + validateTxInsReference allRefIns = do + forShelleyBasedEraInEonMaybe sbe (`TxInsReference` allRefIns) + & maybe (txFeatureMismatchPure (toCardanoEra sbe) TxFeatureReferenceInputs) Right + + -- TODO it's copied from EraBased.Run.Transaction + txFeatureMismatchPure + :: CardanoEra era + -> TxFeature + -> Either TxCmdError a + txFeatureMismatchPure era feature = + Left (TxCmdTxFeatureMismatch (anyCardanoEra era) feature) readUpdateProposalFile :: Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index 93cc93f889..084493c271 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs @@ -1226,12 +1226,12 @@ getAllReferenceInputs votingProceduresAndMaybeScriptWits propProceduresAnMaybeScriptWits readOnlyRefIns = do - let txinsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- txins] - mintingRefInputs = map getReferenceInput mintWitnesses - certsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- certFiles] - withdrawalsWitByRefInputs = [getReferenceInput sWit | (_, _, Just sWit) <- withdrawals] - votesWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- votingProceduresAndMaybeScriptWits] - propsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- propProceduresAnMaybeScriptWits] + let txinsWitByRefInputs = [getScriptWitnessReferenceInput sWit | (_, Just sWit) <- txins] + mintingRefInputs = map getScriptWitnessReferenceInput mintWitnesses + certsWitByRefInputs = [getScriptWitnessReferenceInput sWit | (_, Just sWit) <- certFiles] + withdrawalsWitByRefInputs = [getScriptWitnessReferenceInput sWit | (_, _, Just sWit) <- withdrawals] + votesWitByRefInputs = [getScriptWitnessReferenceInput sWit | (_, Just sWit) <- votingProceduresAndMaybeScriptWits] + propsWitByRefInputs = [getScriptWitnessReferenceInput sWit | (_, Just sWit) <- propProceduresAnMaybeScriptWits] concatMap catMaybes @@ -1243,15 +1243,6 @@ getAllReferenceInputs , propsWitByRefInputs , map Just readOnlyRefIns ] - where - getReferenceInput - :: ScriptWitness witctx era -> Maybe TxIn - getReferenceInput sWit = - case sWit of - PlutusScriptWitness _ _ (PReferenceScript refIn) _ _ _ -> Just refIn - PlutusScriptWitness _ _ PScript{} _ _ _ -> Nothing - SimpleScriptWitness _ (SReferenceScript refIn) -> Just refIn - SimpleScriptWitness _ SScript{} -> Nothing toAddressInAnyEra :: CardanoEra era