Implement ValidateTx query for LocalStateQuery protocol

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

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

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/QueryHF.hs

@@ -23,16 +23,20 @@ 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 ()
 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

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

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
   )
@@ -82,9 +83,14 @@ 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.Util.IOLike (MonadSTM (atomically))
 import Ouroboros.Consensus.Shelley.Ledger.Ledger
 import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion
   ( ShelleyNodeToClientVersion (..)
@@ -376,6 +382,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)
+      QFLookupTables
+      (Either (SL.ApplyTxError era) ())
 
 {-# DEPRECATED GetLedgerPeerSnapshot' "Use GetLedgerPeerSnapshot instead" #-}
 
@@ -543,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
 
@@ -590,6 +605,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 +617,7 @@ instance
     v12 = ShelleyNodeToClientVersion12
     v13 = ShelleyNodeToClientVersion13
     v15 = ShelleyNodeToClientVersion15
+    v16 = ShelleyNodeToClientVersion16
 
 instance SameDepIndex2 (BlockQuery (ShelleyBlock proto era)) where
   sameDepIndex2 GetLedgerTip GetLedgerTip =
@@ -767,9 +784,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 +832,7 @@ instance ShelleyCompatible proto era => ShowQuery (BlockQuery (ShelleyBlock prot
     GetStakeDistribution2{} -> show
     GetMaxMajorProtocolVersion{} -> show
     GetDRepDelegations{} -> show
+    ValidateTx{} -> show
 
 {-------------------------------------------------------------------------------
   Auxiliary
@@ -852,7 +872,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 +966,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 +1051,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 +1102,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 +1152,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.
@@ -1171,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)
@@ -1206,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') =>

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