Skip to content

Commit

Permalink
Define TransactionBuildEstimateCmdArgs data type and implement runTra…
Browse files Browse the repository at this point in the history 
…nsactionBuildEstimateCmd
  • Loading branch information
@Jimbo4350
Jimbo4350 committed Apr 25, 2024
1 parent b9676b9 commit 282803a
Show file tree
Hide file tree
Showing 4 changed files with 237 additions and 37 deletions.
65 changes: 64 additions & 1 deletion cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,6 +6,7 @@ module Cardano.CLI.EraBased.Commands.Transaction
( TransactionCmds (..)
, TransactionBuildRawCmdArgs(..)
, TransactionBuildCmdArgs(..)
, TransactionBuildEstimateCmdArgs(..)
, TransactionSignCmdArgs(..)
, TransactionWitnessCmdArgs(..)
, TransactionSignWitnessCmdArgs(..)
Expand All @@ -21,16 +22,20 @@ module Cardano.CLI.EraBased.Commands.Transaction
) where

import Cardano.Api.Ledger (Coin)
import qualified Cardano.Api.Ledger as L
import Cardano.Api.Shelley

import Cardano.CLI.Types.Common
import Cardano.CLI.Types.Governance

import Data.Map.Strict (Map)
import Data.Set (Set)
import Data.Text (Text)

data TransactionCmds era
= TransactionBuildRawCmd !(TransactionBuildRawCmdArgs era)
| TransactionBuildCmd !(TransactionBuildCmdArgs era)
| TransactionBuildEstimateCmd !(TransactionBuildEstimateCmdArgs era)
| TransactionSignCmd !TransactionSignCmdArgs
| TransactionWitnessCmd !TransactionWitnessCmdArgs
| TransactionSignWitnessCmd !TransactionSignWitnessCmdArgs
Expand Down Expand Up @@ -121,12 +126,69 @@ data TransactionBuildCmdArgs era = TransactionBuildCmdArgs
, scriptFiles :: ![ScriptFile]
-- ^ Auxiliary scripts
, metadataFiles :: ![MetadataFile]
, mfUpdateProposalFile :: !(Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile)))
, mUpdateProposalFile :: !(Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile)))
, voteFiles :: ![(VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake))]
, proposalFiles :: ![(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))]
, buildOutputOptions :: !TxBuildOutputOptions
} deriving Show

-- | Like 'TransactionBuildCmd' but does not require explicit access to a running node
data TransactionBuildEstimateCmdArgs era = TransactionBuildEstimateCmdArgs
{ eon :: !(ShelleyBasedEra era)
, mScriptValidity :: !(Maybe ScriptValidity)
-- ^ Mark script as expected to pass or fail validation
, shelleyWitnesses :: !Int
-- ^ Number of shelley witnesses to be added
, mByronWitnesses :: !(Maybe Int)
, protocolParamsFile :: !ProtocolParamsFile
, totalUTxOValue :: !Value
, txins :: ![(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))]
-- ^ Transaction inputs with optional spending scripts
, readOnlyReferenceInputs :: ![TxIn]
-- ^ Read only reference inputs
, requiredSigners :: ![RequiredSigner]
-- ^ Required signers
, txinsc :: ![TxIn]
-- ^ Transaction inputs for collateral, only key witnesses, no scripts.
, mReturnCollateral :: !(Maybe TxOutShelleyBasedEra)
-- ^ Return collateral
, totalCollateral :: !Coin
-- ^ Total collateral
, txouts :: ![TxOutAnyEra]
-- ^ Normal outputs
, changeAddress :: !TxOutChangeAddress
-- ^ A change output
, mValue :: !(Maybe (Value, [ScriptWitnessFiles WitCtxMint]))
-- ^ Multi-Asset value with script witness
, mValidityLowerBound :: !(Maybe SlotNo)
-- ^ Transaction validity lower bound
, mValidityUpperBound :: !(TxValidityUpperBound era)
-- ^ Transaction validity upper bound
, certificates :: ![(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))]
-- ^ Certificates with potential script witness
, withdrawals :: ![(StakeAddress, Coin, Maybe (ScriptWitnessFiles WitCtxStake))]
-- ^ Withdrawals with potential script witness
, drepsToDeregister :: !(Map (L.Credential L.DRepRole L.StandardCrypto) L.Coin)
-- ^ Map of all deposits for drep credentials that are being
-- unregistered in this transaction
, stakeCredentialsToDeregister :: !(Map StakeCredential L.Coin)
-- ^ Map of all deposits for stake credentials that are being
-- unregistered in this transaction)
, plutusExecutionUnits :: !(Map ScriptWitnessIndex ExecutionUnits)
-- ^ Plutus script execution units
, totalReferenceScriptSize :: !(Maybe Int)
-- ^ Size of all reference scripts in bytes
, metadataSchema :: !TxMetadataJsonSchema
, scriptFiles :: ![ScriptFile]
-- ^ Auxiliary scripts
, metadataFiles :: ![MetadataFile]
, mUpdateProposalFile :: !(Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile)))
, voteFiles :: ![(VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake))]
, proposalFiles :: ![(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))]
, poolsToDeregister :: !(Set PoolId)
, txBodyOutFile :: !(TxBodyFile Out)
}

data TransactionSignCmdArgs = TransactionSignCmdArgs
{ txOrTxBodyFile :: !InputTxBodyOrTxFile
, witnessSigningData :: ![WitnessSigningData]
Expand Down Expand Up @@ -190,6 +252,7 @@ data TransactionViewCmdArgs = TransactionViewCmdArgs
renderTransactionCmds :: TransactionCmds era -> Text
renderTransactionCmds = \case
TransactionBuildCmd {} -> "transaction build"
TransactionBuildEstimateCmd {} -> "transaction build-estimate"
TransactionBuildRawCmd {} -> "transaction build-raw"
TransactionSignCmd {} -> "transaction sign"
TransactionWitnessCmd {} -> "transaction witness"
Expand Down
193 changes: 162 additions & 31 deletions cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -78,6 +78,7 @@ import qualified System.IO as IO
runTransactionCmds :: Cmd.TransactionCmds era -> ExceptT TxCmdError IO ()
runTransactionCmds = \case
Cmd.TransactionBuildCmd args -> runTransactionBuildCmd args
Cmd.TransactionBuildEstimateCmd args -> runTransactionBuildEstimateCmd args
Cmd.TransactionBuildRawCmd args -> runTransactionBuildRawCmd args
Cmd.TransactionSignCmd args -> runTransactionSignCmd args
Cmd.TransactionSubmitCmd args -> runTransactionSubmitCmd args
Expand Down Expand Up @@ -121,7 +122,7 @@ runTransactionBuildCmd
, metadataSchema
, scriptFiles
, metadataFiles
, mfUpdateProposalFile
, mUpdateProposalFile
, voteFiles
, proposalFiles
, buildOutputOptions
Expand Down Expand Up @@ -157,7 +158,7 @@ runTransactionBuildCmd
mapM (readFileScriptInAnyLang . unFile) scriptFiles
txAuxScripts <- hoistEither $ first TxCmdAuxScriptsValidationError $ validateTxAuxScripts eon scripts

mProp <- case mfUpdateProposalFile of
mProp <- case mUpdateProposalFile of
Just (Featured w (Just updateProposalFile)) ->
readTxUpdateProposal w updateProposalFile & firstExceptT TxCmdReadTextViewFileError
_ -> pure TxUpdateProposalNone
Expand Down Expand Up @@ -245,6 +246,136 @@ runTransactionBuildCmd
in lift (cardanoEraConstraints era $ writeTxFileTextEnvelopeCddl eon fpath noWitTx)
& onLeft (left . TxCmdWriteFileError)

runTransactionBuildEstimateCmd
:: ()
=> Cmd.TransactionBuildEstimateCmdArgs era
-> ExceptT TxCmdError IO ()
runTransactionBuildEstimateCmd
Cmd.TransactionBuildEstimateCmdArgs
{ eon
, mScriptValidity
, shelleyWitnesses
, mByronWitnesses
, protocolParamsFile
, totalUTxOValue
, txins
, readOnlyReferenceInputs = readOnlyRefIns
, requiredSigners = reqSigners
, txinsc = txInsCollateral
, mReturnCollateral = mReturnColl
, totalCollateral
, txouts
, changeAddress = TxOutChangeAddress changeAddr
, mValue
, mValidityLowerBound
, mValidityUpperBound
, certificates
, withdrawals
, metadataSchema
, scriptFiles
, metadataFiles
, mUpdateProposalFile
, voteFiles
, proposalFiles
, poolsToDeregister = poolids
, drepsToDeregister
, stakeCredentialsToDeregister
, plutusExecutionUnits
, totalReferenceScriptSize
, txBodyOutFile
} = do
legacyPParams <- firstExceptT TxCmdProtocolParamsError $ readProtocolParameters protocolParamsFile
ledgerPParams <- hoistEither . first TxCmdProtocolParamsConverstionError
$ convertToLedgerProtocolParameters eon legacyPParams
inputsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError
$ readScriptWitnessFiles eon txins
certFilesAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError
$ readScriptWitnessFiles eon certificates

withdrawalsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError
$ readScriptWitnessFilesTuple eon withdrawals
txMetadata <- firstExceptT TxCmdMetadataError
. newExceptT $ readTxMetadata eon metadataSchema metadataFiles
valuesWithScriptWits <- readValueScriptWitnesses eon $ fromMaybe mempty mValue
scripts <- firstExceptT TxCmdScriptFileError $
mapM (readFileScriptInAnyLang . unFile) scriptFiles
txAuxScripts <- hoistEither $ first TxCmdAuxScriptsValidationError $ validateTxAuxScripts eon scripts


txUpdateProposal <- case mUpdateProposalFile of
Just (Featured w (Just updateProposalFile)) ->
readTxUpdateProposal w updateProposalFile & firstExceptT TxCmdReadTextViewFileError
_ -> pure TxUpdateProposalNone

requiredSigners <- mapM (firstExceptT TxCmdRequiredSignerError . newExceptT . readRequiredSigner) reqSigners

mReturnCollateral <- case mReturnColl of
Nothing -> return Nothing
Just retColl -> do
txOut <- toTxOutInShelleyBasedEra eon retColl
return $ Just txOut

txOuts <- mapM (toTxOutInAnyEra eon) txouts

-- the same collateral input can be used for several plutus scripts
let filteredTxinsc = Set.toList $ Set.fromList txInsCollateral

-- Conway related
votingProceduresAndMaybeScriptWits <-
inEonForShelleyBasedEra
(pure mempty)
(\w -> firstExceptT TxCmdVoteError . ExceptT $ conwayEraOnwardsConstraints w $ readVotingProceduresFiles w voteFiles)
eon

proposals <-
lift (readTxGovernanceActions eon proposalFiles)
& onLeft (left . TxCmdProposalError)

certsAndMaybeScriptWits <-
shelleyBasedEraConstraints eon $
sequence
[ fmap (,mSwit) (firstExceptT TxCmdReadTextViewFileError . newExceptT $
readFileTextEnvelope AsCertificate (File certFile))
| (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits
]

txBodyContent <- hoistEither $ constructTxBodyContent
eon mScriptValidity
(Just $ unLedgerProtocolParameters ledgerPParams)
inputsAndMaybeScriptWits
readOnlyRefIns
filteredTxinsc
mReturnCollateral
(Just totalCollateral)
txOuts
mValidityLowerBound
mValidityUpperBound
valuesWithScriptWits
certsAndMaybeScriptWits
withdrawalsAndMaybeScriptWits
requiredSigners
Nothing
txAuxScripts
txMetadata
txUpdateProposal
votingProceduresAndMaybeScriptWits
proposals

BalancedTxBody _ balancedTxBody _ _ <-
forShelleyBasedEraInEon
eon
(left undefined)
(\w -> hoistEither $ first TxCmdFeeEstimationError $
estimateBalancedTxBody w txBodyContent (unLedgerProtocolParameters ledgerPParams) poolids
stakeCredentialsToDeregister drepsToDeregister
plutusExecutionUnits totalCollateral shelleyWitnesses (fromMaybe 0 mByronWitnesses)
(fromMaybe 0 totalReferenceScriptSize) (anyAddressInShelleyBasedEra eon changeAddr)
totalUTxOValue
)
let noWitTx = makeSignedTransaction [] balancedTxBody
lift (writeTxFileTextEnvelopeCddl eon txBodyOutFile noWitTx)
& onLeft (left . TxCmdWriteFileError)

getExecutionUnitPrices :: CardanoEra era -> LedgerProtocolParameters era -> Maybe L.Prices
getExecutionUnitPrices cEra (LedgerProtocolParameters pp) =
forEraInEonMaybe cEra $ \aeo ->
Expand Down Expand Up @@ -403,8 +534,8 @@ runTxBuildRaw sbe

first TxCmdTxBodyError $ createAndValidateTransactionBody sbe txBodyContent

constructTxBodyContent
:: ShelleyBasedEra era
constructTxBodyContent
:: ShelleyBasedEra era
-> Maybe ScriptValidity
-> Maybe (L.PParams (ShelleyLedgerEra era))
-> [(TxIn, Maybe (ScriptWitness WitCtxTxIn era))]
Expand Down Expand Up @@ -439,13 +570,13 @@ constructTxBodyContent
-> [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))]
-> [(Proposal era, Maybe (ScriptWitness WitCtxStake era))]
-> Either TxCmdError (TxBodyContent BuildTx era)
constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits readOnlyRefIns txinsc
mReturnCollateral mTotCollateral txouts mLowerBound mUpperBound
valuesWithScriptWits certsAndMaybeScriptWits withdrawals
constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits readOnlyRefIns txinsc
mReturnCollateral mTotCollateral txouts mLowerBound mUpperBound
valuesWithScriptWits certsAndMaybeScriptWits withdrawals
reqSigners mFee txAuxScripts txMetadata txUpdateProposal
votingProcedures proposals
= do
let era = toCardanoEra sbe -- TODO: Propagate SBE
= do
let era = toCardanoEra sbe -- TODO: Propagate SBE
allReferenceInputs = getAllReferenceInputs
inputsAndMaybeScriptWits
(snd valuesWithScriptWits)
Expand Down Expand Up @@ -475,7 +606,7 @@ constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits rea
& setTxIns (validateTxIns inputsAndMaybeScriptWits)
& setTxInsCollateral validatedCollateralTxIns
& setTxInsReference validatedRefInputs
& setTxOuts txouts
& setTxOuts txouts
& setTxTotalCollateral validatedTotCollateral
& setTxReturnCollateral validatedRetCol
& setTxFee dFee
Expand All @@ -497,7 +628,7 @@ constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits rea





runTxBuild :: ()
=> ShelleyBasedEra era
Expand Down Expand Up @@ -574,34 +705,34 @@ runTxBuild
Refl <- testEquality era nodeEra
& hoistMaybe (TxCmdTxNodeEraMismatchError $ NodeEraMismatchError era nodeEra)

TxCertificates _ certs _
<- hoistEither
. first TxCmdTxCertificatesValidationError
TxCertificates _ certs _
<- hoistEither
. first TxCmdTxCertificatesValidationError
$ validateTxCertificates era certsAndMaybeScriptWits

(txEraUtxo, pparams, eraHistory, systemStart, stakePools, stakeDelegDeposits, drepDelegDeposits) <-
lift (executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip $ queryStateForBalancedTx nodeEra allTxInputs certs)
& onLeft (left . TxCmdQueryConvenienceError . AcqFailure)
& onLeft (left . TxCmdQueryConvenienceError)

txBodyContent <- hoistEither $ constructTxBodyContent
sbe mScriptValidity
(Just $ unLedgerProtocolParameters pparams)
inputsAndMaybeScriptWits
readOnlyRefIns
txBodyContent <- hoistEither $ constructTxBodyContent
sbe mScriptValidity
(Just $ unLedgerProtocolParameters pparams)
inputsAndMaybeScriptWits
readOnlyRefIns
txinsc
mReturnCollateral
mTotCollateral
txouts
mLowerBound
mUpperBound
valuesWithScriptWits
certsAndMaybeScriptWits
withdrawals
reqSigners
mReturnCollateral
mTotCollateral
txouts
mLowerBound
mUpperBound
valuesWithScriptWits
certsAndMaybeScriptWits
withdrawals
reqSigners
Nothing
txAuxScripts
txMetadata
txAuxScripts
txMetadata
txUpdateProposal
votingProcedures proposals

Expand Down Expand Up @@ -666,7 +797,7 @@ validateTxInsCollateral _ [] = return TxInsCollateralNone
validateTxInsCollateral era txins = do
forShelleyBasedEraInEonMaybe era (\supported -> TxInsCollateral supported txins)
& maybe (txFeatureMismatchPure (toCardanoEra era) TxFeatureCollateral) Right


validateTxInsReference
:: ShelleyBasedEra era
Expand Down

0 comments on commit 282803a

Please sign in to comment.