From a5161d8f4a1678d9ae1a6b543f7026c5e1437d00 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Thu, 21 May 2026 05:35:14 +0200 Subject: [PATCH 1/6] Add queryValidateTx: provisional applyTx query for transaction validation Adds a new local state query that runs applyTx against the current ledger state and returns the raw result. The provisional implementation queries the full EpochState and runs applyTx client-side; this will be replaced by a dedicated node-side consensus query. Exposed from Cardano.Api.Query alongside other queries. --- cardano-api/cardano-api.cabal | 1 + .../Api/Experimental/Tx/Internal/Validate.hs | 131 ++++++++++++++++++ cardano-api/src/Cardano/Api/Query.hs | 3 + 3 files changed, 135 insertions(+) create mode 100644 cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Validate.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index a2357b7cf5..99f6d2b80b 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -243,6 +243,7 @@ library Cardano.Api.Experimental.Tx.Internal.Fee Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements Cardano.Api.Experimental.Tx.Internal.Type + Cardano.Api.Experimental.Tx.Internal.Validate Cardano.Api.Genesis.Internal Cardano.Api.Genesis.Internal.Parameters Cardano.Api.Governance.Internal.Action.ProposalProcedure diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Validate.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Validate.hs new file mode 100644 index 0000000000..1c805a782e --- /dev/null +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Validate.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Api.Experimental.Tx.Internal.Validate + ( queryValidateTx + , QueryValidateTxError (..) + ) +where + +import Cardano.Api.Block (ChainPoint (..)) +import Cardano.Api.Era +import Cardano.Api.Genesis.Internal (shelleyGenesisDefaults) +import Cardano.Api.Genesis.Internal.Parameters +import Cardano.Api.Network.IPC (LocalStateQueryExpr) +import Cardano.Api.Network.IPC.Internal.Version (UnsupportedNtcVersionError) +import Cardano.Api.Network.Internal.NetworkId (NetworkMagic (..), toNetworkMagic, toShelleyNetwork) +import Cardano.Api.Query.Internal.Expr +import Cardano.Api.Query.Internal.Type.QueryInMode +import Cardano.Api.Tx.Internal.Sign (Tx (..)) +import Cardano.Api.Tx.Internal.TxIn (fromShelleyTxIn) + +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch) + +import Cardano.Binary qualified as CBOR +import Cardano.Ledger.BaseTypes (boundRational) +import Cardano.Ledger.Coin (unCoin) +import Cardano.Ledger.Core (allInputsTxBodyF, bodyTxL) +import Cardano.Ledger.Shelley.API (ApplyTxError, EpochState (..), LedgerEnv (..), applyTx) +import Cardano.Ledger.Shelley.Genesis (ShelleyGenesis (..), mkShelleyGlobals) +import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL) +import Cardano.Ledger.State (utxoL) +import Cardano.Slotting.Slot (SlotNo (..)) + +import Control.Monad (void) +import Data.Bifunctor (first) +import Data.Set qualified as Set +import Lens.Micro (set, (^.)) + +data QueryValidateTxError + = QueryValidateTxUnsupportedNtcVersion UnsupportedNtcVersionError + | QueryValidateTxEraMismatch EraMismatch + | QueryValidateTxEpochStateDecodeError CBOR.DecoderError + deriving Show + +-- | Run applyTx against the node's current ledger state and return the raw result. +-- +-- TODO: Replace this provisional implementation (which queries the full +-- EpochState from the node and runs applyTx client-side) with a dedicated +-- node-side consensus query that runs applyTx server-side without +-- transferring the ledger state. The replacement should have the same type +-- signature as a normal local state query. +queryValidateTx + :: forall era block point r + . ShelleyBasedEra era + -> Tx era + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either QueryValidateTxError (Either (ApplyTxError (ShelleyLedgerEra era)) ())) +queryValidateTx sbe (ShelleyTx _sbe ledgerTx) = do + eGenParams <- queryGenesisParameters sbe + eSerEpochState <- queryCurrentEpochState sbe + eEraHistory <- queryEraHistory + eChainPoint <- queryChainPoint + -- QueryCurrentEpochState uses DebugEpochState (QFNoTables), so the + -- returned epoch state has empty UTxO tables. We query the relevant + -- UTxOs separately and inject them before running applyTx. + let relevantTxIns = + Set.map fromShelleyTxIn + (shelleyBasedEraConstraints sbe $ ledgerTx ^. bodyTxL . allInputsTxBodyF) + eUtxo <- queryUtxo sbe (QueryUTxOByTxIn relevantTxIns) + return $ do + genParams <- + first QueryValidateTxUnsupportedNtcVersion eGenParams + >>= first QueryValidateTxEraMismatch + serEpochState <- + first QueryValidateTxUnsupportedNtcVersion eSerEpochState + >>= first QueryValidateTxEraMismatch + eraHistory <- first QueryValidateTxUnsupportedNtcVersion eEraHistory + chainPoint <- first QueryValidateTxUnsupportedNtcVersion eChainPoint + utxo <- + first QueryValidateTxUnsupportedNtcVersion eUtxo + >>= first QueryValidateTxEraMismatch + epochState <- first QueryValidateTxEpochStateDecodeError $ + decodeCurrentEpochState sbe serEpochState + let CurrentEpochState es = epochState + LedgerEpochInfo epochInfo = toLedgerEpochInfo eraHistory + globals = mkShelleyGlobals (toShelleyGenesis genParams) epochInfo + slotNo = chainPointToSlotNo chainPoint + Right $ shelleyBasedEraConstraints sbe $ + let esWithUtxo = set utxoL (toLedgerUTxO sbe utxo) es + in void $ applyTx globals (mkMempoolEnv sbe esWithUtxo slotNo) (esLState esWithUtxo) ledgerTx + +chainPointToSlotNo :: ChainPoint -> SlotNo +chainPointToSlotNo ChainPointAtGenesis = SlotNo 0 +chainPointToSlotNo (ChainPoint slotNo _) = slotNo + +mkMempoolEnv + :: ShelleyBasedEra era -> EpochState (ShelleyLedgerEra era) -> SlotNo -> LedgerEnv (ShelleyLedgerEra era) +mkMempoolEnv sbe epochState slotNo = + shelleyBasedEraConstraints sbe $ + LedgerEnv + { ledgerSlotNo = slotNo + , ledgerEpochNo = Nothing + , ledgerIx = minBound + , ledgerPp = epochState ^. curPParamsEpochStateL + , ledgerAccount = esChainAccountState epochState + } + +toShelleyGenesis :: GenesisParameters ShelleyEra -> ShelleyGenesis +toShelleyGenesis gp = + shelleyGenesisDefaults + { sgSystemStart = protocolParamSystemStart gp + , sgNetworkMagic = let NetworkMagic m = toNetworkMagic (protocolParamNetworkId gp) in m + , sgNetworkId = toShelleyNetwork (protocolParamNetworkId gp) + , sgActiveSlotsCoeff = case boundRational (protocolParamActiveSlotsCoefficient gp) of + Nothing -> error "toShelleyGenesis: invalid activeSlotsCoefficient" + Just r -> r + , sgSecurityParam = protocolParamSecurity gp + , sgEpochLength = protocolParamEpochLength gp + , sgSlotsPerKESPeriod = fromIntegral (protocolParamSlotsPerKESPeriod gp) + , sgMaxKESEvolutions = fromIntegral (protocolParamMaxKESEvolutions gp) + , sgUpdateQuorum = fromIntegral (protocolParamUpdateQuorum gp) + , sgMaxLovelaceSupply = fromIntegral (unCoin (protocolParamMaxLovelaceSupply gp)) + , sgProtocolParams = protocolInitialUpdateableProtocolParameters gp + } diff --git a/cardano-api/src/Cardano/Api/Query.hs b/cardano-api/src/Cardano/Api/Query.hs index 6b5f63039f..c10a78c809 100644 --- a/cardano-api/src/Cardano/Api/Query.hs +++ b/cardano-api/src/Cardano/Api/Query.hs @@ -89,6 +89,8 @@ module Cardano.Api.Query , queryProposals , queryStakePoolDefaultVote , queryLedgerConfig + , queryValidateTx + , QueryValidateTxError (..) , DelegationsAndRewards (..) , mergeDelegsAndRewards @@ -99,6 +101,7 @@ module Cardano.Api.Query ) where +import Cardano.Api.Experimental.Tx.Internal.Validate import Cardano.Api.Query.Internal.Convenience import Cardano.Api.Query.Internal.Expr import Cardano.Api.Query.Internal.Type.DebugLedgerState From a8e8f44e187849c8b57e13a12c7ab5c5d36a696f Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Thu, 21 May 2026 05:55:21 +0200 Subject: [PATCH 2/6] Add validateTx convenience function combining phase 1 and phase 2 validation Runs both applyTx (phase 1) and evaluateTransactionExecutionUnits (phase 2) independently in a single LocalStateQueryExpr session, returning both results via TxValidationResult. --- cardano-api/src/Cardano/Api/Experimental.hs | 5 + .../src/Cardano/Api/Experimental/Tx.hs | 138 +++++++++++++++++- 2 files changed, 142 insertions(+), 1 deletion(-) diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs index ae67b6203b..53244e7d61 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -95,6 +95,11 @@ module Cardano.Api.Experimental , makeDrepUpdateCertificate , makeStakeAddressAndDRepDelegationCertificate + -- ** Validation + , TxValidationResult (..) + , QueryValidateTxError (..) + , validateTx + -- * Data family instances , AsType (..) diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx.hs b/cardano-api/src/Cardano/Api/Experimental/Tx.hs index f67964e269..ab52d0b472 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -205,6 +206,11 @@ module Cardano.Api.Experimental.Tx , TxBodyErrorAutoBalance (..) , TxFeeEstimationError (..) + -- * Validation + , TxValidationResult (..) + , QueryValidateTxError (..) + , validateTx + -- ** Internal functions , extractExecutionUnits , getTxScriptWitnessRequirements @@ -225,28 +231,50 @@ import Cardano.Api.Experimental.Tx.Internal.BodyContent.New import Cardano.Api.Experimental.Tx.Internal.Fee import Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements import Cardano.Api.Experimental.Tx.Internal.Type +import Cardano.Api.Experimental.Tx.Internal.Validate (QueryValidateTxError (..), queryValidateTx) import Cardano.Api.HasTypeProxy (HasTypeProxy (..), Proxy, asType) import Cardano.Api.Ledger.Internal.Reexport qualified as L +import Cardano.Api.Network.IPC (LocalStateQueryExpr) import Cardano.Api.Plutus.Internal.Script qualified as Api import Cardano.Api.Pretty (docToString, pretty) import Cardano.Api.ProtocolParameters +import Cardano.Api.Query.Internal.Expr + ( queryEraHistory + , queryProtocolParameters + , querySystemStart + , queryUtxo + ) +import Cardano.Api.Query.Internal.Type.QueryInMode + ( QueryInMode + , QueryUTxOFilter (..) + , toLedgerEpochInfo + , toLedgerUTxO + ) import Cardano.Api.Serialise.Raw ( SerialiseAsRawBytes (..) , SerialiseAsRawBytesError (SerialiseAsRawBytesError) ) import Cardano.Api.Tx.Internal.Body qualified as Api +import Cardano.Api.Tx.Internal.Fee (EvalTxExecutionUnitsLog, ScriptExecutionError) import Cardano.Api.Tx.Internal.Sign import Cardano.Crypto.Hash qualified as Hash +import Cardano.Ledger.Alonzo qualified as LAlonzo +import Cardano.Ledger.Alonzo.Rules qualified as LAlonzo import Cardano.Ledger.Alonzo.Tx qualified as L import Cardano.Ledger.Api qualified as L +import Cardano.Ledger.Babbage qualified as LBabbage +import Cardano.Ledger.Babbage.Rules qualified as LBabbage import Cardano.Ledger.Binary qualified as Ledger import Cardano.Ledger.Core qualified as Ledger import Cardano.Ledger.Hashes qualified as L hiding (Hash) +import Cardano.Ledger.Shelley.API (ApplyTxError) +import Cardano.Ledger.Shelley.Rules qualified as LShelley import Control.Exception (displayException) -import Data.Bifunctor (bimap) +import Data.Bifunctor (bimap, first) import Data.ByteString.Lazy (fromStrict) +import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set qualified as Set @@ -380,3 +408,111 @@ purposeAsIxItemToAsIx -> L.PlutusPurpose L.AsIx (LedgerEra era) purposeAsIxItemToAsIx purpose = obtainCommonConstraints (useEra @era) $ L.hoistPlutusPurpose L.toAsIx purpose + +data TxValidationResult era = TxValidationResult + { phase1Result :: Either (ApplyTxError (ShelleyLedgerEra era)) () + , phase2Result :: Map Api.ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, Api.ExecutionUnits)) + } + +deriving instance Show (ApplyTxError (ShelleyLedgerEra era)) => Show (TxValidationResult era) + +validateTx + :: forall era block point r + . ShelleyBasedEra era + -> Tx era + -> LocalStateQueryExpr + block + point + QueryInMode + r + IO + (Either QueryValidateTxError (TxValidationResult era)) +validateTx sbe tx@(ShelleyTx _sbe ledgerTx) = + Api.forEraInEon + (Api.toCardanoEra sbe) + (error $ "validateTx: unsupported era " <> docToString (pretty sbe)) + ( \expEra -> obtainCommonConstraints expEra $ do + ePhase1 <- queryValidateTx sbe tx + + eSystemStart <- querySystemStart + eEraHistory <- queryEraHistory + ePparams <- queryProtocolParameters sbe + let relevantTxIns = + Set.map Api.fromShelleyTxIn (ledgerTx ^. L.bodyTxL . L.allInputsTxBodyF) + eUtxo <- queryUtxo sbe (QueryUTxOByTxIn relevantTxIns) + + return $ do + phase1 <- ePhase1 + systemStart <- first QueryValidateTxUnsupportedNtcVersion eSystemStart + eraHistory <- first QueryValidateTxUnsupportedNtcVersion eEraHistory + pparams <- + first QueryValidateTxUnsupportedNtcVersion ePparams + >>= first QueryValidateTxEraMismatch + utxo <- + first QueryValidateTxUnsupportedNtcVersion eUtxo + >>= first QueryValidateTxEraMismatch + + let ledgerUtxo = toLedgerUTxO sbe utxo + ledgerEpochInfo = toLedgerEpochInfo eraHistory + phase2 = + evaluateTransactionExecutionUnits + systemStart + ledgerEpochInfo + pparams + ledgerUtxo + ledgerTx + + let phase1Filtered = filterScriptFailures sbe phase1 + Right $ TxValidationResult phase1Filtered phase2 + ) + +filterScriptFailures + :: ShelleyBasedEra era + -> Either (ApplyTxError (ShelleyLedgerEra era)) () + -> Either (ApplyTxError (ShelleyLedgerEra era)) () +filterScriptFailures sbe = \case + Right () -> Right () + Left err -> case sbe of + ShelleyBasedEraShelley -> Left err + ShelleyBasedEraAllegra -> Left err + ShelleyBasedEraMary -> Left err + ShelleyBasedEraAlonzo -> + let LAlonzo.AlonzoApplyTxError failures = err + isScript = \case + LShelley.UtxowFailure (LAlonzo.ShelleyInAlonzoUtxowPredFailure (LShelley.UtxoFailure (LAlonzo.UtxosFailure {}))) -> True + LShelley.UtxowFailure {} -> False + LShelley.DelegsFailure {} -> False + LShelley.ShelleyWithdrawalsMissingAccounts {} -> False + LShelley.ShelleyIncompleteWithdrawals {} -> False + in filterFailures LAlonzo.AlonzoApplyTxError isScript failures + ShelleyBasedEraBabbage -> + let LBabbage.BabbageApplyTxError failures = err + isScript = \case + LShelley.UtxowFailure (LBabbage.UtxoFailure (LBabbage.AlonzoInBabbageUtxoPredFailure (LAlonzo.UtxosFailure {}))) -> True + LShelley.UtxowFailure {} -> False + LShelley.DelegsFailure {} -> False + LShelley.ShelleyWithdrawalsMissingAccounts {} -> False + LShelley.ShelleyIncompleteWithdrawals {} -> False + in filterFailures LBabbage.BabbageApplyTxError isScript failures + ShelleyBasedEraDijkstra -> error "TODO Dijkstra: filterScriptFailures" + ShelleyBasedEraConway -> + let L.ConwayApplyTxError failures = err + isScript = \case + L.ConwayUtxowFailure (L.UtxoFailure (L.UtxosFailure {})) -> True + L.ConwayUtxowFailure {} -> False + L.ConwayCertsFailure {} -> False + L.ConwayGovFailure {} -> False + L.ConwayWdrlNotDelegatedToDRep {} -> False + L.ConwayTreasuryValueMismatch {} -> False + L.ConwayTxRefScriptsSizeTooBig {} -> False + L.ConwayMempoolFailure {} -> False + L.ConwayWithdrawalsMissingAccounts {} -> False + L.ConwayIncompleteWithdrawals {} -> False + in filterFailures L.ConwayApplyTxError isScript failures + +filterFailures + :: (NE.NonEmpty a -> b) -> (a -> Bool) -> NE.NonEmpty a -> Either b () +filterFailures wrap isScript failures = + case NE.nonEmpty (filter (not . isScript) (NE.toList failures)) of + Nothing -> Right () + Just remaining -> Left (wrap remaining) From 3c81e204632896331461079d51a422fc1edcb4da Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Tue, 26 May 2026 00:28:46 +0200 Subject: [PATCH 3/6] Modify validateTx to use experimental api instead --- cardano-api/src/Cardano/Api/Experimental.hs | 1 + .../src/Cardano/Api/Experimental/Era.hs | 6 + .../src/Cardano/Api/Experimental/Tx.hs | 189 ++++++------------ .../Api/Experimental/Tx/Internal/Type.hs | 35 ++++ .../Api/Experimental/Tx/Internal/Validate.hs | 39 ++-- 5 files changed, 124 insertions(+), 146 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs index 53244e7d61..51c9f7a627 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -40,6 +40,7 @@ module Cardano.Api.Experimental , Era (..) , IsEra (..) , Some (..) + , InAnyEra (..) , LedgerEra , DeprecatedEra (..) , eraToSbe diff --git a/cardano-api/src/Cardano/Api/Experimental/Era.hs b/cardano-api/src/Cardano/Api/Experimental/Era.hs index 47e42cb644..f363b96761 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Era.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Era.hs @@ -20,6 +20,7 @@ module Cardano.Api.Experimental.Era , Era (..) , IsEra (..) , Some (..) + , InAnyEra (..) , Inject (..) , Convert (..) , LedgerEra @@ -93,6 +94,11 @@ data Some (f :: k -> Type) where => f a -> Some f +-- | Pair an era witness with a value indexed by that era, +-- hiding the era type parameter existentially. +data InAnyEra f where + InAnyEra :: IsEra era => Era era -> f era -> InAnyEra f + -- | Represents the latest Cardano blockchain eras, including -- the one currently on mainnet and the upcoming one. -- diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx.hs b/cardano-api/src/Cardano/Api/Experimental/Tx.hs index ab52d0b472..2281cf1ff5 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -232,12 +231,10 @@ import Cardano.Api.Experimental.Tx.Internal.Fee import Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements import Cardano.Api.Experimental.Tx.Internal.Type import Cardano.Api.Experimental.Tx.Internal.Validate (QueryValidateTxError (..), queryValidateTx) -import Cardano.Api.HasTypeProxy (HasTypeProxy (..), Proxy, asType) import Cardano.Api.Ledger.Internal.Reexport qualified as L import Cardano.Api.Network.IPC (LocalStateQueryExpr) import Cardano.Api.Plutus.Internal.Script qualified as Api import Cardano.Api.Pretty (docToString, pretty) -import Cardano.Api.ProtocolParameters import Cardano.Api.Query.Internal.Expr ( queryEraHistory , queryProtocolParameters @@ -250,30 +247,18 @@ import Cardano.Api.Query.Internal.Type.QueryInMode , toLedgerEpochInfo , toLedgerUTxO ) -import Cardano.Api.Serialise.Raw - ( SerialiseAsRawBytes (..) - , SerialiseAsRawBytesError (SerialiseAsRawBytesError) - ) import Cardano.Api.Tx.Internal.Body qualified as Api import Cardano.Api.Tx.Internal.Fee (EvalTxExecutionUnitsLog, ScriptExecutionError) import Cardano.Api.Tx.Internal.Sign import Cardano.Crypto.Hash qualified as Hash -import Cardano.Ledger.Alonzo qualified as LAlonzo -import Cardano.Ledger.Alonzo.Rules qualified as LAlonzo import Cardano.Ledger.Alonzo.Tx qualified as L import Cardano.Ledger.Api qualified as L -import Cardano.Ledger.Babbage qualified as LBabbage -import Cardano.Ledger.Babbage.Rules qualified as LBabbage -import Cardano.Ledger.Binary qualified as Ledger import Cardano.Ledger.Core qualified as Ledger import Cardano.Ledger.Hashes qualified as L hiding (Hash) import Cardano.Ledger.Shelley.API (ApplyTxError) -import Cardano.Ledger.Shelley.Rules qualified as LShelley -import Control.Exception (displayException) import Data.Bifunctor (bimap, first) -import Data.ByteString.Lazy (fromStrict) import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map @@ -307,39 +292,6 @@ makeKeyWitness era (UnsignedTx unsignedTx) wsk = signature = makeShelleySignature txhash sk in L.WitVKey vk signature --- | A transaction that has been witnesssed -data SignedTx era - = L.EraTx (LedgerEra era) => SignedTx (Ledger.Tx Ledger.TopTx (LedgerEra era)) - -deriving instance Eq (SignedTx era) - -deriving instance Show (SignedTx era) - -instance HasTypeProxy era => HasTypeProxy (SignedTx era) where - data AsType (SignedTx era) = AsSignedTx (AsType era) - proxyToAsType :: Proxy (SignedTx era) -> AsType (SignedTx era) - proxyToAsType _ = AsSignedTx (asType @era) - -instance - ( HasTypeProxy era - , L.EraTx (LedgerEra era) - ) - => SerialiseAsRawBytes (SignedTx era) - where - serialiseToRawBytes (SignedTx tx) = - Ledger.serialize' (Ledger.eraProtVerHigh @(LedgerEra era)) tx - deserialiseFromRawBytes _ = - bimap wrapError SignedTx - . Ledger.decodeFullAnnotator - (Ledger.eraProtVerHigh @(LedgerEra era)) - "SignedTx" - Ledger.decCBOR - . fromStrict - where - wrapError - :: Ledger.DecoderError -> SerialiseAsRawBytesError - wrapError = SerialiseAsRawBytesError . displayException - signTx :: Era era -> [L.BootstrapWitness] @@ -410,16 +362,19 @@ purposeAsIxItemToAsIx purpose = obtainCommonConstraints (useEra @era) $ L.hoistPlutusPurpose L.toAsIx purpose data TxValidationResult era = TxValidationResult - { phase1Result :: Either (ApplyTxError (ShelleyLedgerEra era)) () - , phase2Result :: Map Api.ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, Api.ExecutionUnits)) + { phase1Result :: Either (ApplyTxError (LedgerEra era)) () + , phase2Result + :: Map + Api.ScriptWitnessIndex + (Either ScriptExecutionError (EvalTxExecutionUnitsLog, Api.ExecutionUnits)) } -deriving instance Show (ApplyTxError (ShelleyLedgerEra era)) => Show (TxValidationResult era) +deriving instance Show (ApplyTxError (LedgerEra era)) => Show (TxValidationResult era) validateTx :: forall era block point r - . ShelleyBasedEra era - -> Tx era + . IsEra era + => SignedTx era -> LocalStateQueryExpr block point @@ -427,87 +382,63 @@ validateTx r IO (Either QueryValidateTxError (TxValidationResult era)) -validateTx sbe tx@(ShelleyTx _sbe ledgerTx) = - Api.forEraInEon - (Api.toCardanoEra sbe) - (error $ "validateTx: unsupported era " <> docToString (pretty sbe)) - ( \expEra -> obtainCommonConstraints expEra $ do - ePhase1 <- queryValidateTx sbe tx - - eSystemStart <- querySystemStart - eEraHistory <- queryEraHistory - ePparams <- queryProtocolParameters sbe - let relevantTxIns = - Set.map Api.fromShelleyTxIn (ledgerTx ^. L.bodyTxL . L.allInputsTxBodyF) - eUtxo <- queryUtxo sbe (QueryUTxOByTxIn relevantTxIns) - - return $ do - phase1 <- ePhase1 - systemStart <- first QueryValidateTxUnsupportedNtcVersion eSystemStart - eraHistory <- first QueryValidateTxUnsupportedNtcVersion eEraHistory - pparams <- - first QueryValidateTxUnsupportedNtcVersion ePparams - >>= first QueryValidateTxEraMismatch - utxo <- - first QueryValidateTxUnsupportedNtcVersion eUtxo - >>= first QueryValidateTxEraMismatch - - let ledgerUtxo = toLedgerUTxO sbe utxo - ledgerEpochInfo = toLedgerEpochInfo eraHistory - phase2 = - evaluateTransactionExecutionUnits - systemStart - ledgerEpochInfo - pparams - ledgerUtxo - ledgerTx - - let phase1Filtered = filterScriptFailures sbe phase1 - Right $ TxValidationResult phase1Filtered phase2 - ) +validateTx stx@(SignedTx ledgerTx) = + obtainCommonConstraints (useEra @era) $ do + let sbe = convert (useEra @era) + ePhase1 <- queryValidateTx stx + + eSystemStart <- querySystemStart + eEraHistory <- queryEraHistory + ePparams <- queryProtocolParameters sbe + let relevantTxIns = + Set.map Api.fromShelleyTxIn (ledgerTx ^. L.bodyTxL . L.allInputsTxBodyF) + eUtxo <- queryUtxo sbe (QueryUTxOByTxIn relevantTxIns) + + return $ do + phase1 <- ePhase1 + systemStart <- first QueryValidateTxUnsupportedNtcVersion eSystemStart + eraHistory <- first QueryValidateTxUnsupportedNtcVersion eEraHistory + pparams <- + first QueryValidateTxUnsupportedNtcVersion ePparams + >>= first QueryValidateTxEraMismatch + utxo <- + first QueryValidateTxUnsupportedNtcVersion eUtxo + >>= first QueryValidateTxEraMismatch + + let ledgerUtxo = toLedgerUTxO sbe utxo + ledgerEpochInfo = toLedgerEpochInfo eraHistory + phase2 = + evaluateTransactionExecutionUnits + systemStart + ledgerEpochInfo + pparams + ledgerUtxo + ledgerTx + + let phase1Filtered = filterScriptFailures (useEra @era) phase1 + Right $ TxValidationResult phase1Filtered phase2 filterScriptFailures - :: ShelleyBasedEra era - -> Either (ApplyTxError (ShelleyLedgerEra era)) () - -> Either (ApplyTxError (ShelleyLedgerEra era)) () -filterScriptFailures sbe = \case + :: Era era + -> Either (ApplyTxError (LedgerEra era)) () + -> Either (ApplyTxError (LedgerEra era)) () +filterScriptFailures era = \case Right () -> Right () - Left err -> case sbe of - ShelleyBasedEraShelley -> Left err - ShelleyBasedEraAllegra -> Left err - ShelleyBasedEraMary -> Left err - ShelleyBasedEraAlonzo -> - let LAlonzo.AlonzoApplyTxError failures = err - isScript = \case - LShelley.UtxowFailure (LAlonzo.ShelleyInAlonzoUtxowPredFailure (LShelley.UtxoFailure (LAlonzo.UtxosFailure {}))) -> True - LShelley.UtxowFailure {} -> False - LShelley.DelegsFailure {} -> False - LShelley.ShelleyWithdrawalsMissingAccounts {} -> False - LShelley.ShelleyIncompleteWithdrawals {} -> False - in filterFailures LAlonzo.AlonzoApplyTxError isScript failures - ShelleyBasedEraBabbage -> - let LBabbage.BabbageApplyTxError failures = err - isScript = \case - LShelley.UtxowFailure (LBabbage.UtxoFailure (LBabbage.AlonzoInBabbageUtxoPredFailure (LAlonzo.UtxosFailure {}))) -> True - LShelley.UtxowFailure {} -> False - LShelley.DelegsFailure {} -> False - LShelley.ShelleyWithdrawalsMissingAccounts {} -> False - LShelley.ShelleyIncompleteWithdrawals {} -> False - in filterFailures LBabbage.BabbageApplyTxError isScript failures - ShelleyBasedEraDijkstra -> error "TODO Dijkstra: filterScriptFailures" - ShelleyBasedEraConway -> + Left err -> case era of + DijkstraEra -> error "TODO Dijkstra: filterScriptFailures" + ConwayEra -> let L.ConwayApplyTxError failures = err isScript = \case - L.ConwayUtxowFailure (L.UtxoFailure (L.UtxosFailure {})) -> True - L.ConwayUtxowFailure {} -> False - L.ConwayCertsFailure {} -> False - L.ConwayGovFailure {} -> False - L.ConwayWdrlNotDelegatedToDRep {} -> False - L.ConwayTreasuryValueMismatch {} -> False - L.ConwayTxRefScriptsSizeTooBig {} -> False - L.ConwayMempoolFailure {} -> False - L.ConwayWithdrawalsMissingAccounts {} -> False - L.ConwayIncompleteWithdrawals {} -> False + L.ConwayUtxowFailure (L.UtxoFailure (L.UtxosFailure{})) -> True + L.ConwayUtxowFailure{} -> False + L.ConwayCertsFailure{} -> False + L.ConwayGovFailure{} -> False + L.ConwayWdrlNotDelegatedToDRep{} -> False + L.ConwayTreasuryValueMismatch{} -> False + L.ConwayTxRefScriptsSizeTooBig{} -> False + L.ConwayMempoolFailure{} -> False + L.ConwayWithdrawalsMissingAccounts{} -> False + L.ConwayIncompleteWithdrawals{} -> False in filterFailures L.ConwayApplyTxError isScript failures filterFailures diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Type.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Type.hs index 6b0571314d..77742fc1c1 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Type.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Type.hs @@ -14,10 +14,12 @@ module Cardano.Api.Experimental.Tx.Internal.Type ( UnsignedTx (..) + , SignedTx (..) ) where import Cardano.Api.Era.Internal.Core qualified as Api +import Cardano.Api.Experimental.Era (LedgerEra) import Cardano.Api.HasTypeProxy (HasTypeProxy (..), asType) import Cardano.Api.Ledger.Internal.Reexport qualified as L import Cardano.Api.ProtocolParameters @@ -98,4 +100,37 @@ instance deriving instance Eq (UnsignedTx era) +-- | A transaction that has been witnessed +data SignedTx era + = L.EraTx (LedgerEra era) => SignedTx (Ledger.Tx Ledger.TopTx (LedgerEra era)) + +deriving instance Eq (SignedTx era) + +deriving instance Show (SignedTx era) + +instance HasTypeProxy era => HasTypeProxy (SignedTx era) where + data AsType (SignedTx era) = AsSignedTx (AsType era) + proxyToAsType :: Proxy (SignedTx era) -> AsType (SignedTx era) + proxyToAsType _ = AsSignedTx (asType @era) + +instance + ( HasTypeProxy era + , L.EraTx (LedgerEra era) + ) + => SerialiseAsRawBytes (SignedTx era) + where + serialiseToRawBytes (SignedTx tx) = + Ledger.serialize' (Ledger.eraProtVerHigh @(LedgerEra era)) tx + deserialiseFromRawBytes _ = + bimap wrapError SignedTx + . Ledger.decodeFullAnnotator + (Ledger.eraProtVerHigh @(LedgerEra era)) + "SignedTx" + Ledger.decCBOR + . fromStrict + where + wrapError + :: Ledger.DecoderError -> SerialiseAsRawBytesError + wrapError = SerialiseAsRawBytesError . displayException + deriving instance Show (UnsignedTx era) diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Validate.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Validate.hs index 1c805a782e..d90f1a2ac1 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Validate.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Validate.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Cardano.Api.Experimental.Tx.Internal.Validate ( queryValidateTx @@ -11,6 +12,8 @@ where import Cardano.Api.Block (ChainPoint (..)) import Cardano.Api.Era +import Cardano.Api.Experimental.Era (IsEra, LedgerEra, obtainCommonConstraints, useEra) +import Cardano.Api.Experimental.Tx.Internal.Type (SignedTx (..)) import Cardano.Api.Genesis.Internal (shelleyGenesisDefaults) import Cardano.Api.Genesis.Internal.Parameters import Cardano.Api.Network.IPC (LocalStateQueryExpr) @@ -18,11 +21,8 @@ import Cardano.Api.Network.IPC.Internal.Version (UnsupportedNtcVersionError) import Cardano.Api.Network.Internal.NetworkId (NetworkMagic (..), toNetworkMagic, toShelleyNetwork) import Cardano.Api.Query.Internal.Expr import Cardano.Api.Query.Internal.Type.QueryInMode -import Cardano.Api.Tx.Internal.Sign (Tx (..)) import Cardano.Api.Tx.Internal.TxIn (fromShelleyTxIn) -import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch) - import Cardano.Binary qualified as CBOR import Cardano.Ledger.BaseTypes (boundRational) import Cardano.Ledger.Coin (unCoin) @@ -32,6 +32,7 @@ import Cardano.Ledger.Shelley.Genesis (ShelleyGenesis (..), mkShelleyGlobals) import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL) import Cardano.Ledger.State (utxoL) import Cardano.Slotting.Slot (SlotNo (..)) +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch) import Control.Monad (void) import Data.Bifunctor (first) @@ -53,16 +54,17 @@ data QueryValidateTxError -- signature as a normal local state query. queryValidateTx :: forall era block point r - . ShelleyBasedEra era - -> Tx era + . IsEra era + => SignedTx era -> LocalStateQueryExpr block point QueryInMode r IO - (Either QueryValidateTxError (Either (ApplyTxError (ShelleyLedgerEra era)) ())) -queryValidateTx sbe (ShelleyTx _sbe ledgerTx) = do + (Either QueryValidateTxError (Either (ApplyTxError (LedgerEra era)) ())) +queryValidateTx (SignedTx ledgerTx) = obtainCommonConstraints (useEra @era) $ do + let sbe = convert (useEra @era) eGenParams <- queryGenesisParameters sbe eSerEpochState <- queryCurrentEpochState sbe eEraHistory <- queryEraHistory @@ -71,8 +73,9 @@ queryValidateTx sbe (ShelleyTx _sbe ledgerTx) = do -- returned epoch state has empty UTxO tables. We query the relevant -- UTxOs separately and inject them before running applyTx. let relevantTxIns = - Set.map fromShelleyTxIn - (shelleyBasedEraConstraints sbe $ ledgerTx ^. bodyTxL . allInputsTxBodyF) + Set.map + fromShelleyTxIn + (ledgerTx ^. bodyTxL . allInputsTxBodyF) eUtxo <- queryUtxo sbe (QueryUTxOByTxIn relevantTxIns) return $ do genParams <- @@ -86,24 +89,26 @@ queryValidateTx sbe (ShelleyTx _sbe ledgerTx) = do utxo <- first QueryValidateTxUnsupportedNtcVersion eUtxo >>= first QueryValidateTxEraMismatch - epochState <- first QueryValidateTxEpochStateDecodeError $ - decodeCurrentEpochState sbe serEpochState + epochState <- + first QueryValidateTxEpochStateDecodeError $ + decodeCurrentEpochState sbe serEpochState let CurrentEpochState es = epochState LedgerEpochInfo epochInfo = toLedgerEpochInfo eraHistory globals = mkShelleyGlobals (toShelleyGenesis genParams) epochInfo slotNo = chainPointToSlotNo chainPoint - Right $ shelleyBasedEraConstraints sbe $ - let esWithUtxo = set utxoL (toLedgerUTxO sbe utxo) es - in void $ applyTx globals (mkMempoolEnv sbe esWithUtxo slotNo) (esLState esWithUtxo) ledgerTx + Right $ + shelleyBasedEraConstraints sbe $ + let esWithUtxo = set utxoL (toLedgerUTxO sbe utxo) es + in void $ applyTx globals (mkMempoolEnv @era esWithUtxo slotNo) (esLState esWithUtxo) ledgerTx chainPointToSlotNo :: ChainPoint -> SlotNo chainPointToSlotNo ChainPointAtGenesis = SlotNo 0 chainPointToSlotNo (ChainPoint slotNo _) = slotNo mkMempoolEnv - :: ShelleyBasedEra era -> EpochState (ShelleyLedgerEra era) -> SlotNo -> LedgerEnv (ShelleyLedgerEra era) -mkMempoolEnv sbe epochState slotNo = - shelleyBasedEraConstraints sbe $ + :: forall era. IsEra era => EpochState (LedgerEra era) -> SlotNo -> LedgerEnv (LedgerEra era) +mkMempoolEnv epochState slotNo = + obtainCommonConstraints (useEra @era) $ LedgerEnv { ledgerSlotNo = slotNo , ledgerEpochNo = Nothing From 2ae516cb39c71a6192914a5d027e696092b94b61 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Fri, 22 May 2026 04:46:17 +0200 Subject: [PATCH 4/6] Re-export Conway validation types through Cardano.Api.Ledger Add re-exports for ApplyTxError(..), ConwayLedgerPredFailure(..), ConwayUtxowPredFailure(..), ConwayUtxoPredFailure(..), Mismatch(..), and hashToTextAsHex so downstream consumers (cardano-cli) can pattern-match on ledger predicate failures for human-readable error rendering. --- .../Cardano/Api/Ledger/Internal/Reexport.hs | 54 +++++++++++++++++-- 1 file changed, 51 insertions(+), 3 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Ledger/Internal/Reexport.hs b/cardano-api/src/Cardano/Api/Ledger/Internal/Reexport.hs index 6c92113e0b..c33dfba1ab 100644 --- a/cardano-api/src/Cardano/Api/Ledger/Internal/Reexport.hs +++ b/cardano-api/src/Cardano/Api/Ledger/Internal/Reexport.hs @@ -46,6 +46,7 @@ module Cardano.Api.Ledger.Internal.Reexport -- Core , Addr , Coin (..) + , DeltaCoin (..) , Compactible (..) , partialCompactFL , toCompactPartial @@ -71,6 +72,7 @@ module Cardano.Api.Ledger.Internal.Reexport , Val (..) , addDeltaCoin , castSafeHash + , coinTxOutL , getScriptsNeeded , mkBasicTxOut , toDeltaCoin @@ -84,6 +86,22 @@ module Cardano.Api.Ledger.Internal.Reexport -- Dijkstra , DijkstraPlutusPurpose (..) -- Conway + , ApplyTxError (..) + , ConwayLedgerPredFailure (..) + , ConwayUtxowPredFailure (..) + , ConwayUtxoPredFailure (..) + , ConwayCertsPredFailure (..) + , ConwayCertPredFailure (..) + , ConwayDelegPredFailure (..) + , ConwayGovCertPredFailure (..) + , ConwayGovPredFailure (..) + , ConwayUtxosPredFailure (..) + , ShelleyPoolPredFailure (..) + , TagMismatchDescription (..) + , FailureDescription (..) + , CollectError (..) + , IsValid (..) + , Withdrawals (..) , Anchor (..) , Committee (..) , Delegatee (..) @@ -148,6 +166,7 @@ module Cardano.Api.Ledger.Internal.Reexport , AlonzoEraTxWits (..) , AlonzoPlutusPurpose (..) , AlonzoScriptsNeeded (..) + , AsItem (..) , AsIx (..) , CoinPerWord (..) , Data (..) @@ -179,6 +198,8 @@ module Cardano.Api.Ledger.Internal.Reexport , showTimelock , toAsIx -- Base + , Mismatch (..) + , Relation (..) , boundRational , unboundRational , DnsName @@ -201,12 +222,16 @@ module Cardano.Api.Ledger.Internal.Reexport -- Crypto , hashToBytes , hashFromBytes + , hashToTextAsHex , Crypto , StandardCrypto , ADDRHASH -- Slotting , EpochNo (..) -- SafeHash + , ScriptHash (..) + , DataHash + , TxAuxDataHash (..) , SafeHash , unsafeMakeSafeHash , extractHash @@ -215,13 +240,14 @@ module Cardano.Api.Ledger.Internal.Reexport ) where -import Cardano.Crypto.Hash.Class (hashFromBytes, hashToBytes) -import Cardano.Ledger.Address (AccountAddress (..), Addr (..)) +import Cardano.Crypto.Hash.Class (hashFromBytes, hashToBytes, hashToTextAsHex) +import Cardano.Ledger.Address (AccountAddress (..), Addr (..), Withdrawals (..)) import Cardano.Ledger.Allegra.Scripts (AllegraEraScript (..), Timelock (..), showTimelock) import Cardano.Ledger.Alonzo.Core ( AlonzoEraScript (..) , AlonzoEraTxBody (..) , AlonzoEraTxWits (..) + , AsItem (..) , AsIx (..) , AsIxItem (AsIxItem) , CoinPerWord (..) @@ -244,6 +270,9 @@ import Cardano.Ledger.Alonzo.Scripts , plutusScriptLanguage , toAsIx ) +import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (..)) +import Cardano.Ledger.Alonzo.Rules (FailureDescription (..), TagMismatchDescription (..)) +import Cardano.Ledger.Alonzo.Tx (IsValid (..)) import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), TxDats (..)) import Cardano.Ledger.Alonzo.UTxO (AlonzoScriptsNeeded (..)) import Cardano.Ledger.Api @@ -276,9 +305,11 @@ import Cardano.Ledger.BaseTypes , DnsName , EpochInterval (..) , Inject (..) + , Mismatch (..) , Network (..) , NonNegativeInterval , ProtVer (..) + , Relation (..) , StrictMaybe (..) , UnitInterval , Url @@ -306,7 +337,7 @@ import Cardano.Ledger.Binary , toPlainDecoder ) import Cardano.Ledger.Binary.Plain (Decoder, serializeAsHexText) -import Cardano.Ledger.Coin (Coin (..), addDeltaCoin, toDeltaCoin) +import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..), addDeltaCoin, toDeltaCoin) import Cardano.Ledger.Compactible import Cardano.Ledger.Conway.Core ( DRepVotingThresholds (..) @@ -317,7 +348,19 @@ import Cardano.Ledger.Conway.Core , dvtPPTechnicalGroupL , dvtUpdateToConstitutionL ) +import Cardano.Ledger.Conway (ApplyTxError (..)) import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) +import Cardano.Ledger.Conway.Rules + ( ConwayCertPredFailure (..) + , ConwayCertsPredFailure (..) + , ConwayDelegPredFailure (..) + , ConwayGovCertPredFailure (..) + , ConwayGovPredFailure (..) + , ConwayLedgerPredFailure (..) + , ConwayUtxoPredFailure (..) + , ConwayUtxosPredFailure (..) + , ConwayUtxowPredFailure (..) + ) import Cardano.Ledger.Conway.Governance ( Anchor (..) , Committee (..) @@ -350,6 +393,7 @@ import Cardano.Ledger.Core , PoolCert (..) , TxOut , Value + , coinTxOutL , fromEraCBOR , mkBasicTxOut , ppMinFeeAL @@ -362,7 +406,10 @@ import Cardano.Ledger.DRep (DRep (..), drepAnchorL, drepDepositL, drepExpiryL) import Cardano.Ledger.Dijkstra.Scripts (DijkstraPlutusPurpose (..)) import Cardano.Ledger.Hashes ( ADDRHASH + , DataHash , SafeHash + , ScriptHash (..) + , TxAuxDataHash (..) , castSafeHash , extractHash , unsafeMakeSafeHash @@ -394,6 +441,7 @@ import Cardano.Ledger.Shelley.API , WitVKey (..) , hashKey ) +import Cardano.Ledger.Shelley.Rules (ShelleyPoolPredFailure (..)) import Cardano.Ledger.Shelley.Genesis ( ShelleyGenesisStaking (..) , secondsToNominalDiffTimeMicro From 1793dfd1b83e4d75a919f5ce21080613eb78595e Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Wed, 27 May 2026 03:23:36 +0200 Subject: [PATCH 5/6] Add SRP for `ouroboros-consensus` and `ouroboros-network` --- cabal.project | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/cabal.project b/cabal.project index 6bc4498438..ae9faf56b0 100644 --- a/cabal.project +++ b/cabal.project @@ -20,6 +20,38 @@ 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: ouroboros-network + --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: cardano-diffusion + --sha256: 1r5y5px0kj4nhb65s9i7pr0sikxghfqwfkzmsgiql2maic4nglwi + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network.git + tag: 65da1ad619473f9467d3336a6d6e9a2a8714913d + subdir: network-mux + --sha256: 1r5y5px0kj4nhb65s9i7pr0sikxghfqwfkzmsgiql2maic4nglwi + +-- END SRP STANZAS MANAGED BY STANZAMAN -- + packages: cardano-api cardano-api-gen From 13b452f32cf053a803988f455551a697726c65cc Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Wed, 27 May 2026 04:37:31 +0200 Subject: [PATCH 6/6] Use server-side `ValidateTx` consensus query for transaction validation Replace the provisional client-side applyTx implementation with a proper server-side query through the LocalStateQuery protocol. This avoids transferring the full ledger state to the client. --- .../Api/Experimental/Tx/Internal/Validate.hs | 107 ++---------------- .../src/Cardano/Api/Query/Internal/Expr.hs | 1 + .../Api/Query/Internal/Type/QueryInMode.hs | 13 ++- .../Test/Cardano/Api/Cip129.hs | 1 - 4 files changed, 22 insertions(+), 100 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Validate.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Validate.hs index d90f1a2ac1..f3ed0b52b8 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Validate.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Validate.hs @@ -10,48 +10,23 @@ module Cardano.Api.Experimental.Tx.Internal.Validate ) where -import Cardano.Api.Block (ChainPoint (..)) -import Cardano.Api.Era +import Cardano.Api.Era.Internal.Eon.Convert (convert) import Cardano.Api.Experimental.Era (IsEra, LedgerEra, obtainCommonConstraints, useEra) import Cardano.Api.Experimental.Tx.Internal.Type (SignedTx (..)) -import Cardano.Api.Genesis.Internal (shelleyGenesisDefaults) -import Cardano.Api.Genesis.Internal.Parameters import Cardano.Api.Network.IPC (LocalStateQueryExpr) import Cardano.Api.Network.IPC.Internal.Version (UnsupportedNtcVersionError) -import Cardano.Api.Network.Internal.NetworkId (NetworkMagic (..), toNetworkMagic, toShelleyNetwork) import Cardano.Api.Query.Internal.Expr import Cardano.Api.Query.Internal.Type.QueryInMode -import Cardano.Api.Tx.Internal.TxIn (fromShelleyTxIn) +import Cardano.Api.Tx.Internal.Sign (Tx (..)) -import Cardano.Binary qualified as CBOR -import Cardano.Ledger.BaseTypes (boundRational) -import Cardano.Ledger.Coin (unCoin) -import Cardano.Ledger.Core (allInputsTxBodyF, bodyTxL) -import Cardano.Ledger.Shelley.API (ApplyTxError, EpochState (..), LedgerEnv (..), applyTx) -import Cardano.Ledger.Shelley.Genesis (ShelleyGenesis (..), mkShelleyGlobals) -import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL) -import Cardano.Ledger.State (utxoL) -import Cardano.Slotting.Slot (SlotNo (..)) +import Cardano.Ledger.Shelley.API (ApplyTxError) import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch) -import Control.Monad (void) -import Data.Bifunctor (first) -import Data.Set qualified as Set -import Lens.Micro (set, (^.)) - data QueryValidateTxError = QueryValidateTxUnsupportedNtcVersion UnsupportedNtcVersionError | QueryValidateTxEraMismatch EraMismatch - | QueryValidateTxEpochStateDecodeError CBOR.DecoderError deriving Show --- | Run applyTx against the node's current ledger state and return the raw result. --- --- TODO: Replace this provisional implementation (which queries the full --- EpochState from the node and runs applyTx client-side) with a dedicated --- node-side consensus query that runs applyTx server-side without --- transferring the ledger state. The replacement should have the same type --- signature as a normal local state query. queryValidateTx :: forall era block point r . IsEra era @@ -64,73 +39,9 @@ queryValidateTx IO (Either QueryValidateTxError (Either (ApplyTxError (LedgerEra era)) ())) queryValidateTx (SignedTx ledgerTx) = obtainCommonConstraints (useEra @era) $ do - let sbe = convert (useEra @era) - eGenParams <- queryGenesisParameters sbe - eSerEpochState <- queryCurrentEpochState sbe - eEraHistory <- queryEraHistory - eChainPoint <- queryChainPoint - -- QueryCurrentEpochState uses DebugEpochState (QFNoTables), so the - -- returned epoch state has empty UTxO tables. We query the relevant - -- UTxOs separately and inject them before running applyTx. - let relevantTxIns = - Set.map - fromShelleyTxIn - (ledgerTx ^. bodyTxL . allInputsTxBodyF) - eUtxo <- queryUtxo sbe (QueryUTxOByTxIn relevantTxIns) - return $ do - genParams <- - first QueryValidateTxUnsupportedNtcVersion eGenParams - >>= first QueryValidateTxEraMismatch - serEpochState <- - first QueryValidateTxUnsupportedNtcVersion eSerEpochState - >>= first QueryValidateTxEraMismatch - eraHistory <- first QueryValidateTxUnsupportedNtcVersion eEraHistory - chainPoint <- first QueryValidateTxUnsupportedNtcVersion eChainPoint - utxo <- - first QueryValidateTxUnsupportedNtcVersion eUtxo - >>= first QueryValidateTxEraMismatch - epochState <- - first QueryValidateTxEpochStateDecodeError $ - decodeCurrentEpochState sbe serEpochState - let CurrentEpochState es = epochState - LedgerEpochInfo epochInfo = toLedgerEpochInfo eraHistory - globals = mkShelleyGlobals (toShelleyGenesis genParams) epochInfo - slotNo = chainPointToSlotNo chainPoint - Right $ - shelleyBasedEraConstraints sbe $ - let esWithUtxo = set utxoL (toLedgerUTxO sbe utxo) es - in void $ applyTx globals (mkMempoolEnv @era esWithUtxo slotNo) (esLState esWithUtxo) ledgerTx - -chainPointToSlotNo :: ChainPoint -> SlotNo -chainPointToSlotNo ChainPointAtGenesis = SlotNo 0 -chainPointToSlotNo (ChainPoint slotNo _) = slotNo - -mkMempoolEnv - :: forall era. IsEra era => EpochState (LedgerEra era) -> SlotNo -> LedgerEnv (LedgerEra era) -mkMempoolEnv epochState slotNo = - obtainCommonConstraints (useEra @era) $ - LedgerEnv - { ledgerSlotNo = slotNo - , ledgerEpochNo = Nothing - , ledgerIx = minBound - , ledgerPp = epochState ^. curPParamsEpochStateL - , ledgerAccount = esChainAccountState epochState - } - -toShelleyGenesis :: GenesisParameters ShelleyEra -> ShelleyGenesis -toShelleyGenesis gp = - shelleyGenesisDefaults - { sgSystemStart = protocolParamSystemStart gp - , sgNetworkMagic = let NetworkMagic m = toNetworkMagic (protocolParamNetworkId gp) in m - , sgNetworkId = toShelleyNetwork (protocolParamNetworkId gp) - , sgActiveSlotsCoeff = case boundRational (protocolParamActiveSlotsCoefficient gp) of - Nothing -> error "toShelleyGenesis: invalid activeSlotsCoefficient" - Just r -> r - , sgSecurityParam = protocolParamSecurity gp - , sgEpochLength = protocolParamEpochLength gp - , sgSlotsPerKESPeriod = fromIntegral (protocolParamSlotsPerKESPeriod gp) - , sgMaxKESEvolutions = fromIntegral (protocolParamMaxKESEvolutions gp) - , sgUpdateQuorum = fromIntegral (protocolParamUpdateQuorum gp) - , sgMaxLovelaceSupply = fromIntegral (unCoin (protocolParamMaxLovelaceSupply gp)) - , sgProtocolParams = protocolInitialUpdateableProtocolParameters gp - } + let tx = ShelleyTx (convert (useEra @era)) ledgerTx + result <- querySbe (useEra @era) (QueryValidateTx tx) + return $ case result of + Left err -> Left (QueryValidateTxUnsupportedNtcVersion err) + Right (Left mismatch) -> Left (QueryValidateTxEraMismatch mismatch) + Right (Right r) -> Right r diff --git a/cardano-api/src/Cardano/Api/Query/Internal/Expr.hs b/cardano-api/src/Cardano/Api/Query/Internal/Expr.hs index 53cdf55d44..2e4a778e26 100644 --- a/cardano-api/src/Cardano/Api/Query/Internal/Expr.hs +++ b/cardano-api/src/Cardano/Api/Query/Internal/Expr.hs @@ -43,6 +43,7 @@ module Cardano.Api.Query.Internal.Expr , queryStakePoolDefaultVote , queryLedgerConfig , queryDRepDelegations + , querySbe ) where diff --git a/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs b/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs index e467998d74..4efce94e8f 100644 --- a/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs +++ b/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs @@ -87,6 +87,7 @@ import Cardano.Api.Serialise.TextEnvelope.Internal , TextEnvelopeType ) import Cardano.Api.Tx.Internal.Body +import Cardano.Api.Tx.Internal.Sign (Tx (..)) import Cardano.Api.UTxO (UTxO (..)) import Cardano.Binary qualified as CBOR @@ -342,6 +343,9 @@ data QueryInShelleyBasedEra era result where GetDRepDelegations :: Set Ledger.DRep -> QueryInShelleyBasedEra era (Map Ledger.DRep (Set (Ledger.Credential Ledger.Staking))) + QueryValidateTx + :: Tx era + -> QueryInShelleyBasedEra era (Either (Ledger.ApplyTxError (ShelleyLedgerEra era)) ()) deriving instance Show (QueryInShelleyBasedEra era result) @@ -576,7 +580,7 @@ toConsensusQueryShelleyBased . HasCallStack => ConsensusBlockForEra era ~ Consensus.ShelleyBlock protocol (ShelleyLedgerEra era) => Consensus.CardanoBlock StandardCrypto ~ block - => L.EraGov (ShelleyLedgerEra era) + => Consensus.ShelleyCompatible protocol (ShelleyLedgerEra era) => ShelleyBasedEra era -> QueryInShelleyBasedEra era result -> Some (Consensus.Query block) @@ -746,6 +750,8 @@ toConsensusQueryShelleyBased sbe = \case (consensusQueryInEraInMode era (Consensus.GetDRepDelegations dreps)) ) sbe + QueryValidateTx (ShelleyTx _ tx) -> + Some (consensusQueryInEraInMode era (Consensus.ValidateTx (Consensus.mkShelleyTx tx))) where era = toCardanoEra sbe @@ -1075,6 +1081,11 @@ fromConsensusQueryResultShelleyBased sbe sbeQuery q' r' = Consensus.GetDRepDelegations{} -> r' _ -> fromConsensusQueryResultMismatch + QueryValidateTx{} -> + case q' of + Consensus.ValidateTx{} -> + r' + _ -> fromConsensusQueryResultMismatch -- | This should /only/ happen if we messed up the mapping in 'toConsensusQuery' -- and 'fromConsensusQueryResult' so they are inconsistent with each other. diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Cip129.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Cip129.hs index 2fded15406..9a9f61d22f 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Cip129.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Cip129.hs @@ -11,7 +11,6 @@ import Cardano.Api import Cardano.Api.Ledger qualified as L import Cardano.Ledger.Api.Governance qualified as Gov -import Cardano.Ledger.Core qualified as L import Data.Text qualified as T import GHC.Stack