Rewrite mempool API in light of Tx/TxInBlock.

Previously, we used the Tx/TxInBlock distinction to also embody the fact
that a Tx had been validated, and hence future applications of that Tx
could skip a certain number of checks, an important performance concern.

Now we lack this distinction (which in any case was somewhat a
conflation of concerns), so we introduce the `Validated` newtype to
reflect this, and rewrite the Mempool API to reflect this.

alonzo/impl/src/Cardano/Ledger/Alonzo.hs

@@ -32,10 +32,9 @@ import Cardano.Ledger.Alonzo.PParams
   )
 import qualified Cardano.Ledger.Alonzo.Rules.Bbody as Alonzo (AlonzoBBODY)
 import qualified Cardano.Ledger.Alonzo.Rules.Ledger as Alonzo (AlonzoLEDGER)
-import Cardano.Ledger.Alonzo.Rules.Utxo (UtxoPredicateFailure (UtxosFailure), utxoEntrySize)
+import Cardano.Ledger.Alonzo.Rules.Utxo (utxoEntrySize)
 import qualified Cardano.Ledger.Alonzo.Rules.Utxo as Alonzo (AlonzoUTXO)
-import qualified Cardano.Ledger.Alonzo.Rules.Utxos as Alonzo (UTXOS, constructValidated, lbl2Phase)
-import Cardano.Ledger.Alonzo.Rules.Utxow (AlonzoPredFail (WrappedShelleyEraFailure))
+import qualified Cardano.Ledger.Alonzo.Rules.Utxos as Alonzo (UTXOS)
 import qualified Cardano.Ledger.Alonzo.Rules.Utxow as Alonzo (AlonzoUTXOW)
 import Cardano.Ledger.Alonzo.Scripts (Script (..), isPlutusScript)
 import Cardano.Ledger.Alonzo.Tx (ValidatedTx (..), minfee)
@@ -53,7 +52,6 @@ import Cardano.Ledger.Keys (GenDelegs (GenDelegs))
 import qualified Cardano.Ledger.Mary.Value as V (Value)
 import Cardano.Ledger.Rules.ValidationMode
   ( applySTSNonStatic,
-    applySTSValidateSuchThat,
   )
 import Cardano.Ledger.SafeHash (hashAnnotated)
 import Cardano.Ledger.Shelley (nativeMultiSigTag)
@@ -66,7 +64,7 @@ import Cardano.Ledger.ShelleyMA.Rules.Utxo (consumed)
 import Cardano.Ledger.ShelleyMA.Timelocks (validateTimelock)
 import Cardano.Ledger.Val (Val (inject), coin, (<->))
 import Control.Arrow (left)
-import Control.Monad.Except (liftEither, runExcept)
+import Control.Monad.Except (liftEither)
 import Control.Monad.Reader (runReader)
 import Control.State.Transition.Extended (TRC (TRC))
 import Data.Default (def)
@@ -84,17 +82,10 @@ import Shelley.Spec.Ledger.LedgerState
     LedgerState (..),
     NewEpochState (..),
     UTxOState (..),
-    _dstate,
     _genDelegs,
-    _pParams,
-    _pstate,
   )
 import Shelley.Spec.Ledger.Metadata (validMetadatum)
 import qualified Shelley.Spec.Ledger.STS.Epoch as Shelley
-import Shelley.Spec.Ledger.STS.Ledger
-  ( LedgerEnv (..),
-    LedgerPredicateFailure (UtxowFailure),
-  )
 import qualified Shelley.Spec.Ledger.STS.Mir as Shelley
 import qualified Shelley.Spec.Ledger.STS.Newpp as Shelley
 import qualified Shelley.Spec.Ledger.STS.Ocert as Shelley
@@ -103,7 +94,6 @@ import qualified Shelley.Spec.Ledger.STS.Rupd as Shelley
 import qualified Shelley.Spec.Ledger.STS.Snap as Shelley
 import qualified Shelley.Spec.Ledger.STS.Tick as Shelley
 import qualified Shelley.Spec.Ledger.STS.Upec as Shelley
-import Shelley.Spec.Ledger.STS.Utxow (UtxowPredicateFailure (UtxoFailure))
 import qualified Shelley.Spec.Ledger.Tx as Shelley
 import Shelley.Spec.Ledger.UTxO (balance)
 
@@ -121,45 +111,12 @@ instance
   type Crypto (AlonzoEra c) = c
 
 instance API.PraosCrypto c => API.ApplyTx (AlonzoEra c) where
-  applyTx globals env@(LedgerEnv slot _ix pp _accnt) st@(utxostate, dpstate) tx =
-    do
-      vtx <-
-        liftEither
-          . left
-            ( API.ApplyTxError
-                . fmap
-                  ( UtxowFailure
-                      . WrappedShelleyEraFailure
-                      . UtxoFailure
-                      . UtxosFailure
-                  )
-            )
-          . runExcept
-          $ Alonzo.constructValidated globals utxoenv utxostate tx
-      -- Note here that we exclude checks of 2-phase validation, since we have
-      -- just constructed our own validating flag and can hence trust it! Other
-      -- static checks must be run, however, since we haven't computed them
-      -- before.
-      state' <-
-        liftEither
-          . left API.ApplyTxError
-          . flip runReader globals
-          . applySTSValidateSuchThat
-            @(Core.EraRule "LEDGER" (AlonzoEra c))
-            (notElem Alonzo.lbl2Phase)
-          $ TRC (env, st, vtx)
-      pure (state', vtx)
-    where
-      delegs = (_genDelegs . _dstate) dpstate
-      stake = (_pParams . _pstate) dpstate
-      utxoenv = API.UtxoEnv slot pp stake delegs
-
-  applyTxInBlock globals env state tx =
+  reapplyTx globals env state vtx =
     let res =
           flip runReader globals
             . applySTSNonStatic
               @(Core.EraRule "LEDGER" (AlonzoEra c))
-            $ TRC (env, state, tx)
+            $ TRC (env, state, API.extractTx vtx)
      in liftEither . left API.ApplyTxError $ res
 
 instance API.PraosCrypto c => API.ApplyBlock (AlonzoEra c)

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Mempool.hs

@@ -16,6 +16,8 @@
 module Shelley.Spec.Ledger.API.Mempool
   ( ApplyTx (..),
     ApplyTxError (..),
+    Validated,
+    extractTx,
 
     -- * Exports for testing
     MempoolEnv,
@@ -61,6 +63,15 @@ import Shelley.Spec.Ledger.PParams (PParams' (..))
 import Shelley.Spec.Ledger.STS.Ledger (LedgerEnv, LedgerPredicateFailure)
 import qualified Shelley.Spec.Ledger.STS.Ledger as Ledger
 
+-- | A newtype which indicates that a transaction has been validated against
+-- some chain state.
+newtype Validated tx = Validated tx
+  deriving (Eq, Show)
+
+-- | Extract the underlying unvalidated Tx.
+extractTx :: Validated tx -> tx
+extractTx (Validated tx) = tx
+
 class
   ( ChainData (Core.Tx era),
     AnnotatedData (Core.Tx era),
@@ -89,25 +100,25 @@ class
     MempoolEnv era ->
     MempoolState era ->
     Core.Tx era ->
-    m (MempoolState era, Core.Tx era)
+    m (MempoolState era, Validated (Core.Tx era))
   default applyTx ::
     MonadError (ApplyTxError era) m =>
     Globals ->
     MempoolEnv era ->
     MempoolState era ->
     Core.Tx era ->
-    m (MempoolState era, Core.Tx era)
+    m (MempoolState era, Validated (Core.Tx era))
   applyTx globals env state tx =
     let res =
           flip runReader globals
             . applySTS @(Core.EraRule "LEDGER" era)
             $ TRC (env, state, tx)
      in liftEither
           . left ApplyTxError
-          . right (,tx)
+          . right (,Validated tx)
           $ res
 
-  -- | Reapply a 'TxInBlock'.
+  -- | Reapply a previously validated 'Tx'.
   --
   --   This applies the (validated) transaction to a new mempool state. It may
   --   fail due to the mempool state changing (for example, a needed output
@@ -118,21 +129,21 @@ class
   --   any static checks. This is not required, but strongly encouraged since
   --   this function will be called each time the mempool revalidates
   --   transactions against a new mempool state.
-  applyTxInBlock ::
+  reapplyTx ::
     MonadError (ApplyTxError era) m =>
     Globals ->
     MempoolEnv era ->
     MempoolState era ->
-    Core.Tx era ->
+    Validated (Core.Tx era) ->
     m (MempoolState era)
-  default applyTxInBlock ::
+  default reapplyTx ::
     MonadError (ApplyTxError era) m =>
     Globals ->
     MempoolEnv era ->
     MempoolState era ->
-    Core.Tx era ->
+    Validated (Core.Tx era) ->
     m (MempoolState era)
-  applyTxInBlock globals env state tx =
+  reapplyTx globals env state (Validated tx) =
     let res =
           flip runReader globals
             . applySTS @(Core.EraRule "LEDGER" era)