From 0c6f5de609b5aefbfe6869368ad6d940bbcd911c Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Wed, 27 May 2026 03:57:42 +0200 Subject: [PATCH 1/3] Add SRP for `ouroboros-network` --- cabal.project | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/cabal.project b/cabal.project index a7e5372fa2..981eed6216 100644 --- a/cabal.project +++ b/cabal.project @@ -22,6 +22,31 @@ 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-network.git + tag: 65da1ad619473f9467d3336a6d6e9a2a8714913d + subdir: ouroboros-network + --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: . -- We want to always build the test-suites and benchmarks From 5618b748a92131c361aa36deca65a654f9d3185a Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Wed, 27 May 2026 04:13:07 +0200 Subject: [PATCH 2/3] Implement `ValidateTx` query for `LocalStateQuery` protocol Adds a new BlockQuery constructor `ValidateTx` that validates a transaction against the current ledger state without submitting it. Gated behind ShelleyNodeToClientVersion16 / NodeToClientV_24. --- .../Ouroboros/Consensus/Cardano/Node.hs | 19 ++++++++- .../Shelley/Ledger/NetworkProtocolVersion.hs | 3 ++ .../Consensus/Shelley/Ledger/Query.hs | 41 +++++++++++++++++-- .../Consensus/Shelley/Node/Serialisation.hs | 6 ++- .../Consensus/Ledger/Query/Version.hs | 1 + 5 files changed, 63 insertions(+), 7 deletions(-) diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index 3c73a2256a..9902c2194d 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs @@ -45,6 +45,7 @@ module Ouroboros.Consensus.Cardano.Node , pattern CardanoNodeToClientVersion17 , pattern CardanoNodeToClientVersion18 , pattern CardanoNodeToClientVersion19 + , pattern CardanoNodeToClientVersion20 , pattern CardanoNodeToNodeVersion1 , pattern CardanoNodeToNodeVersion2 ) where @@ -438,6 +439,21 @@ pattern CardanoNodeToClientVersion19 = :* Nil ) +pattern CardanoNodeToClientVersion20 :: BlockNodeToClientVersion (CardanoBlock c) +pattern CardanoNodeToClientVersion20 = + HardForkNodeToClientEnabled + HardForkSpecificNodeToClientVersion3 + ( EraNodeToClientEnabled ByronNodeToClientVersion1 + :* EraNodeToClientEnabled ShelleyNodeToClientVersion16 + :* EraNodeToClientEnabled ShelleyNodeToClientVersion16 + :* EraNodeToClientEnabled ShelleyNodeToClientVersion16 + :* EraNodeToClientEnabled ShelleyNodeToClientVersion16 + :* EraNodeToClientEnabled ShelleyNodeToClientVersion16 + :* EraNodeToClientEnabled ShelleyNodeToClientVersion16 + :* EraNodeToClientEnabled ShelleyNodeToClientVersion16 + :* Nil + ) + instance CardanoHardForkConstraints c => SupportedNetworkProtocolVersion (CardanoBlock c) @@ -458,9 +474,10 @@ instance , (NodeToClientV_21, CardanoNodeToClientVersion17) , (NodeToClientV_22, CardanoNodeToClientVersion18) , (NodeToClientV_23, CardanoNodeToClientVersion19) + , (NodeToClientV_24, CardanoNodeToClientVersion20) ] - latestReleasedNodeVersion _prx = (Just NodeToNodeV_15, Just NodeToClientV_23) + latestReleasedNodeVersion _prx = (Just NodeToNodeV_15, Just NodeToClientV_24) {------------------------------------------------------------------------------- ProtocolInfo diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs index b91495f334..18c42686ce 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs @@ -36,6 +36,8 @@ data ShelleyNodeToClientVersion | -- | Support retrieving all ledger peers by GetLedgerPeerSnapshot -- New queries introduced: QueryDRepDelegations ShelleyNodeToClientVersion15 + | -- | New queries introduced: ValidateTx + ShelleyNodeToClientVersion16 deriving (Show, Eq, Ord, Enum, Bounded) ledgerPeerSnapshotSupportsSRV :: ShelleyNodeToClientVersion -> LedgerPeerSnapshotSRVSupport @@ -64,6 +66,7 @@ instance SupportedNetworkProtocolVersion (ShelleyBlock proto era) where , (NodeToClientV_21, ShelleyNodeToClientVersion13) , (NodeToClientV_22, ShelleyNodeToClientVersion14) , (NodeToClientV_23, ShelleyNodeToClientVersion15) + , (NodeToClientV_24, ShelleyNodeToClientVersion16) ] latestReleasedNodeVersion = latestReleasedNodeVersionDefault diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs index 177d3bd1e7..f39d45632e 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs @@ -82,9 +82,13 @@ import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) import Ouroboros.Consensus.Protocol.Praos.Common +import Control.Monad.Except (runExcept) +import Ouroboros.Consensus.Ledger.SupportsMempool (WhetherToIntervene (..)) import qualified Ouroboros.Consensus.Shelley.Eras as SE +import Ouroboros.Consensus.Shelley.Eras (applyShelleyBasedTx) import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Config +import Ouroboros.Consensus.Shelley.Ledger.Mempool (GenTx (ShelleyTx)) import Ouroboros.Consensus.Shelley.Ledger.Ledger import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion ( ShelleyNodeToClientVersion (..) @@ -376,6 +380,12 @@ data instance BlockQuery (ShelleyBlock proto era) fp result where (ShelleyBlock proto era) QFNoTables (Map SL.DRep (Set (SL.Credential SL.Staking))) + ValidateTx :: + GenTx (ShelleyBlock proto era) -> + BlockQuery + (ShelleyBlock proto era) + QFNoTables + (Either (SL.ApplyTxError era) ()) {-# DEPRECATED GetLedgerPeerSnapshot' "Use GetLedgerPeerSnapshot instead" #-} @@ -529,6 +539,19 @@ instance $ cfg GetDRepDelegations dreps -> SL.queryDRepDelegations st dreps + ValidateTx (ShelleyTx _ tx) -> + let tipSlot = case shelleyLedgerTip lst of + Origin -> SlotNo 0 + NotOrigin tip -> shelleyTipSlotNo tip + in case runExcept $ + applyShelleyBasedTx + globals + (SL.mkMempoolEnv st tipSlot) + (SL.mkMempoolState st) + DoNotIntervene + tx of + Left err -> Left err + Right _ -> Right () where lcfg = configLedger $ getExtLedgerCfg cfg globals = shelleyLedgerGlobals lcfg @@ -590,6 +613,7 @@ instance GetStakeDistribution2{} -> (>= v13) GetMaxMajorProtocolVersion -> (>= v13) GetDRepDelegations{} -> (>= v15) + ValidateTx{} -> (>= v16) where -- WARNING: when adding a new query, a new @ShelleyNodeToClientVersionX@ -- must be added. See #2830 for a template on how to do this. @@ -601,6 +625,7 @@ instance v12 = ShelleyNodeToClientVersion12 v13 = ShelleyNodeToClientVersion13 v15 = ShelleyNodeToClientVersion15 + v16 = ShelleyNodeToClientVersion16 instance SameDepIndex2 (BlockQuery (ShelleyBlock proto era)) where sameDepIndex2 GetLedgerTip GetLedgerTip = @@ -767,9 +792,11 @@ instance SameDepIndex2 (BlockQuery (ShelleyBlock proto era)) where | otherwise = Nothing sameDepIndex2 GetDRepDelegations{} _ = Nothing + sameDepIndex2 ValidateTx{} ValidateTx{} = Just Refl + sameDepIndex2 ValidateTx{} _ = Nothing -deriving instance Eq (BlockQuery (ShelleyBlock proto era) fp result) -deriving instance Show (BlockQuery (ShelleyBlock proto era) fp result) +deriving instance ShelleyBasedEra era => Eq (BlockQuery (ShelleyBlock proto era) fp result) +deriving instance ShelleyBasedEra era => Show (BlockQuery (ShelleyBlock proto era) fp result) instance ShelleyCompatible proto era => ShowQuery (BlockQuery (ShelleyBlock proto era) fp) where showResult = \case @@ -813,6 +840,7 @@ instance ShelleyCompatible proto era => ShowQuery (BlockQuery (ShelleyBlock prot GetStakeDistribution2{} -> show GetMaxMajorProtocolVersion{} -> show GetDRepDelegations{} -> show + ValidateTx{} -> show {------------------------------------------------------------------------------- Auxiliary @@ -852,7 +880,7 @@ getFilteredVoteDelegatees ss creds encodeShelleyQuery :: forall era proto fp result. - ShelleyBasedEra era => + ShelleyCompatible proto era => BlockQuery (ShelleyBlock proto era) fp result -> Encoding encodeShelleyQuery query = case query of GetLedgerTip -> @@ -946,10 +974,12 @@ encodeShelleyQuery query = case query of CBOR.encodeListLen 1 <> CBOR.encodeWord8 38 GetDRepDelegations dreps -> CBOR.encodeListLen 2 <> CBOR.encodeWord8 39 <> LC.toEraCBOR @era dreps + ValidateTx tx -> + CBOR.encodeListLen 2 <> CBOR.encodeWord8 40 <> toCBOR tx decodeShelleyQuery :: forall era proto. - ShelleyBasedEra era => + ShelleyCompatible proto era => forall s. Decoder s (SomeBlockQuery (BlockQuery (ShelleyBlock proto era))) decodeShelleyQuery = do @@ -1029,6 +1059,7 @@ decodeShelleyQuery = do (1, 37) -> return $ SomeBlockQuery GetStakeDistribution2 (1, 38) -> return $ SomeBlockQuery GetMaxMajorProtocolVersion (2, 39) -> requireCG $ SomeBlockQuery . GetDRepDelegations <$> LC.fromEraCBOR @era + (2, 40) -> SomeBlockQuery . ValidateTx <$> fromCBOR _ -> failmsg "invalid" encodeShelleyResult :: @@ -1079,6 +1110,7 @@ encodeShelleyResult v query = case query of GetStakeDistribution2{} -> LC.toEraCBOR @era GetMaxMajorProtocolVersion -> toCBOR GetDRepDelegations{} -> LC.toEraCBOR @era + ValidateTx{} -> LC.toEraCBOR @era decodeShelleyResult :: forall proto era fp result. @@ -1128,6 +1160,7 @@ decodeShelleyResult v query = case query of GetStakeDistribution2 -> LC.fromEraCBOR @era GetMaxMajorProtocolVersion -> fromCBOR GetDRepDelegations{} -> LC.fromEraCBOR @era + ValidateTx{} -> LC.fromEraCBOR @era currentPParamsEnDecoding :: forall era s. diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs index 714ee97594..3ac1ceefe0 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -200,10 +201,11 @@ data ShelleyEncoderException era proto ShelleyEncoderUnsupportedQuery (SomeBlockQuery (BlockQuery (ShelleyBlock proto era))) ShelleyNodeToClientVersion - deriving Show + +deriving instance ShelleyBasedEra era => Show (ShelleyEncoderException era proto) instance - (Typeable era, Typeable proto) => + (ShelleyBasedEra era, Typeable era, Typeable proto) => Exception (ShelleyEncoderException era proto) instance diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query/Version.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query/Version.hs index 87de8a4387..d272acf0c8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query/Version.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query/Version.hs @@ -29,3 +29,4 @@ nodeToClientVersionToQueryVersion x = case x of NodeToClientV_21 -> QueryVersion3 NodeToClientV_22 -> QueryVersion3 NodeToClientV_23 -> QueryVersion3 + NodeToClientV_24 -> QueryVersion3 From bca18fd361d8342bdbfb8a08366e86479677ce30 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Wed, 27 May 2026 12:03:44 +0200 Subject: [PATCH 3/3] Fix for state querying in tx validation query --- .../Ouroboros/Consensus/Cardano/QueryHF.hs | 30 ++++++++++- .../Consensus/Shelley/Ledger/Query.hs | 54 +++++++++++++------ .../Ouroboros/Consensus/Shelley/ShelleyHFC.hs | 11 +++- .../ThreadNet/Infra/ShelleyBasedHardFork.hs | 30 ++++++++++- .../HardFork/Combinator/Ledger/Query.hs | 2 +- 5 files changed, 105 insertions(+), 22 deletions(-) diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/QueryHF.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/QueryHF.hs index cc1a248470..a33018e423 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/QueryHF.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/QueryHF.hs @@ -23,9 +23,12 @@ import Data.Coerce import Data.Functor.Product import Data.SOP.BasicFunctors import Data.SOP.Constraint +import Data.SOP.Functors (Flip (..)) import Data.SOP.Index import Data.SOP.Strict +import qualified Data.SOP.Telescope as Telescope import Data.Singletons +import Data.Type.Equality ((:~:) (..)) import NoThunks.Class import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Byron.Node () @@ -33,6 +36,7 @@ import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.CanHardFork import Ouroboros.Consensus.Cardano.Ledger import Ouroboros.Consensus.HardFork.Combinator +import Ouroboros.Consensus.HardFork.Combinator.State.Types (currentState) import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.Tables @@ -42,6 +46,7 @@ import Ouroboros.Consensus.Shelley.Node () import Ouroboros.Consensus.Shelley.Protocol.Praos () import Ouroboros.Consensus.Storage.LedgerDB import Ouroboros.Consensus.TypeFamilyWrappers +import Ouroboros.Consensus.Util.IOLike (MonadSTM (atomically)) -- | Just to have the @x@ as the last type variable newtype FlipBlockQuery footprint result x @@ -95,11 +100,13 @@ shelleyCardanoFilter q = eliminateCardanoTxOut (\_ -> shelleyQFTraverseTablesPre instance CardanoHardForkConstraints c => BlockSupportsHFLedgerQuery (CardanoEras c) where answerBlockQueryHFLookup = answerCardanoQueryHF - ( \idx -> + ( \idx cfg q forker -> answerShelleyLookupQueries (injectLedgerTables idx) (ejectHardForkTxOut idx) (coerce . ejectCanonicalTxIn idx) + (getPerEraShelleyLedgerState idx forker) + cfg q forker ) answerBlockQueryHFTraverse = answerCardanoQueryHF @@ -128,3 +135,24 @@ byronCardanoFilter :: TxOut (LedgerState (HardForkBlock (CardanoEras c))) -> Bool byronCardanoFilter = \case {} + +getPerEraShelleyLedgerState :: + forall blk xs m. + (MonadSTM m, All SingleEraBlock xs) => + Index xs blk -> + ReadOnlyForker' m (HardForkBlock xs) -> + m (LedgerState blk EmptyMK) +getPerEraShelleyLedgerState idx forker = do + ext <- atomically (roforkerGetLedgerState forker) + let tipNS = Telescope.tip $ getHardForkState $ hardForkLedgerStatePerEra $ ledgerState ext + pure $ case projectNS idx tipNS of + Just cur -> unFlip (currentState cur) + Nothing -> error "getPerEraShelleyLedgerState: era mismatch" + +projectNS :: Index xs x -> NS f xs -> Maybe (f x) +projectNS idx ns = go (getIndex idx) ns + where + go :: NS ((:~:) x) ys -> NS f ys -> Maybe (f x) + go (Z Refl) (Z fx) = Just fx + go (S i) (S s) = go i s + go _ _ = Nothing diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs index f39d45632e..4b6681e0ea 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs @@ -49,6 +49,7 @@ import qualified Cardano.Ledger.Core as SL import Cardano.Ledger.Keys (KeyHash) import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.Core as LC +import qualified Cardano.Ledger.Shelley.LedgerState as SL import qualified Cardano.Ledger.Shelley.RewardProvenance as SL ( RewardProvenance ) @@ -89,6 +90,7 @@ import Ouroboros.Consensus.Shelley.Eras (applyShelleyBasedTx) import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Config import Ouroboros.Consensus.Shelley.Ledger.Mempool (GenTx (ShelleyTx)) +import Ouroboros.Consensus.Util.IOLike (MonadSTM (atomically)) import Ouroboros.Consensus.Shelley.Ledger.Ledger import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion ( ShelleyNodeToClientVersion (..) @@ -384,7 +386,7 @@ data instance BlockQuery (ShelleyBlock proto era) fp result where GenTx (ShelleyBlock proto era) -> BlockQuery (ShelleyBlock proto era) - QFNoTables + QFLookupTables (Either (SL.ApplyTxError era) ()) {-# DEPRECATED GetLedgerPeerSnapshot' "Use GetLedgerPeerSnapshot instead" #-} @@ -539,19 +541,6 @@ instance $ cfg GetDRepDelegations dreps -> SL.queryDRepDelegations st dreps - ValidateTx (ShelleyTx _ tx) -> - let tipSlot = case shelleyLedgerTip lst of - Origin -> SlotNo 0 - NotOrigin tip -> shelleyTipSlotNo tip - in case runExcept $ - applyShelleyBasedTx - globals - (SL.mkMempoolEnv st tipSlot) - (SL.mkMempoolState st) - DoNotIntervene - tx of - Left err -> Left err - Right _ -> Right () where lcfg = configLedger $ getExtLedgerCfg cfg globals = shelleyLedgerGlobals lcfg @@ -566,7 +555,10 @@ instance hst = headerState ext st = shelleyLedgerState lst - answerBlockQueryLookup = answerShelleyLookupQueries id id coerce + answerBlockQueryLookup cfg q forker = + answerShelleyLookupQueries id id coerce + (ledgerState <$> atomically (LedgerDB.roforkerGetLedgerState forker)) + cfg q forker answerBlockQueryTraverse = answerShelleyTraversingQueries id coerce shelleyQFTraverseTablesPredicate @@ -1204,22 +1196,29 @@ answerShelleyLookupQueries :: (TxOut (LedgerState blk) -> LC.TxOut era) -> -- | Eject TxIn (TxIn (LedgerState blk) -> SL.TxIn) -> + -- | Get the Shelley ledger state (only called for ValidateTx) + m (LedgerState (ShelleyBlock proto era) EmptyMK) -> ExtLedgerCfg (ShelleyBlock proto era) -> BlockQuery (ShelleyBlock proto era) QFLookupTables result -> ReadOnlyForker' m blk -> m result -answerShelleyLookupQueries injTables ejTxOut ejTxIn cfg q forker = +answerShelleyLookupQueries injTables ejTxOut ejTxIn getShelleyLedgerSt cfg q forker = case q of GetUTxOByTxIn txins -> answerGetUtxOByTxIn txins + ValidateTx (ShelleyTx _ tx) -> + answerValidateTx tx GetCBOR q' -> -- We encode using the latest (@maxBound@) ShelleyNodeToClientVersion, -- as the @GetCBOR@ query already is about opportunistically assuming -- both client and server are running the same version; cf. the -- @GetCBOR@ Haddocks. mkSerialised (encodeShelleyResult maxBound q') - <$> answerShelleyLookupQueries injTables ejTxOut ejTxIn cfg q' forker + <$> answerShelleyLookupQueries injTables ejTxOut ejTxIn getShelleyLedgerSt cfg q' forker where + lcfg = configLedger $ getExtLedgerCfg cfg + globals = shelleyLedgerGlobals lcfg + answerGetUtxOByTxIn :: Set.Set SL.TxIn -> m (SL.UTxO era) @@ -1239,6 +1238,27 @@ answerShelleyLookupQueries injTables ejTxOut ejTxIn cfg q forker = ) values + answerValidateTx :: + SL.Tx SL.TopTx era -> + m (Either (SL.ApplyTxError era) ()) + answerValidateTx tx = do + shelleyLedgerSt <- getShelleyLedgerSt + let st = shelleyLedgerState shelleyLedgerSt + tipSlot = case shelleyLedgerTip shelleyLedgerSt of + Origin -> SlotNo 0 + NotOrigin tip -> shelleyTipSlotNo tip + utxo <- answerGetUtxOByTxIn (tx ^. SL.bodyTxL . SL.allInputsTxBodyF) + let stWithUtxo = set (SL.nesEsL . SL.esLStateL . SL.lsUTxOStateL . SL.utxoL) utxo st + pure $ case runExcept $ + applyShelleyBasedTx + globals + (SL.mkMempoolEnv stWithUtxo tipSlot) + (SL.mkMempoolState stWithUtxo) + DoNotIntervene + tx of + Left err -> Left err + Right _ -> Right () + shelleyQFTraverseTablesPredicate :: forall proto era proto' era' result. (ShelleyBasedEra era, ShelleyBasedEra era') => diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs index 6f5410b0ac..76983469a9 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -77,6 +77,7 @@ import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.HardFork.History (Bound (boundSlot)) import Ouroboros.Consensus.HardFork.Simple import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.Extended (ledgerState) import Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits) import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol @@ -92,7 +93,9 @@ import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Ledger.Inspect as Shelley.Inspect import Ouroboros.Consensus.Shelley.Node () import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto) +import Ouroboros.Consensus.Storage.LedgerDB (roforkerGetLedgerState) import Ouroboros.Consensus.TypeFamilyWrappers +import Ouroboros.Consensus.Util.IOLike (MonadSTM (atomically)) import Ouroboros.Consensus.Util.IndexedMemPack {------------------------------------------------------------------------------- @@ -466,7 +469,13 @@ instance BlockSupportsHFLedgerQuery '[ShelleyBlock proto era] where answerBlockQueryHFLookup = \case - IZ -> answerShelleyLookupQueries (injectLedgerTables IZ) id (coerce . ejectCanonicalTxIn IZ) + IZ -> \cfg q forker -> + let getShelleyLedgerSt = do + ext <- atomically (roforkerGetLedgerState forker) + pure $ unFlip $ currentState $ Telescope.fromTZ $ + getHardForkState $ hardForkLedgerStatePerEra $ ledgerState ext + in answerShelleyLookupQueries (injectLedgerTables IZ) id (coerce . ejectCanonicalTxIn IZ) + getShelleyLedgerSt cfg q forker IS idx -> case idx of {} answerBlockQueryHFTraverse = \case diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs index 2ec5bf8a54..bdddb37ca4 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs @@ -60,9 +60,11 @@ import qualified Data.Map.Strict as Map import Data.MemPack import Data.Proxy import Data.SOP.BasicFunctors +import Data.SOP.Constraint (All) import Data.SOP.Functors (Flip (..)) import qualified Data.SOP.InPairs as InPairs -import Data.SOP.Index (Index (..), hcimap) +import Data.SOP.Index (Index (..), getIndex, hcimap) +import Data.Type.Equality ((:~:) (..)) import Data.SOP.Strict import qualified Data.SOP.Tails as Tails import qualified Data.SOP.Telescope as Telescope @@ -101,6 +103,7 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto) import Ouroboros.Consensus.Storage.LedgerDB import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (eitherToMaybe) +import Ouroboros.Consensus.Util.IOLike (MonadSTM (atomically)) import Ouroboros.Consensus.Util.IndexedMemPack import Test.ThreadNet.TxGen import Test.ThreadNet.TxGen.Shelley () @@ -360,11 +363,13 @@ instance where answerBlockQueryHFLookup = answerShelleyBasedQueryHF - ( \idx -> + ( \idx cfg q forker -> answerShelleyLookupQueries (injectLedgerTables idx) (ejectHardForkTxOutDefault idx) (coerce . ejectCanonicalTxIn idx) + (getPerEraShelleyLedgerState idx forker) + cfg q forker ) answerBlockQueryHFTraverse = @@ -384,6 +389,27 @@ instance S (Z (WrapTxOut x)) -> shelleyQFTraverseTablesPredicate q x queryLedgerGetTraversingFilter (IS (IS idx)) _q = case idx of {} +getPerEraShelleyLedgerState :: + forall blk xs m. + (MonadSTM m, All SingleEraBlock xs) => + Index xs blk -> + ReadOnlyForker' m (HardForkBlock xs) -> + m (LedgerState blk EmptyMK) +getPerEraShelleyLedgerState idx forker = do + ext <- atomically (roforkerGetLedgerState forker) + let tipNS = Telescope.tip $ getHardForkState $ hardForkLedgerStatePerEra $ ledgerState ext + pure $ case projectNS idx tipNS of + Just cur -> unFlip (HFC.currentState cur) + Nothing -> error "getPerEraShelleyLedgerState: era mismatch" + +projectNS :: Index xs x -> NS f xs -> Maybe (f x) +projectNS idx = go (getIndex idx) + where + go :: NS ((:~:) x) ys -> NS f ys -> Maybe (f x) + go (Z Refl) (Z fx) = Just fx + go (S i) (S s) = go i s + go _ _ = Nothing + {------------------------------------------------------------------------------- Protocol info -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs index a240228bbd..8eb7e20774 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs @@ -131,7 +131,7 @@ class where answerBlockQueryHFLookup :: All SingleEraBlock xs => - Monad m => + MonadSTM m => Index xs x -> ExtLedgerCfg x -> BlockQuery x QFLookupTables result ->