diff --git a/cabal.project b/cabal.project index ba972eee30..594072e06b 100644 --- a/cabal.project +++ b/cabal.project @@ -14,7 +14,7 @@ repository cardano-haskell-packages -- you need to run if you change them index-state: , hackage.haskell.org 2024-08-08T19:27:29Z - , cardano-haskell-packages 2024-08-13T10:37:21Z + , cardano-haskell-packages 2024-09-05T16:30:09Z packages: cardano-cli diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 6c7835b9e5..d8719de1bf 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -213,7 +213,7 @@ library binary, bytestring, canonical-json, - cardano-api ^>=9.2, + cardano-api ^>=9.3, cardano-binary, cardano-crypto, cardano-crypto-class ^>=2.1.2, @@ -244,9 +244,9 @@ library network, optparse-applicative-fork, ouroboros-consensus ^>=0.20, - ouroboros-consensus-cardano ^>=0.18, + ouroboros-consensus-cardano ^>=0.19, ouroboros-consensus-protocol ^>=0.9.0.1, - ouroboros-network-api ^>=0.7.3, + ouroboros-network-api ^>=0.9, ouroboros-network-protocols, parsec, prettyprinter, diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index 93e1b5dcb3..a827040225 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs @@ -36,6 +36,7 @@ where import Cardano.Api import Cardano.Api.Byron hiding (SomeByronSigningKey (..)) +import Cardano.Api.Experimental import qualified Cardano.Api.Ledger as L import Cardano.Api.Shelley @@ -64,7 +65,6 @@ import Data.Bifunctor (Bifunctor (..)) import qualified Data.ByteString as Data.Bytestring import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS -import Data.Containers.ListUtils (nubOrd) import Data.Data ((:~:) (..)) import qualified Data.Foldable as Foldable import Data.Function ((&)) @@ -135,176 +135,184 @@ runTransactionBuildCmd , proposalFiles , treasuryDonation -- Maybe TxTreasuryDonation , buildOutputOptions - } = shelleyBasedEraConstraints eon $ do - let era = toCardanoEra eon - - -- The user can specify an era prior to the era that the node is currently in. - -- We cannot use the user specified era to construct a query against a node because it may differ - -- from the node's era and this will result in the 'QueryEraMismatch' failure. - - let localNodeConnInfo = - LocalNodeConnectInfo - { localConsensusModeParams = consensusModeParams - , localNodeNetworkId = networkId - , localNodeSocketPath = nodeSocketPath - } - - inputsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError $ readScriptWitnessFiles eon txins - certFilesAndMaybeScriptWits <- - firstExceptT TxCmdScriptWitnessError $ readScriptWitnessFiles eon certificates - - -- TODO: Conway Era - How can we make this more composable? - certsAndMaybeScriptWits <- - sequence - [ fmap - (,mSwit) - ( firstExceptT TxCmdReadTextViewFileError . newExceptT $ - readFileTextEnvelope AsCertificate (File certFile) - ) - | (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits - ] - 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 - - mProp <- case mUpdateProposalFile of - Just (Featured w (Just updateProposalFile)) -> - readTxUpdateProposal w updateProposalFile & firstExceptT TxCmdReadTextViewFileError - _ -> pure TxUpdateProposalNone - - requiredSigners <- - mapM (firstExceptT TxCmdRequiredSignerError . newExceptT . readRequiredSigner) reqSigners - mReturnCollateral <- forM mReturnColl $ toTxOutInShelleyBasedEra eon - - txOuts <- mapM (toTxOutInAnyEra eon) txouts - - -- Conway related - votingProceduresAndMaybeScriptWits <- - inEonForEra - (pure mempty) - (\w -> firstExceptT TxCmdVoteError $ ExceptT (readVotingProceduresFiles w voteFiles)) - era - - proposals <- - newExceptT $ - first TxCmdProposalError - <$> readTxGovernanceActions eon proposalFiles - - -- the same collateral input can be used for several plutus scripts - let filteredTxinsc = nubOrd txinsc - - let allReferenceInputs = - getAllReferenceInputs - inputsAndMaybeScriptWits - (snd valuesWithScriptWits) - certsAndMaybeScriptWits - withdrawalsAndMaybeScriptWits - votingProceduresAndMaybeScriptWits - proposals - readOnlyReferenceInputs - - let inputsThatRequireWitnessing = [input | (input, _) <- inputsAndMaybeScriptWits] - allTxInputs = inputsThatRequireWitnessing ++ allReferenceInputs ++ filteredTxinsc - - AnyCardanoEra nodeEra <- - lift (executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip queryCurrentEra) - & onLeft (left . TxCmdQueryConvenienceError . AcqFailure) - & onLeft (left . TxCmdQueryConvenienceError . QceUnsupportedNtcVersion) - - (txEraUtxo, _, eraHistory, systemStart, _, _, _, featuredCurrentTreasuryValueM) <- - lift - ( executeLocalStateQueryExpr - localNodeConnInfo - Consensus.VolatileTip - (queryStateForBalancedTx nodeEra allTxInputs []) - ) - & onLeft (left . TxCmdQueryConvenienceError . AcqFailure) - & onLeft (left . TxCmdQueryConvenienceError) - - let currentTreasuryValueAndDonation = - case (treasuryDonation, unFeatured <$> featuredCurrentTreasuryValueM) of - (Nothing, _) -> Nothing -- We shouldn't specify the treasury value when no donation is being done - (Just _td, Nothing) -> Nothing -- TODO: Current treasury value couldn't be obtained but is required: we should fail suggesting that the node's version is too old - (Just td, Just ctv) -> Just (ctv, td) - - -- We need to construct the txBodycontent outside of runTxBuild - BalancedTxBody txBodyContent balancedTxBody _ _ <- - runTxBuild - eon - nodeSocketPath - networkId - mScriptValidity - inputsAndMaybeScriptWits - readOnlyReferenceInputs - filteredTxinsc - mReturnCollateral - mTotalCollateral - txOuts - changeAddresses - valuesWithScriptWits - mValidityLowerBound - mValidityUpperBound - certsAndMaybeScriptWits - withdrawalsAndMaybeScriptWits - requiredSigners - txAuxScripts - txMetadata - mProp - mOverrideWitnesses - votingProceduresAndMaybeScriptWits - proposals - currentTreasuryValueAndDonation - - -- TODO: Calculating the script cost should live as a different command. - -- Why? Because then we can simply read a txbody and figure out - -- the script cost vs having to build the tx body each time - case buildOutputOptions of - OutputScriptCostOnly fp -> do - let BuildTxWith mTxProtocolParams = txProtocolParams txBodyContent - - pparams <- pure mTxProtocolParams & onNothing (left TxCmdProtocolParametersNotPresentInTxBody) - executionUnitPrices <- - pure (getExecutionUnitPrices era pparams) & onNothing (left TxCmdPParamExecutionUnitsNotAvailable) - - Refl <- - testEquality era nodeEra - & hoistMaybe (TxCmdTxNodeEraMismatchError $ NodeEraMismatchError era nodeEra) - - scriptExecUnitsMap <- - firstExceptT (TxCmdTxExecUnitsErr . AnyTxCmdTxExecUnitsErr) $ - hoistEither $ - evaluateTransactionExecutionUnits + } = + caseShelleyToBabbageOrConwayEraOnwards + (left . TxCmdDeprecatedEra) + ( \ConwayEraOnwardsConway -> + shelleyBasedEraConstraints eon $ do + let era = toCardanoEra eon + + -- The user can specify an era prior to the era that the node is currently in. + -- We cannot use the user specified era to construct a query against a node because it may differ + -- from the node's era and this will result in the 'QueryEraMismatch' failure. + + let localNodeConnInfo = + LocalNodeConnectInfo + { localConsensusModeParams = consensusModeParams + , localNodeNetworkId = networkId + , localNodeSocketPath = nodeSocketPath + } + + inputsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError $ readScriptWitnessFiles eon txins + certFilesAndMaybeScriptWits <- + firstExceptT TxCmdScriptWitnessError $ readScriptWitnessFiles eon certificates + + -- TODO: Conway Era - How can we make this more composable? + certsAndMaybeScriptWits <- + sequence + [ fmap + (,mSwit) + ( firstExceptT TxCmdReadTextViewFileError . newExceptT $ + readFileTextEnvelope AsCertificate (File certFile) + ) + | (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits + ] + 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 + + mProp <- case mUpdateProposalFile of + Just (Featured w (Just updateProposalFile)) -> + readTxUpdateProposal w updateProposalFile & firstExceptT TxCmdReadTextViewFileError + _ -> pure TxUpdateProposalNone + + requiredSigners <- + mapM (firstExceptT TxCmdRequiredSignerError . newExceptT . readRequiredSigner) reqSigners + mReturnCollateral <- forM mReturnColl $ toTxOutInShelleyBasedEra eon + + txOuts <- mapM (toTxOutInAnyEra eon) txouts + + -- Conway related + votingProceduresAndMaybeScriptWits <- + inEonForEra + (pure mempty) + (\w -> firstExceptT TxCmdVoteError $ ExceptT (readVotingProceduresFiles w voteFiles)) era - systemStart - (toLedgerEpochInfo eraHistory) - pparams - txEraUtxo - balancedTxBody - - let mScriptWits = forEraInEon era [] $ \sbe -> collectTxBodyScriptWitnesses sbe txBodyContent - - scriptCostOutput <- - firstExceptT TxCmdPlutusScriptCostErr $ - hoistEither $ - renderScriptCosts - txEraUtxo - executionUnitPrices - mScriptWits - scriptExecUnitsMap - liftIO $ LBS.writeFile (unFile fp) $ encodePretty scriptCostOutput - OutputTxBodyOnly fpath -> - let noWitTx = makeSignedTransaction [] balancedTxBody - in lift (cardanoEraConstraints era $ writeTxFileTextEnvelopeCddl eon fpath noWitTx) - & onLeft (left . TxCmdWriteFileError) + + proposals <- + newExceptT $ + first TxCmdProposalError + <$> readTxGovernanceActions eon proposalFiles + + -- the same collateral input can be used for several plutus scripts + let filteredTxinsc = toList $ Set.fromList txinsc + + let allReferenceInputs = + getAllReferenceInputs + inputsAndMaybeScriptWits + (snd valuesWithScriptWits) + certsAndMaybeScriptWits + withdrawalsAndMaybeScriptWits + votingProceduresAndMaybeScriptWits + proposals + readOnlyReferenceInputs + + let inputsThatRequireWitnessing = [input | (input, _) <- inputsAndMaybeScriptWits] + allTxInputs = inputsThatRequireWitnessing ++ allReferenceInputs ++ filteredTxinsc + + AnyCardanoEra nodeEra <- + lift (executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip queryCurrentEra) + & onLeft (left . TxCmdQueryConvenienceError . AcqFailure) + & onLeft (left . TxCmdQueryConvenienceError . QceUnsupportedNtcVersion) + + (txEraUtxo, _, eraHistory, systemStart, _, _, _, featuredCurrentTreasuryValueM) <- + lift + ( executeLocalStateQueryExpr + localNodeConnInfo + Consensus.VolatileTip + (queryStateForBalancedTx nodeEra allTxInputs []) + ) + & onLeft (left . TxCmdQueryConvenienceError . AcqFailure) + & onLeft (left . TxCmdQueryConvenienceError) + + let currentTreasuryValueAndDonation = + case (treasuryDonation, unFeatured <$> featuredCurrentTreasuryValueM) of + (Nothing, _) -> Nothing -- We shouldn't specify the treasury value when no donation is being done + (Just _td, Nothing) -> Nothing -- TODO: Current treasury value couldn't be obtained but is required: we should fail suggesting that the node's version is too old + (Just td, Just ctv) -> Just (ctv, td) + + -- We need to construct the txBodycontent outside of runTxBuild + BalancedTxBody txBodyContent unsignedTx@(UnsignedTx balancedTxBody) _ _ <- + runTxBuild + eon + nodeSocketPath + networkId + mScriptValidity + inputsAndMaybeScriptWits + readOnlyReferenceInputs + filteredTxinsc + mReturnCollateral + mTotalCollateral + txOuts + changeAddresses + valuesWithScriptWits + mValidityLowerBound + mValidityUpperBound + certsAndMaybeScriptWits + withdrawalsAndMaybeScriptWits + requiredSigners + txAuxScripts + txMetadata + mProp + mOverrideWitnesses + votingProceduresAndMaybeScriptWits + proposals + currentTreasuryValueAndDonation + + -- TODO: Calculating the script cost should live as a different command. + -- Why? Because then we can simply read a txbody and figure out + -- the script cost vs having to build the tx body each time + case buildOutputOptions of + OutputScriptCostOnly fp -> do + let BuildTxWith mTxProtocolParams = txProtocolParams txBodyContent + + pparams <- pure mTxProtocolParams & onNothing (left TxCmdProtocolParametersNotPresentInTxBody) + executionUnitPrices <- + pure (getExecutionUnitPrices era pparams) & onNothing (left TxCmdPParamExecutionUnitsNotAvailable) + + Refl <- + testEquality era nodeEra + & hoistMaybe (TxCmdTxNodeEraMismatchError $ NodeEraMismatchError era nodeEra) + + scriptExecUnitsMap <- + firstExceptT (TxCmdTxExecUnitsErr . AnyTxCmdTxExecUnitsErr) $ + hoistEither $ + evaluateTransactionExecutionUnitsShelley + eon + systemStart + (toLedgerEpochInfo eraHistory) + pparams + txEraUtxo + balancedTxBody + + let mScriptWits = forEraInEon era [] $ \sbe -> collectTxBodyScriptWitnesses sbe txBodyContent + + scriptCostOutput <- + firstExceptT TxCmdPlutusScriptCostErr $ + hoistEither $ + renderScriptCosts + txEraUtxo + executionUnitPrices + mScriptWits + scriptExecUnitsMap + liftIO $ LBS.writeFile (unFile fp) $ encodePretty scriptCostOutput + OutputTxBodyOnly fpath -> + let + noWitTx = ShelleyTx eon $ signTx useEra [] [] unsignedTx + in + lift (cardanoEraConstraints era $ writeTxFileTextEnvelopeCddl eon fpath noWitTx) + & onLeft (left . TxCmdWriteFileError) + ) + eon runTransactionBuildEstimateCmd :: () @@ -442,7 +450,7 @@ runTransactionBuildEstimateCmd -- TODO change type collectTxBodyScriptWitnesses sbe txBodyContent ] - BalancedTxBody _ balancedTxBody _ _ <- + BalancedTxBody _ unsignedTx _ _ <- hoistEither $ first TxCmdFeeEstimationError $ estimateBalancedTxBody @@ -460,9 +468,15 @@ runTransactionBuildEstimateCmd -- TODO change type (anyAddressInShelleyBasedEra sbe changeAddr) totalUTxOValue - let noWitTx = makeSignedTransaction [] balancedTxBody - lift (writeTxFileTextEnvelopeCddl sbe txBodyOutFile noWitTx) - & onLeft (left . TxCmdWriteFileError) + caseShelleyToBabbageOrConwayEraOnwards + (left . TxCmdDeprecatedEra) + ( \ConwayEraOnwardsConway -> + let e :: Era ConwayEra = useEra + noWitTx = ShelleyTx sbe $ signTx e [] [] unsignedTx + in lift (writeTxFileTextEnvelopeCddl sbe txBodyOutFile noWitTx) + & onLeft (left . TxCmdWriteFileError) + ) + sbe getPoolDeregistrationInfo :: Certificate era @@ -759,7 +773,7 @@ runTxBuildRaw proposals mCurrentTreasuryValueAndDonation - first TxCmdTxBodyError $ createAndValidateTransactionBody sbe txBodyContent + first TxCmdTxBodyError $ createTransactionBody sbe txBodyContent constructTxBodyContent :: forall era @@ -1330,7 +1344,7 @@ createTxMintValue -> (Value, [ScriptWitness WitCtxMint era]) -> Either TxCmdError (TxMintValue BuildTx era) createTxMintValue era (val, scriptWitnesses) = - if List.null (valueToList val) && List.null scriptWitnesses + if List.null (toList val) && List.null scriptWitnesses then return TxMintNone else do caseShelleyToAllegraOrMaryEraOnwards @@ -1339,7 +1353,7 @@ createTxMintValue era (val, scriptWitnesses) = -- The set of policy ids for which we need witnesses: let witnessesNeededSet :: Set PolicyId witnessesNeededSet = - fromList [pid | (AssetId pid _, _) <- valueToList val] + fromList [pid | (AssetId pid _, _) <- toList val] let witnessesProvidedMap :: Map PolicyId (ScriptWitness WitCtxMint era) witnessesProvidedMap = fromList $ gatherMintingWitnesses scriptWitnesses diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs index f0a1ec37e3..6e8baf1e2f 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs @@ -56,7 +56,6 @@ data TxCmdError | TxCmdTxSubmitErrorEraMismatch !EraMismatch | TxCmdTxFeatureMismatch !AnyCardanoEra !TxFeature | TxCmdTxBodyError !TxBodyError - | TxCmdNotImplemented !Text | TxCmdWitnessEraMismatch !AnyCardanoEra !AnyCardanoEra !WitnessFile | TxCmdPolicyIdsMissing ![PolicyId] ![PolicyId] | -- The first list is the missing policy Ids, the second list is the @@ -85,6 +84,7 @@ data TxCmdError | TxCmdProtocolParamsConverstionError ProtocolParametersConversionError | forall era. TxCmdTxGovDuplicateVotes (TxGovDuplicateVotes era) | forall era. TxCmdFeeEstimationError (TxFeeEstimationError era) + | forall era. TxCmdDeprecatedEra (ShelleyToBabbageEra era) renderTxCmdError :: TxCmdError -> Doc ann renderTxCmdError = \case @@ -94,6 +94,12 @@ renderTxCmdError = \case prettyError voteErr TxCmdConstitutionError constErr -> pshow constErr + TxCmdDeprecatedEra era -> + mconcat + [ "The era " + , pshow (toCardanoEra era) + , " is deprecated. Please use the Conway era." + ] TxCmdProposalError propErr -> pshow propErr TxCmdReadTextViewFileError fileErr -> @@ -130,8 +136,6 @@ renderTxCmdError = \case <> " era transactions." TxCmdTxBodyError err' -> "Transaction validaton error: " <> prettyError err' - TxCmdNotImplemented msg -> - "Feature not yet implemented: " <> pretty msg TxCmdWitnessEraMismatch era era' (WitnessFile file) -> "The era of a witness does not match the era of the transaction. " <> "The transaction is for the " diff --git a/flake.lock b/flake.lock index 5aa1384c1d..42d5ad8711 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1723546234, - "narHash": "sha256-XJBgWgieb7U0LoDaVR6sisd6LR9zyXW+AgbpmSGYaZE=", + "lastModified": 1725556271, + "narHash": "sha256-+cwhAlF4zGfWC3UTSppYOwZ8SRcAfWU3WweenyvYgLA=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "7542392846fc9f30ea4f78a2fa7ebf35e79e4eca", + "rev": "c9c0d9f9c76ea1e18d8fb8b744c52bfc39b058c8", "type": "github" }, "original": {