diff --git a/cabal.project b/cabal.project index 84f5dd16e1..92a9f4a5cf 100644 --- a/cabal.project +++ b/cabal.project @@ -20,6 +20,45 @@ active-repositories: , :rest , cardano-haskell-packages:override +-- BEGIN SRP STANZAS MANAGED BY STANZAMAN -- + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network.git + tag: 65da1ad619473f9467d3336a6d6e9a2a8714913d + subdir: cardano-diffusion + --sha256: 1r5y5px0kj4nhb65s9i7pr0sikxghfqwfkzmsgiql2maic4nglwi + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus.git + tag: bca18fd361d8342bdbfb8a08366e86479677ce30 + subdir: . + --sha256: 11znnl9zk59bxr6dn76zrni6i0q32bqnlxqf4wprvxikg4r666pa + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network.git + tag: 65da1ad619473f9467d3336a6d6e9a2a8714913d + subdir: network-mux + --sha256: 1r5y5px0kj4nhb65s9i7pr0sikxghfqwfkzmsgiql2maic4nglwi + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network.git + tag: 65da1ad619473f9467d3336a6d6e9a2a8714913d + subdir: ouroboros-network + --sha256: 1r5y5px0kj4nhb65s9i7pr0sikxghfqwfkzmsgiql2maic4nglwi + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-api.git + tag: 13b452f32cf053a803988f455551a697726c65cc + subdir: cardano-api + --sha256: 1fq901pjq1k3hiqygnmifw6w9pydqb4xr4i987n69r2jp1k3025m + +-- END SRP STANZAS MANAGED BY STANZAMAN -- + packages: cardano-cli diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 695fbae1cf..7294f2bf5e 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -135,6 +135,7 @@ library Cardano.CLI.EraBased.TextView.Option Cardano.CLI.EraBased.TextView.Run Cardano.CLI.EraBased.Transaction.Command + Cardano.CLI.EraBased.Transaction.Internal.ErrorRendering Cardano.CLI.EraBased.Transaction.Internal.HashCheck Cardano.CLI.EraBased.Transaction.Option Cardano.CLI.EraBased.Transaction.Run diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Script/Mint/Read.hs b/cardano-cli/src/Cardano/CLI/EraBased/Script/Mint/Read.hs index 3ba8ca9f97..5f77602996 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Script/Mint/Read.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Script/Mint/Read.hs @@ -20,7 +20,6 @@ import Cardano.CLI.EraBased.Script.Read.Common import Cardano.CLI.EraBased.Script.Type import Cardano.CLI.Read import Cardano.CLI.Type.Common (AnySLanguage (..)) -import Cardano.Ledger.Core qualified as L readMintScriptWitness :: forall era e diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Command.hs b/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Command.hs index a1eae0e200..0e67fdedab 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Command.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Command.hs @@ -21,6 +21,7 @@ module Cardano.CLI.EraBased.Transaction.Command , TransactionSignWitnessCmdArgs (..) , TransactionSubmitCmdArgs (..) , TransactionTxIdCmdArgs (..) + , TransactionValidateCmdArgs (..) , TransactionViewCmdArgs (..) , TransactionWitnessCmdArgs (..) , TxCborFormat (..) @@ -55,6 +56,7 @@ data TransactionCmds era | TransactionCalculatePlutusScriptCostCmd !(TransactionCalculatePlutusScriptCostCmdArgs era) | TransactionHashScriptDataCmd !TransactionHashScriptDataCmdArgs | TransactionTxIdCmd !TransactionTxIdCmdArgs + | TransactionValidateCmd !TransactionValidateCmdArgs data TransactionBuildRawCmdArgs era = TransactionBuildRawCmdArgs { eon :: !(Exp.Era era) @@ -253,6 +255,12 @@ data TransactionSubmitCmdArgs = TransactionSubmitCmdArgs } deriving Show +data TransactionValidateCmdArgs = TransactionValidateCmdArgs + { nodeConnInfo :: !LocalNodeConnectInfo + , txFile :: !FilePath + } + deriving Show + newtype TransactionPolicyIdCmdArgs = TransactionPolicyIdCmdArgs { scriptFile :: ScriptFile } @@ -349,3 +357,4 @@ renderTransactionCmds = \case TransactionCalculatePlutusScriptCostCmd{} -> "transaction calculate-plutus-script-cost" TransactionHashScriptDataCmd{} -> "transaction hash-script-data" TransactionTxIdCmd{} -> "transaction txid" + TransactionValidateCmd{} -> "transaction validate" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Internal/ErrorRendering.hs b/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Internal/ErrorRendering.hs new file mode 100644 index 0000000000..f2bd88dfd5 --- /dev/null +++ b/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Internal/ErrorRendering.hs @@ -0,0 +1,453 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.CLI.EraBased.Transaction.Internal.ErrorRendering + ( renderApplyTxErrors + , renderScriptWitnessIndexShort + , renderScriptExecutionError + ) +where + +import Cardano.Api +import Cardano.Api.Experimental qualified as Exp +import Cardano.Api.Ledger qualified as L + +import Data.Foldable qualified as Foldable +import Data.Map.NonEmpty qualified as NEMap +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Set.NonEmpty (NonEmptySet, toSet) +import Data.Text qualified as Text +import Lens.Micro ((^.)) + +showT :: Show a => a -> Text +showT = Text.pack . show + +showCoin :: L.Coin -> Text +showCoin (L.Coin n) = Text.pack (show n) + +showDeltaCoin :: L.DeltaCoin -> Text +showDeltaCoin (L.DeltaCoin n) = Text.pack (show n) + +renderLedgerTxIn :: L.TxIn -> Text +renderLedgerTxIn (L.TxIn (L.TxId h) ix) = + L.hashToTextAsHex (L.extractHash h) <> "#" <> Text.pack (show (fromEnum ix)) + +renderLedgerTxIns :: Set.Set L.TxIn -> Text +renderLedgerTxIns = Text.intercalate ", " . map renderLedgerTxIn . Set.toList + +renderScriptHash :: L.ScriptHash -> Text +renderScriptHash (L.ScriptHash h) = L.hashToTextAsHex h + +renderScriptHashes :: Set.Set L.ScriptHash -> Text +renderScriptHashes = Text.intercalate ", " . map renderScriptHash . Set.toList + +renderKeyHash :: L.KeyHash r -> Text +renderKeyHash = L.hashToTextAsHex . L.unKeyHash + +class RelationSymbol (r :: L.Relation) where + relationSymbol :: Text + +instance RelationSymbol L.RelEQ where relationSymbol = "=" +instance RelationSymbol L.RelLT where relationSymbol = "<" +instance RelationSymbol L.RelGT where relationSymbol = ">" +instance RelationSymbol L.RelLTEQ where relationSymbol = "≤" +instance RelationSymbol L.RelGTEQ where relationSymbol = "≥" +instance RelationSymbol L.RelSubset where relationSymbol = "⊆" + +renderMismatch :: forall r a. RelationSymbol r => Text -> (a -> Text) -> L.Mismatch r a -> [Text] +renderMismatch name renderVal L.Mismatch{L.mismatchSupplied, L.mismatchExpected} = + [ name + <> ": supplied " + <> renderVal mismatchSupplied + <> ", expected " + <> relationSymbol @r + <> " " + <> renderVal mismatchExpected + ] + +renderMismatchInline :: forall r a. RelationSymbol r => (a -> Text) -> L.Mismatch r a -> Text +renderMismatchInline renderVal L.Mismatch{L.mismatchSupplied, L.mismatchExpected} = + "supplied " + <> renderVal mismatchSupplied + <> ", expected " + <> relationSymbol @r + <> " " + <> renderVal mismatchExpected + +showEpochNo :: L.EpochNo -> Text +showEpochNo (L.EpochNo n) = Text.pack (show n) + +renderVKeyWitnesses :: NonEmptySet (L.KeyHash r) -> [Text] +renderVKeyWitnesses keyHashes = + let hashes = [renderKeyHash kh | kh <- Set.toList (toSet keyHashes)] + in ["MissingVKeyWitnessesUTXOW: " <> Text.intercalate ", " hashes] + +renderWithdrawals :: L.Withdrawals -> [Text] +renderWithdrawals (L.Withdrawals ws) = + [ " " <> showT addr <> ": " <> showCoin coin <> " lovelace" + | (addr, coin) <- Map.toList ws + ] + +renderTxOutCoins :: Foldable f => f (L.TxOut (ShelleyLedgerEra ConwayEra)) -> [Text] +renderTxOutCoins outs = + [ " output with " <> showCoin (out ^. L.coinTxOutL) <> " lovelace" + | out <- Foldable.toList outs + ] + +renderSafeHash :: L.SafeHash c -> Text +renderSafeHash = L.hashToTextAsHex . L.extractHash + +renderDataHashes :: Foldable f => f L.DataHash -> Text +renderDataHashes = Text.intercalate ", " . map renderSafeHash . Foldable.toList + +renderStrictMaybeHash :: L.StrictMaybe (L.SafeHash c) -> Text +renderStrictMaybeHash L.SNothing = "none" +renderStrictMaybeHash (L.SJust h) = renderSafeHash h + +renderPlutusPurposeAsItem :: L.ConwayPlutusPurpose L.AsItem (ShelleyLedgerEra ConwayEra) -> Text +renderPlutusPurposeAsItem = \case + L.ConwaySpending (L.AsItem txIn) -> "Spending " <> renderLedgerTxIn txIn + L.ConwayMinting (L.AsItem (L.PolicyID sh)) -> "Minting " <> renderScriptHash sh + L.ConwayCertifying (L.AsItem cert) -> "Certifying " <> showT cert + L.ConwayRewarding (L.AsItem addr) -> "Rewarding " <> showT addr + L.ConwayVoting (L.AsItem voter) -> "Voting " <> showT voter + L.ConwayProposing (L.AsItem prop) -> "Proposing " <> showT prop + +renderPlutusPurposeAsIx :: L.ConwayPlutusPurpose L.AsIx (ShelleyLedgerEra ConwayEra) -> Text +renderPlutusPurposeAsIx = \case + L.ConwaySpending (L.AsIx ix) -> "Spending:" <> showT ix + L.ConwayMinting (L.AsIx ix) -> "Minting:" <> showT ix + L.ConwayCertifying (L.AsIx ix) -> "Certifying:" <> showT ix + L.ConwayRewarding (L.AsIx ix) -> "Rewarding:" <> showT ix + L.ConwayVoting (L.AsIx ix) -> "Voting:" <> showT ix + L.ConwayProposing (L.AsIx ix) -> "Proposing:" <> showT ix + +renderApplyTxErrors :: Exp.Era era -> L.ApplyTxError (Exp.LedgerEra era) -> [Text] +renderApplyTxErrors = \case + Exp.ConwayEra -> renderConwayErrors + Exp.DijkstraEra -> error "TODO Dijkstra: renderApplyTxErrors" + +-- Conway top-level + +renderConwayErrors :: L.ApplyTxError (ShelleyLedgerEra ConwayEra) -> [Text] +renderConwayErrors (L.ConwayApplyTxError failures) = + concatMap conwayLedgerFailure failures + +conwayLedgerFailure :: L.ConwayLedgerPredFailure (ShelleyLedgerEra ConwayEra) -> [Text] +conwayLedgerFailure = \case + L.ConwayUtxowFailure f -> conwayUtxowFailure f + L.ConwayCertsFailure f -> conwayCertsFailure f + L.ConwayGovFailure f -> conwayGovFailure f + L.ConwayWdrlNotDelegatedToDRep keyHashes -> + [ "ConwayWdrlNotDelegatedToDRep: " + <> Text.intercalate ", " (map renderKeyHash (Foldable.toList keyHashes)) + ] + L.ConwayTreasuryValueMismatch m -> + renderMismatch "ConwayTreasuryValueMismatch" (\c -> showCoin c <> " lovelace") m + L.ConwayTxRefScriptsSizeTooBig m -> + renderMismatch "ConwayTxRefScriptsSizeTooBig" (\n -> showT n <> " bytes") m + L.ConwayMempoolFailure txt -> ["ConwayMempoolFailure: " <> txt] + L.ConwayWithdrawalsMissingAccounts ws -> + "ConwayWithdrawalsMissingAccounts:" : renderWithdrawals ws + L.ConwayIncompleteWithdrawals m -> + ["ConwayIncompleteWithdrawals:"] + <> [ " " + <> showT addr + <> ": " + <> renderMismatchInline (\c -> showCoin c <> " lovelace") mm + | (addr, mm) <- NEMap.toList m + ] + +-- Conway UTXOW + +conwayUtxowFailure :: L.ConwayUtxowPredFailure (ShelleyLedgerEra ConwayEra) -> [Text] +conwayUtxowFailure = \case + L.UtxoFailure f -> conwayUtxoFailure f + L.InvalidWitnessesUTXOW ws -> + ["InvalidWitnessesUTXOW:"] + <> [" " <> showT w | w <- Foldable.toList ws] + L.MissingVKeyWitnessesUTXOW keyHashes -> renderVKeyWitnesses keyHashes + L.MissingScriptWitnessesUTXOW hs -> + ["MissingScriptWitnessesUTXOW: " <> renderScriptHashes (toSet hs)] + L.ScriptWitnessNotValidatingUTXOW hs -> + ["ScriptWitnessNotValidatingUTXOW: " <> renderScriptHashes (toSet hs)] + L.MissingTxBodyMetadataHash (L.TxAuxDataHash h) -> ["MissingTxBodyMetadataHash: " <> renderSafeHash h] + L.MissingTxMetadata (L.TxAuxDataHash h) -> ["MissingTxMetadata: " <> renderSafeHash h] + L.ConflictingMetadataHash m -> + renderMismatch "ConflictingMetadataHash" (\(L.TxAuxDataHash h) -> renderSafeHash h) m + L.InvalidMetadata -> ["InvalidMetadata"] + L.ExtraneousScriptWitnessesUTXOW hs -> + ["ExtraneousScriptWitnessesUTXOW: " <> renderScriptHashes (toSet hs)] + L.MissingRedeemers rs -> + ["MissingRedeemers:"] + <> [ " " <> renderPlutusPurposeAsItem purpose <> " -> " <> renderScriptHash sh + | (purpose, sh) <- Foldable.toList rs + ] + L.MissingRequiredDatums missing received -> + [ "MissingRequiredDatums: missing " + <> renderDataHashes (toSet missing) + <> ", received " + <> renderDataHashes received + ] + L.NotAllowedSupplementalDatums unallowed acceptable -> + [ "NotAllowedSupplementalDatums: unallowed " + <> renderDataHashes (toSet unallowed) + <> ", acceptable " + <> renderDataHashes acceptable + ] + L.PPViewHashesDontMatch m -> renderMismatch "PPViewHashesDontMatch" renderStrictMaybeHash m + L.UnspendableUTxONoDatumHash txins -> + ["UnspendableUTxONoDatumHash: " <> renderLedgerTxIns (toSet txins)] + L.ExtraRedeemers rs -> + ["ExtraRedeemers:"] + <> [" " <> renderPlutusPurposeAsIx r | r <- Foldable.toList rs] + L.MalformedScriptWitnesses hs -> + ["MalformedScriptWitnesses: " <> renderScriptHashes (toSet hs)] + L.MalformedReferenceScripts hs -> + ["MalformedReferenceScripts: " <> renderScriptHashes (toSet hs)] + L.ScriptIntegrityHashMismatch m _bs -> renderMismatch "ScriptIntegrityHashMismatch" renderStrictMaybeHash m + +-- Conway UTxO + +conwayUtxoFailure :: L.ConwayUtxoPredFailure (ShelleyLedgerEra ConwayEra) -> [Text] +conwayUtxoFailure = \case + L.UtxosFailure f -> conwayUtxosFailure f + L.BadInputsUTxO ins -> ["BadInputsUTxO: " <> renderLedgerTxIns (toSet ins)] + L.OutsideValidityIntervalUTxO interval slot -> + ["OutsideValidityIntervalUTxO: validity interval " <> showT interval <> " at slot " <> showT slot] + L.MaxTxSizeUTxO m -> + renderMismatch "MaxTxSizeUTxO" (\n -> showT n <> " bytes") m + L.InputSetEmptyUTxO -> ["InputSetEmptyUTxO"] + L.FeeTooSmallUTxO L.Mismatch{L.mismatchSupplied, L.mismatchExpected} -> + [ "FeeTooSmallUTxO: minimum fee is " + <> showCoin mismatchExpected + <> " lovelace" + <> ", transaction specifies " + <> showCoin mismatchSupplied + <> " lovelace" + ] + L.ValueNotConservedUTxO m -> + renderMismatch "ValueNotConservedUTxO" (\v -> showCoin (L.coin v) <> " lovelace") m + L.WrongNetwork network addrs -> ["WrongNetwork: expected " <> showT network <> ", addresses " <> showT addrs] + L.WrongNetworkWithdrawal network addrs -> + ["WrongNetworkWithdrawal: expected " <> showT network <> ", addresses " <> showT addrs] + L.OutputTooSmallUTxO outs -> + "OutputTooSmallUTxO:" : renderTxOutCoins outs + L.OutputBootAddrAttrsTooBig outs -> + "OutputBootAddrAttrsTooBig:" : renderTxOutCoins outs + L.OutputTooBigUTxO outs -> + ["OutputTooBigUTxO:"] + <> [ " output: actual size " <> showT actual <> ", limit " <> showT limit + | (actual, limit, _) <- Foldable.toList outs + ] + L.InsufficientCollateral actualBal required -> + [ "InsufficientCollateral: actual collateral is " + <> showDeltaCoin actualBal + <> " lovelace" + <> ", required collateral is " + <> showCoin required + <> " lovelace" + ] + L.ScriptsNotPaidUTxO utxos -> + ["ScriptsNotPaidUTxO:"] + <> [ " " <> renderLedgerTxIn txIn <> ": " <> showCoin (out ^. L.coinTxOutL) <> " lovelace" + | (txIn, out) <- NEMap.toList utxos + ] + L.ExUnitsTooBigUTxO m -> + renderMismatch "ExUnitsTooBigUTxO" showT m + L.CollateralContainsNonADA val -> ["CollateralContainsNonADA: " <> showT val] + L.WrongNetworkInTxBody m -> renderMismatch "WrongNetworkInTxBody" showT m + L.OutsideForecast slot -> ["OutsideForecast: slot " <> showT slot] + L.TooManyCollateralInputs m -> + renderMismatch "TooManyCollateralInputs" showT m + L.NoCollateralInputs -> ["NoCollateralInputs"] + L.IncorrectTotalCollateralField actualBal declaredTotal -> + [ "IncorrectTotalCollateralField: declared total collateral is " + <> showCoin declaredTotal + <> " lovelace" + <> ", actual total collateral is " + <> showDeltaCoin actualBal + <> " lovelace" + ] + L.BabbageOutputTooSmallUTxO outs -> + ["BabbageOutputTooSmallUTxO:"] + <> [ " output has " + <> showCoin (out ^. L.coinTxOutL) + <> " lovelace, minimum is " + <> showCoin minCoin + <> " lovelace" + | (out, minCoin) <- Foldable.toList outs + ] + L.BabbageNonDisjointRefInputs ins -> + [ "BabbageNonDisjointRefInputs: " + <> Text.intercalate ", " (map renderLedgerTxIn (Foldable.toList ins)) + ] + +-- Conway UTxOS (phase-2 script validation errors) + +conwayUtxosFailure :: L.ConwayUtxosPredFailure (ShelleyLedgerEra ConwayEra) -> [Text] +conwayUtxosFailure = \case + L.ValidationTagMismatch (L.IsValid expected) desc -> + ["ValidationTagMismatch: isValid=" <> showT expected <> ", " <> renderTagMismatch desc] + L.CollectErrors errs -> + ["CollectErrors:"] <> concatMap (\e -> [" " <> renderCollectError e]) errs + +renderTagMismatch :: L.TagMismatchDescription -> Text +renderTagMismatch = \case + L.PassedUnexpectedly -> "script passed unexpectedly (expected failure)" + L.FailedUnexpectedly descs -> + "script failed unexpectedly: " + <> Text.intercalate "; " (map renderFailureDescription (Foldable.toList descs)) + +renderFailureDescription :: L.FailureDescription -> Text +renderFailureDescription = \case + L.PlutusFailure msg _bs -> msg + +renderCollectError :: L.CollectError (ShelleyLedgerEra ConwayEra) -> Text +renderCollectError = \case + L.NoRedeemer purpose -> "NoRedeemer: " <> renderPlutusPurposeAsItem purpose + L.NoWitness scriptHash -> "NoWitness: " <> renderScriptHash scriptHash + L.NoCostModel lang -> "NoCostModel: " <> showT lang + L.BadTranslation err -> "BadTranslation: " <> showT err + +-- Conway CERTS (certificate validation) + +conwayCertsFailure :: L.ConwayCertsPredFailure (ShelleyLedgerEra ConwayEra) -> [Text] +conwayCertsFailure = \case + L.WithdrawalsNotInRewardsCERTS ws -> + "WithdrawalsNotInRewardsCERTS:" : renderWithdrawals ws + L.CertFailure f -> conwayCertFailure f + +conwayCertFailure :: L.ConwayCertPredFailure (ShelleyLedgerEra ConwayEra) -> [Text] +conwayCertFailure = \case + L.DelegFailure f -> conwayDelegFailure f + L.PoolFailure f -> shelleyPoolFailure f + L.GovCertFailure f -> conwayGovCertFailure f + +conwayDelegFailure :: L.ConwayDelegPredFailure (ShelleyLedgerEra ConwayEra) -> [Text] +conwayDelegFailure = \case + L.IncorrectDepositDELEG coin -> ["IncorrectDepositDELEG: " <> showCoin coin <> " lovelace"] + L.StakeKeyRegisteredDELEG cred -> ["StakeKeyRegisteredDELEG: " <> showT cred] + L.StakeKeyNotRegisteredDELEG cred -> ["StakeKeyNotRegisteredDELEG: " <> showT cred] + L.StakeKeyHasNonZeroAccountBalanceDELEG coin -> + ["StakeKeyHasNonZeroAccountBalanceDELEG: " <> showCoin coin <> " lovelace"] + L.DelegateeDRepNotRegisteredDELEG cred -> ["DelegateeDRepNotRegisteredDELEG: " <> showT cred] + L.DelegateeStakePoolNotRegisteredDELEG kh -> ["DelegateeStakePoolNotRegisteredDELEG: " <> renderKeyHash kh] + L.DepositIncorrectDELEG m -> + renderMismatch "DepositIncorrectDELEG" (\c -> showCoin c <> " lovelace") m + L.RefundIncorrectDELEG m -> + renderMismatch "RefundIncorrectDELEG" (\c -> showCoin c <> " lovelace") m + +shelleyPoolFailure :: L.ShelleyPoolPredFailure (ShelleyLedgerEra ConwayEra) -> [Text] +shelleyPoolFailure = \case + L.StakePoolNotRegisteredOnKeyPOOL kh -> ["StakePoolNotRegisteredOnKeyPOOL: " <> renderKeyHash kh] + L.StakePoolRetirementWrongEpochPOOL + (tooEarly :: L.Mismatch L.RelGT L.EpochNo) + (tooLate :: L.Mismatch L.RelLTEQ L.EpochNo) -> + [ "StakePoolRetirementWrongEpochPOOL: requested epoch " + <> showEpochNo (L.mismatchSupplied tooEarly) + <> ", must be " <> relationSymbol @L.RelGT <> " " + <> showEpochNo (L.mismatchExpected tooEarly) + <> " and " <> relationSymbol @L.RelLTEQ <> " " + <> showEpochNo (L.mismatchExpected tooLate) + ] + L.StakePoolCostTooLowPOOL m -> + renderMismatch "StakePoolCostTooLowPOOL" (\c -> showCoin c <> " lovelace") m + L.WrongNetworkPOOL m kh -> + [ "WrongNetworkPOOL: pool " + <> renderKeyHash kh + <> ", " + <> renderMismatchInline showT m + ] + L.PoolMedataHashTooBig kh sz -> + ["PoolMedataHashTooBig: pool " <> renderKeyHash kh <> ", size " <> showT sz] + L.VRFKeyHashAlreadyRegistered kh vrfHash -> + ["VRFKeyHashAlreadyRegistered: pool " <> renderKeyHash kh <> ", VRF " <> showT vrfHash] + +conwayGovCertFailure :: L.ConwayGovCertPredFailure (ShelleyLedgerEra ConwayEra) -> [Text] +conwayGovCertFailure = \case + L.ConwayDRepAlreadyRegistered cred -> ["ConwayDRepAlreadyRegistered: " <> showT cred] + L.ConwayDRepNotRegistered cred -> ["ConwayDRepNotRegistered: " <> showT cred] + L.ConwayDRepIncorrectDeposit m -> + renderMismatch "ConwayDRepIncorrectDeposit" (\c -> showCoin c <> " lovelace") m + L.ConwayCommitteeHasPreviouslyResigned cred -> + ["ConwayCommitteeHasPreviouslyResigned: " <> showT cred] + L.ConwayDRepIncorrectRefund m -> + renderMismatch "ConwayDRepIncorrectRefund" (\c -> showCoin c <> " lovelace") m + L.ConwayCommitteeIsUnknown cred -> ["ConwayCommitteeIsUnknown: " <> showT cred] + +-- Conway GOV (governance action validation) + +conwayGovFailure :: L.ConwayGovPredFailure (ShelleyLedgerEra ConwayEra) -> [Text] +conwayGovFailure = \case + L.GovActionsDoNotExist ids -> ["GovActionsDoNotExist: " <> showT (Foldable.toList ids)] + L.MalformedProposal act -> ["MalformedProposal: " <> showT act] + L.ProposalProcedureNetworkIdMismatch addr network -> + [ "ProposalProcedureNetworkIdMismatch: address " + <> showT addr + <> ", expected network " + <> showT network + ] + L.TreasuryWithdrawalsNetworkIdMismatch addrs network -> + [ "TreasuryWithdrawalsNetworkIdMismatch: expected network " + <> showT network + <> ", addresses " + <> showT addrs + ] + L.ProposalDepositIncorrect m -> + renderMismatch "ProposalDepositIncorrect" (\c -> showCoin c <> " lovelace") m + L.DisallowedVoters voters -> + ["DisallowedVoters: " <> showT (Foldable.toList voters)] + L.ConflictingCommitteeUpdate creds -> + ["ConflictingCommitteeUpdate: " <> showT creds] + L.ExpirationEpochTooSmall m -> + ["ExpirationEpochTooSmall:"] + <> [" " <> showT cred <> ": epoch " <> showT epoch | (cred, epoch) <- NEMap.toList m] + L.InvalidPrevGovActionId prop -> ["InvalidPrevGovActionId: " <> showT prop] + L.VotingOnExpiredGovAction voters -> + ["VotingOnExpiredGovAction: " <> showT (Foldable.toList voters)] + L.ProposalCantFollow prevId m -> + renderMismatch "ProposalCantFollow" showT m + <> [" previous gov action id: " <> showT prevId] + L.InvalidGuardrailsScriptHash got expected -> + ["InvalidGuardrailsScriptHash: expected " <> showT expected <> ", got " <> showT got] + L.DisallowedProposalDuringBootstrap prop -> ["DisallowedProposalDuringBootstrap: " <> showT prop] + L.DisallowedVotesDuringBootstrap voters -> + ["DisallowedVotesDuringBootstrap: " <> showT (Foldable.toList voters)] + L.VotersDoNotExist voters -> + ["VotersDoNotExist: " <> showT (Foldable.toList voters)] + L.ZeroTreasuryWithdrawals act -> ["ZeroTreasuryWithdrawals: " <> showT act] + L.ProposalReturnAccountDoesNotExist addr -> + ["ProposalReturnAccountDoesNotExist: " <> showT addr] + L.TreasuryWithdrawalReturnAccountsDoNotExist addrs -> + ["TreasuryWithdrawalReturnAccountsDoNotExist: " <> showT (Foldable.toList addrs)] + L.UnelectedCommitteeVoters voters -> + ["UnelectedCommitteeVoters: " <> showT (Foldable.toList voters)] + +-- Script witness rendering (used by phase-2 output) + +renderScriptWitnessIndexShort :: ScriptWitnessIndex -> Text +renderScriptWitnessIndexShort = \case + ScriptWitnessIndexTxIn n -> "Spend:" <> Text.pack (show n) + ScriptWitnessIndexMint n -> "Mint:" <> Text.pack (show n) + ScriptWitnessIndexCertificate n -> "Cert:" <> Text.pack (show n) + ScriptWitnessIndexWithdrawal n -> "Reward:" <> Text.pack (show n) + ScriptWitnessIndexVoting n -> "Vote:" <> Text.pack (show n) + ScriptWitnessIndexProposing n -> "Propose:" <> Text.pack (show n) + +renderScriptExecutionError :: ScriptExecutionError -> Text +renderScriptExecutionError = \case + ScriptErrorEvaluationFailed dpf -> + let evalErr = dpfEvaluationError dpf + logs = dpfExecutionLogs dpf + in Text.intercalate "\n" $ + [Text.pack (show evalErr)] + <> ["Logs: " <> Text.intercalate ", " logs | not (null logs)] + err -> Text.pack (docToString (prettyError err)) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Option.hs b/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Option.hs index 7da616655e..4d957d952d 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Option.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Option.hs @@ -90,6 +90,16 @@ pTransactionCmds envCli = [ "Submit a transaction to the local node whose Unix domain socket " , "is obtained from the CARDANO_NODE_SOCKET_PATH environment variable." ] + , Just $ + Opt.hsubparser $ + commandWithMetavar "validate" $ + Opt.info (pTransactionValidate envCli) $ + Opt.progDesc $ + mconcat + [ "Validate a transaction against the current ledger state " + , "without submitting it. Runs phase 1 (ledger rules) and " + , "phase 2 (Plutus script evaluation) independently." + ] , Just $ Opt.hsubparser $ commandWithMetavar "policyid" $ @@ -370,6 +380,17 @@ pTransactionSubmit envCli = ) <*> pTxSubmitFile +pTransactionValidate :: EnvCli -> Parser (TransactionCmds era) +pTransactionValidate envCli = + fmap TransactionValidateCmd $ + TransactionValidateCmdArgs + <$> ( LocalNodeConnectInfo + <$> pConsensusModeParams + <*> pNetworkId envCli + <*> pSocketPath envCli + ) + <*> pTxSubmitFile + pTransactionPolicyId :: Parser (TransactionCmds era) pTransactionPolicyId = fmap TransactionPolicyIdCmd $ diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Run.hs b/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Run.hs index 6ec542edd2..931a116ee5 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Run.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Run.hs @@ -25,6 +25,7 @@ module Cardano.CLI.EraBased.Transaction.Run , runTransactionTxIdCmd , runTransactionWitnessCmd , runTransactionSignWitnessCmd + , runTransactionValidateCmd ) where @@ -57,6 +58,11 @@ import Cardano.CLI.EraBased.Script.Vote.Read import Cardano.CLI.EraBased.Script.Withdrawal.Read import Cardano.CLI.EraBased.Transaction.Command import Cardano.CLI.EraBased.Transaction.Command qualified as Cmd +import Cardano.CLI.EraBased.Transaction.Internal.ErrorRendering + ( renderApplyTxErrors + , renderScriptExecutionError + , renderScriptWitnessIndexShort + ) import Cardano.CLI.EraBased.Transaction.Internal.HashCheck ( checkCertificateHashes , checkProposalHashes @@ -116,6 +122,7 @@ runTransactionCmds = \case runTransactionPolicyIdCmd args Cmd.TransactionWitnessCmd args -> fromExceptTCli $ runTransactionWitnessCmd args Cmd.TransactionSignWitnessCmd args -> fromExceptTCli $ runTransactionSignWitnessCmd args + Cmd.TransactionValidateCmd args -> fromExceptTCli $ runTransactionValidateCmd args -- ---------------------------------------------------------------------------- -- Building transactions @@ -1345,6 +1352,82 @@ runTransactionSubmitCmd TxValidationEraMismatch mismatchErr -> left $ TxCmdTxSubmitErrorEraMismatch mismatchErr TxSubmitError err -> left . TxCmdTxSubmitError . Text.pack $ show err +-- ---------------------------------------------------------------------------- +-- Transaction validation +-- + +runTransactionValidateCmd + :: () + => Cmd.TransactionValidateCmdArgs + -> ExceptT TxCmdError IO () +runTransactionValidateCmd + Cmd.TransactionValidateCmdArgs + { nodeConnInfo + , txFile + } = do + txFileOrPipe <- liftIO $ fileOrPipe txFile + Exp.InAnyEra era signedTx <- + lift (readFileSignedTx txFileOrPipe) & onLeft (left . TxCmdReadSignedTxError) + + Exp.obtainCommonConstraints era $ do + result <- + liftIO $ + executeLocalStateQueryExpr nodeConnInfo Consensus.VolatileTip $ + Exp.validateTx signedTx + + case result of + Left acquireFailure -> + left $ TxCmdTxValidateAcquireFailure acquireFailure + Right (Left queryError) -> + left $ TxCmdTxValidateQueryError queryError + Right (Right (Exp.TxValidationResult{Exp.phase1Result, Exp.phase2Result})) -> do + let phase1Passed = isRight phase1Result + phase2Entries = Map.toAscList phase2Result + phase2Passed = all (isRight . snd) phase2Entries + allPassed = phase1Passed && phase2Passed + + liftIO $ do + if allPassed + then Text.hPutStrLn IO.stdout "Transaction is valid." + else Text.hPutStrLn IO.stdout "Transaction validation failed." + + case phase1Result of + Right () -> + Text.hPutStrLn IO.stdout "Phase 1: passed" + Left err -> do + Text.hPutStrLn IO.stdout "Phase 1: FAILED" + forM_ (renderApplyTxErrors era err) $ \errLine -> + Text.hPutStrLn IO.stdout $ " " <> errLine + + let nScripts = length phase2Entries + scriptWord = if nScripts == 1 then "script" else "scripts" + if phase2Passed + then + Text.hPutStrLn IO.stdout $ + "Phase 2: passed (" <> Text.pack (show nScripts) <> " " <> scriptWord <> " evaluated)" + else + Text.hPutStrLn IO.stdout "Phase 2: FAILED" + + forM_ phase2Entries $ \(scriptIx, scriptResult) -> + case scriptResult of + Right (_logs, execUnits) -> + Text.hPutStrLn IO.stdout $ + " " + <> renderScriptWitnessIndexShort scriptIx + <> " passed (mem: " + <> Text.pack (show (executionMemory execUnits)) + <> ", steps: " + <> Text.pack (show (executionSteps execUnits)) + <> ")" + Left scriptErr -> do + Text.hPutStrLn IO.stdout $ + " " <> renderScriptWitnessIndexShort scriptIx <> " FAILED" + forM_ (Text.lines (renderScriptExecutionError scriptErr)) $ \errLine -> + Text.hPutStrLn IO.stdout $ " " <> errLine + + unless allPassed $ + liftIO exitFailure + -- ---------------------------------------------------------------------------- -- Transaction fee calculation -- diff --git a/cardano-cli/src/Cardano/CLI/Read.hs b/cardano-cli/src/Cardano/CLI/Read.hs index ac00562387..bd650a4363 100644 --- a/cardano-cli/src/Cardano/CLI/Read.hs +++ b/cardano-cli/src/Cardano/CLI/Read.hs @@ -26,7 +26,9 @@ module Cardano.CLI.Read -- * Tx , IncompleteTxBody (..) + , ReadSignedTxError (..) , readFileTx + , readFileSignedTx , readFileTxBody , readTx -- For testing purposes @@ -303,6 +305,21 @@ readFileTx file = do InAnyShelleyBasedEra sbe tx <- pure cddlTx return $ Right $ inAnyShelleyBasedEra sbe tx +data ReadSignedTxError + = ReadSignedTxFileError (FileError TextEnvelopeError) + | ReadSignedTxDeprecatedEra AnyCardanoEra + deriving Show + +readFileSignedTx :: FileOrPipe -> IO (Either ReadSignedTxError (Exp.InAnyEra Exp.SignedTx)) +readFileSignedTx file = do + result <- readFileTx file + case result of + Left e -> return $ Left $ ReadSignedTxFileError e + Right (InAnyShelleyBasedEra sbe (ShelleyTx _ ledgerTx)) -> + case Exp.sbeToEra sbe of + Left _ -> return $ Left $ ReadSignedTxDeprecatedEra (anyCardanoEra (toCardanoEra sbe)) + Right era -> return $ Right $ Exp.obtainCommonConstraints era $ Exp.InAnyEra era (Exp.SignedTx ledgerTx) + newtype IncompleteTxBody = IncompleteTxBody {unIncompleteTxBody :: InAnyShelleyBasedEra TxBody} diff --git a/cardano-cli/src/Cardano/CLI/Type/Error/TxCmdError.hs b/cardano-cli/src/Cardano/CLI/Type/Error/TxCmdError.hs index f73c1e76f8..43e64132cf 100644 --- a/cardano-cli/src/Cardano/CLI/Type/Error/TxCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Type/Error/TxCmdError.hs @@ -80,6 +80,9 @@ data TxCmdError | TxCmdUtxoJsonError String | forall era. TxCmdDeprecatedEra (Exp.DeprecatedEra era) | TxCmdGenesisDataError GenesisDataError + | TxCmdTxValidateQueryError Exp.QueryValidateTxError + | TxCmdTxValidateAcquireFailure AcquiringFailure + | TxCmdReadSignedTxError ReadSignedTxError instance Show TxCmdError where show = show . renderTxCmdError @@ -201,6 +204,16 @@ renderTxCmdError = \case ] TxCmdDatumDecodingError err -> "Error decoding datum: " <> pshow err + TxCmdTxValidateQueryError err -> + "Transaction validation query error: " <> pshow err + TxCmdTxValidateAcquireFailure err -> + "Failed to acquire local node state for transaction validation: " <> pshow err + TxCmdReadSignedTxError (ReadSignedTxFileError err) -> + prettyError err + TxCmdReadSignedTxError (ReadSignedTxDeprecatedEra era) -> + "Transaction validation is not supported for " + <> pshow era + <> " transactions. Only Conway and later eras are supported." prettyPolicyIdList :: [PolicyId] -> Doc ann prettyPolicyIdList = diff --git a/cardano-cli/test/cardano-cli-golden/files/golden/help.cli b/cardano-cli/test/cardano-cli-golden/files/golden/help.cli index 8a582f05b0..ee16b4563c 100644 --- a/cardano-cli/test/cardano-cli-golden/files/golden/help.cli +++ b/cardano-cli/test/cardano-cli-golden/files/golden/help.cli @@ -2590,6 +2590,7 @@ Usage: cardano-cli conway transaction | witness | assemble | submit + | validate | policyid | calculate-min-fee | calculate-min-required-utxo @@ -3132,6 +3133,19 @@ Usage: cardano-cli conway transaction submit Submit a transaction to the local node whose Unix domain socket is obtained from the CARDANO_NODE_SOCKET_PATH environment variable. +Usage: cardano-cli conway transaction validate + [--cardano-mode + [--epoch-slots SLOTS]] + ( --mainnet + | --testnet-magic NATURAL + ) + --socket-path SOCKET_PATH + --tx-file FILEPATH + + Validate a transaction against the current ledger state without submitting it. + Runs phase 1 (ledger rules) and phase 2 (Plutus script evaluation) + independently. + Usage: cardano-cli conway transaction policyid --script-file FILEPATH Calculate the PolicyId from the monetary policy script. @@ -4994,6 +5008,7 @@ Usage: cardano-cli latest transaction | witness | assemble | submit + | validate | policyid | calculate-min-fee | calculate-min-required-utxo @@ -5536,6 +5551,19 @@ Usage: cardano-cli latest transaction submit Submit a transaction to the local node whose Unix domain socket is obtained from the CARDANO_NODE_SOCKET_PATH environment variable. +Usage: cardano-cli latest transaction validate + [--cardano-mode + [--epoch-slots SLOTS]] + ( --mainnet + | --testnet-magic NATURAL + ) + --socket-path SOCKET_PATH + --tx-file FILEPATH + + Validate a transaction against the current ledger state without submitting it. + Runs phase 1 (ledger rules) and phase 2 (Plutus script evaluation) + independently. + Usage: cardano-cli latest transaction policyid --script-file FILEPATH Calculate the PolicyId from the monetary policy script. diff --git a/cardano-cli/test/cardano-cli-golden/files/golden/help/conway_transaction.cli b/cardano-cli/test/cardano-cli-golden/files/golden/help/conway_transaction.cli index 4208cc9d4f..f78661b934 100644 --- a/cardano-cli/test/cardano-cli-golden/files/golden/help/conway_transaction.cli +++ b/cardano-cli/test/cardano-cli-golden/files/golden/help/conway_transaction.cli @@ -6,6 +6,7 @@ Usage: cardano-cli conway transaction | witness | assemble | submit + | validate | policyid | calculate-min-fee | calculate-min-required-utxo @@ -36,6 +37,10 @@ Available commands: submit Submit a transaction to the local node whose Unix domain socket is obtained from the CARDANO_NODE_SOCKET_PATH environment variable. + validate Validate a transaction against the current ledger + state without submitting it. Runs phase 1 (ledger + rules) and phase 2 (Plutus script evaluation) + independently. policyid Calculate the PolicyId from the monetary policy script. calculate-min-fee Calculate the minimum fee for a transaction. diff --git a/cardano-cli/test/cardano-cli-golden/files/golden/help/conway_transaction_validate.cli b/cardano-cli/test/cardano-cli-golden/files/golden/help/conway_transaction_validate.cli new file mode 100644 index 0000000000..25dbf92e0b --- /dev/null +++ b/cardano-cli/test/cardano-cli-golden/files/golden/help/conway_transaction_validate.cli @@ -0,0 +1,29 @@ +Usage: cardano-cli conway transaction validate + [--cardano-mode + [--epoch-slots SLOTS]] + ( --mainnet + | --testnet-magic NATURAL + ) + --socket-path SOCKET_PATH + --tx-file FILEPATH + + Validate a transaction against the current ledger state without submitting it. + Runs phase 1 (ledger rules) and phase 2 (Plutus script evaluation) + independently. + +Available options: + --cardano-mode For talking to a node running in full Cardano mode + (default). + --epoch-slots SLOTS The number of slots per epoch for the Byron era. + (default: 21600) + --mainnet Use the mainnet magic id. This overrides the + CARDANO_NODE_NETWORK_ID environment variable + --testnet-magic NATURAL Specify a testnet magic id. This overrides the + CARDANO_NODE_NETWORK_ID environment variable + --socket-path SOCKET_PATH + Path to the node socket. This overrides the + CARDANO_NODE_SOCKET_PATH environment variable. The + argument is optional if CARDANO_NODE_SOCKET_PATH is + defined and mandatory otherwise. + --tx-file FILEPATH Filepath of the transaction you intend to submit. + -h,--help Show this help text diff --git a/cardano-cli/test/cardano-cli-golden/files/golden/help/latest_transaction.cli b/cardano-cli/test/cardano-cli-golden/files/golden/help/latest_transaction.cli index 5c3177e239..c1fcad2ef9 100644 --- a/cardano-cli/test/cardano-cli-golden/files/golden/help/latest_transaction.cli +++ b/cardano-cli/test/cardano-cli-golden/files/golden/help/latest_transaction.cli @@ -6,6 +6,7 @@ Usage: cardano-cli latest transaction | witness | assemble | submit + | validate | policyid | calculate-min-fee | calculate-min-required-utxo @@ -36,6 +37,10 @@ Available commands: submit Submit a transaction to the local node whose Unix domain socket is obtained from the CARDANO_NODE_SOCKET_PATH environment variable. + validate Validate a transaction against the current ledger + state without submitting it. Runs phase 1 (ledger + rules) and phase 2 (Plutus script evaluation) + independently. policyid Calculate the PolicyId from the monetary policy script. calculate-min-fee Calculate the minimum fee for a transaction. diff --git a/cardano-cli/test/cardano-cli-golden/files/golden/help/latest_transaction_validate.cli b/cardano-cli/test/cardano-cli-golden/files/golden/help/latest_transaction_validate.cli new file mode 100644 index 0000000000..cc7abe63fd --- /dev/null +++ b/cardano-cli/test/cardano-cli-golden/files/golden/help/latest_transaction_validate.cli @@ -0,0 +1,29 @@ +Usage: cardano-cli latest transaction validate + [--cardano-mode + [--epoch-slots SLOTS]] + ( --mainnet + | --testnet-magic NATURAL + ) + --socket-path SOCKET_PATH + --tx-file FILEPATH + + Validate a transaction against the current ledger state without submitting it. + Runs phase 1 (ledger rules) and phase 2 (Plutus script evaluation) + independently. + +Available options: + --cardano-mode For talking to a node running in full Cardano mode + (default). + --epoch-slots SLOTS The number of slots per epoch for the Byron era. + (default: 21600) + --mainnet Use the mainnet magic id. This overrides the + CARDANO_NODE_NETWORK_ID environment variable + --testnet-magic NATURAL Specify a testnet magic id. This overrides the + CARDANO_NODE_NETWORK_ID environment variable + --socket-path SOCKET_PATH + Path to the node socket. This overrides the + CARDANO_NODE_SOCKET_PATH environment variable. The + argument is optional if CARDANO_NODE_SOCKET_PATH is + defined and mandatory otherwise. + --tx-file FILEPATH Filepath of the transaction you intend to submit. + -h,--help Show this help text