Implement server-side transaction validation via LocalStateQuery

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

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

cardano-api/src/Cardano/Api/Experimental.hs

@@ -40,6 +40,7 @@ module Cardano.Api.Experimental
   , Era (..)
   , IsEra (..)
   , Some (..)
+  , InAnyEra (..)
   , LedgerEra
   , DeprecatedEra (..)
   , eraToSbe
@@ -95,6 +96,11 @@ module Cardano.Api.Experimental
   , makeDrepUpdateCertificate
   , makeStakeAddressAndDRepDelegationCertificate
 
+    -- ** Validation
+  , TxValidationResult (..)
+  , QueryValidateTxError (..)
+  , validateTx
+
     -- * Data family instances
   , AsType (..)
 

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.
 --

cardano-api/src/Cardano/Api/Experimental/Tx.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -205,6 +205,11 @@ module Cardano.Api.Experimental.Tx
   , TxBodyErrorAutoBalance (..)
   , TxFeeEstimationError (..)
 
+    -- * Validation
+  , TxValidationResult (..)
+  , QueryValidateTxError (..)
+  , validateTx
+
     -- ** Internal functions
   , extractExecutionUnits
   , getTxScriptWitnessRequirements
@@ -225,28 +230,36 @@ 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.HasTypeProxy (HasTypeProxy (..), Proxy, asType)
+import Cardano.Api.Experimental.Tx.Internal.Validate (QueryValidateTxError (..), queryValidateTx)
 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.Serialise.Raw
-  ( SerialiseAsRawBytes (..)
-  , SerialiseAsRawBytesError (SerialiseAsRawBytesError)
+import Cardano.Api.Query.Internal.Expr
+  ( queryEraHistory
+  , queryProtocolParameters
+  , querySystemStart
+  , queryUtxo
+  )
+import Cardano.Api.Query.Internal.Type.QueryInMode
+  ( QueryInMode
+  , QueryUTxOFilter (..)
+  , toLedgerEpochInfo
+  , toLedgerUTxO
   )
 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.Tx qualified as L
 import Cardano.Ledger.Api qualified as L
-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 Control.Exception (displayException)
-import Data.Bifunctor (bimap)
-import Data.ByteString.Lazy (fromStrict)
+import Data.Bifunctor (bimap, first)
+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
@@ -279,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]
@@ -380,3 +360,90 @@ purposeAsIxItemToAsIx
   -> L.PlutusPurpose L.AsIx (LedgerEra era)
 purposeAsIxItemToAsIx purpose =
   obtainCommonConstraints (useEra @era) $ L.hoistPlutusPurpose L.toAsIx purpose
+
+data TxValidationResult era = TxValidationResult
+  { phase1Result :: Either (ApplyTxError (LedgerEra era)) ()
+  , phase2Result
+      :: Map
+           Api.ScriptWitnessIndex
+           (Either ScriptExecutionError (EvalTxExecutionUnitsLog, Api.ExecutionUnits))
+  }
+
+deriving instance Show (ApplyTxError (LedgerEra era)) => Show (TxValidationResult era)
+
+validateTx
+  :: forall era block point r
+   . IsEra era
+  => SignedTx era
+  -> LocalStateQueryExpr
+       block
+       point
+       QueryInMode
+       r
+       IO
+       (Either QueryValidateTxError (TxValidationResult era))
+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
+  :: Era era
+  -> Either (ApplyTxError (LedgerEra era)) ()
+  -> Either (ApplyTxError (LedgerEra era)) ()
+filterScriptFailures era = \case
+  Right () -> Right ()
+  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
+       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)

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)

cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Validate.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Cardano.Api.Experimental.Tx.Internal.Validate
+  ( queryValidateTx
+  , QueryValidateTxError (..)
+  )
+where
+
+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.Network.IPC (LocalStateQueryExpr)
+import Cardano.Api.Network.IPC.Internal.Version (UnsupportedNtcVersionError)
+import Cardano.Api.Query.Internal.Expr
+import Cardano.Api.Query.Internal.Type.QueryInMode
+import Cardano.Api.Tx.Internal.Sign (Tx (..))
+
+import Cardano.Ledger.Shelley.API (ApplyTxError)
+import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch)
+
+data QueryValidateTxError
+  = QueryValidateTxUnsupportedNtcVersion UnsupportedNtcVersionError
+  | QueryValidateTxEraMismatch EraMismatch
+  deriving Show
+
+queryValidateTx
+  :: forall era block point r
+   . IsEra era
+  => SignedTx era
+  -> LocalStateQueryExpr
+       block
+       point
+       QueryInMode
+       r
+       IO
+       (Either QueryValidateTxError (Either (ApplyTxError (LedgerEra era)) ()))
+queryValidateTx (SignedTx ledgerTx) = obtainCommonConstraints (useEra @era) $ do
+  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