Mempool API changes for Alonzo.

We now expose two separate functions in the mempool:

- `validateTx`, which takes a transaction and returns a `TxInBlock`.
- `reapplyTx`, which applies a `TxInBlock` to a new ledger state.

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

@@ -126,8 +126,6 @@ type instance Core.TxOut (AlonzoEra c) = TxOut (AlonzoEra c)
 
 type instance Core.TxBody (AlonzoEra c) = TxBody (AlonzoEra c)
 
-type instance Core.TxOut (AlonzoEra c) = TxOut (AlonzoEra c)
-
 type instance Core.Value (AlonzoEra c) = V.Value c
 
 type instance Core.Script (AlonzoEra c) = Script (AlonzoEra c)

cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MonoLocalBinds #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -28,7 +29,7 @@ import Shelley.Spec.Ledger.API
     ApplyTx,
     Coin (..),
     Globals,
-    LedgersEnv (..),
+    LedgerEnv (..),
     MempoolEnv,
     MempoolState,
     Tx,
@@ -57,10 +58,11 @@ type MaryBench = MaryEra C_Crypto
 -- state shouldn't matter much.
 applyTxMempoolEnv :: Default (Core.PParams era) => MempoolEnv era
 applyTxMempoolEnv =
-  LedgersEnv
-    { ledgersSlotNo = SlotNo 71,
-      ledgersPp = def,
-      ledgersAccount = AccountState (Coin 45000000000) (Coin 45000000000)
+  LedgerEnv
+    { ledgerSlotNo = SlotNo 71,
+      ledgerIx = 0,
+      ledgerPp = def,
+      ledgerAccount = AccountState (Coin 45000000000) (Coin 45000000000)
     }
 
 data ApplyTxRes era = ApplyTxRes

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

@@ -6,6 +6,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -20,15 +21,19 @@ module Shelley.Spec.Ledger.API.Mempool
     MempoolEnv,
     MempoolState,
     applyTxsTransition,
+
+    -- * Exports for compatibility
+    applyTxs,
   )
 where
 
 import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import Cardano.Ledger.Core (AnnotatedData, ChainData, SerialisableData)
 import qualified Cardano.Ledger.Core as Core
+import Cardano.Ledger.Era (Crypto, TxInBlock)
 import Cardano.Ledger.Shelley (ShelleyEra)
 import Cardano.Ledger.Shelley.Constraints (ShelleyBased)
-import Control.Arrow (left)
+import Control.Arrow (ArrowChoice (right), left)
 import Control.Monad.Except
 import Control.Monad.Trans.Reader (runReader)
 import Control.State.Transition.Extended
@@ -48,8 +53,8 @@ import Shelley.Spec.Ledger.BaseTypes (Globals, ShelleyBase)
 import Shelley.Spec.Ledger.LedgerState (NewEpochState)
 import qualified Shelley.Spec.Ledger.LedgerState as LedgerState
 import Shelley.Spec.Ledger.PParams (PParams' (..))
-import Shelley.Spec.Ledger.STS.Ledgers (LedgersEnv, LedgersPredicateFailure)
-import qualified Shelley.Spec.Ledger.STS.Ledgers as Ledgers
+import Shelley.Spec.Ledger.STS.Ledger (LedgerEnv, LedgerPredicateFailure)
+import qualified Shelley.Spec.Ledger.STS.Ledger as Ledger
 import Shelley.Spec.Ledger.Slot (SlotNo)
 import Shelley.Spec.Ledger.Tx (Tx)
 
@@ -61,39 +66,89 @@ class
     Show (ApplyTxError era),
     Typeable (ApplyTxError era),
     SerialisableData (ApplyTxError era),
-    STS (Core.EraRule "LEDGERS" era),
-    BaseM (Core.EraRule "LEDGERS" era) ~ ShelleyBase,
-    Environment (Core.EraRule "LEDGERS" era) ~ LedgersEnv era,
-    State (Core.EraRule "LEDGERS" era) ~ MempoolState era,
-    Signal (Core.EraRule "LEDGERS" era) ~ Seq (Tx era),
-    PredicateFailure (Core.EraRule "LEDGERS" era) ~ LedgersPredicateFailure era
+    STS (Core.EraRule "LEDGER" era),
+    BaseM (Core.EraRule "LEDGER" era) ~ ShelleyBase,
+    Environment (Core.EraRule "LEDGER" era) ~ LedgerEnv era,
+    State (Core.EraRule "LEDGER" era) ~ MempoolState era,
+    Signal (Core.EraRule "LEDGER" era) ~ Tx era,
+    PredicateFailure (Core.EraRule "LEDGER" era) ~ LedgerPredicateFailure era
   ) =>
   ApplyTx era
   where
-  applyTxs ::
+  -- | Validate a transaction against a mempool state, and return both the new
+  -- mempool state and a "validated" 'TxInBlock'.
+  --
+  -- The meaning of being "validated" depends on the era. In general, a
+  -- 'TxInBlock' has had all checks run, and can now only fail due to checks
+  -- which depend on the state; most notably, that UTxO inputs disappear.
+  validateTx ::
     MonadError (ApplyTxError era) m =>
     Globals ->
-    SlotNo ->
-    Seq (Tx era) ->
-    NewEpochState era ->
-    m (NewEpochState era)
-  default applyTxs ::
-    (MonadError (ApplyTxError era) m) =>
+    MempoolEnv era ->
+    MempoolState era ->
+    Tx era ->
+    m (MempoolState era, TxInBlock era)
+  default validateTx ::
+    Tx era ~ TxInBlock era =>
+    MonadError (ApplyTxError era) m =>
     Globals ->
-    SlotNo ->
-    Seq (Tx era) ->
-    NewEpochState era ->
-    m (NewEpochState era)
-  applyTxs globals slot txs state =
-    overNewEpochState (applyTxsTransition globals mempoolEnv txs) state
-    where
-      mempoolEnv = mkMempoolEnv state slot
+    MempoolEnv era ->
+    MempoolState era ->
+    Tx era ->
+    m (MempoolState era, TxInBlock era)
+  validateTx globals env state tx =
+    let res =
+          flip runReader globals
+            . applySTS @(Core.EraRule "LEDGER" era)
+            $ TRC (env, state, tx)
+     in liftEither
+          . left (ApplyTxError . join)
+          . right (,tx)
+          $ res
+
+  -- | Reapply a 'TxInBlock'.
+  --
+  --   This applies the (validated) transaction to a new mempool state. It may
+  --   fail due to the mempool state changing (for example, a needed output
+  --   having already been spent). It should not fail due to any static check
+  --   (such as cryptographic checks).
+  --
+  --   Implementations of this function may optionally skip the performance of
+  --   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.
+  reapplyTxInBlock ::
+    MonadError (ApplyTxError era) m =>
+    Globals ->
+    MempoolEnv era ->
+    MempoolState era ->
+    TxInBlock era ->
+    m (MempoolState era)
+  default reapplyTxInBlock ::
+    Tx era ~ TxInBlock era =>
+    MonadError (ApplyTxError era) m =>
+    Globals ->
+    MempoolEnv era ->
+    MempoolState era ->
+    TxInBlock era ->
+    m (MempoolState era)
+  reapplyTxInBlock globals env state tx =
+    let res =
+          flip runReader globals
+            . applySTS @(Core.EraRule "LEDGER" era)
+            $ TRC (env, state, tx)
+     in liftEither
+          . left (ApplyTxError . join)
+          $ res
 
 instance PraosCrypto c => ApplyTx (ShelleyEra c)
 
-type MempoolEnv era = Ledgers.LedgersEnv era
+type MempoolEnv era = Ledger.LedgerEnv era
 
-type MempoolState = LedgerState.LedgerState
+type MempoolState era =
+  ( LedgerState.UTxOState era,
+    LedgerState.DPState (Crypto era)
+  )
 
 -- | Construct the environment used to validate transactions from the full
 -- ledger state.
@@ -117,10 +172,11 @@ mkMempoolEnv
     { LedgerState.nesEs
     }
   slot =
-    Ledgers.LedgersEnv
-      { Ledgers.ledgersSlotNo = slot,
-        Ledgers.ledgersPp = LedgerState.esPp nesEs,
-        Ledgers.ledgersAccount = LedgerState.esAccountState nesEs
+    Ledger.LedgerEnv
+      { Ledger.ledgerSlotNo = slot,
+        Ledger.ledgerIx = 0,
+        Ledger.ledgerPp = LedgerState.esPp nesEs,
+        Ledger.ledgerAccount = LedgerState.esAccountState nesEs
       }
 
 -- | Construct a mempool state from the wider ledger state.
@@ -130,42 +186,60 @@ mkMempoolEnv
 --   a new block).
 mkMempoolState :: NewEpochState era -> MempoolState era
 mkMempoolState LedgerState.NewEpochState {LedgerState.nesEs} =
-  LedgerState.esLState nesEs
+  (_utxoState, _delegationState)
+  where
+    LedgerState.LedgerState
+      { LedgerState._utxoState,
+        LedgerState._delegationState
+      } = LedgerState.esLState nesEs
 
-data ApplyTxError era = ApplyTxError [PredicateFailure (Core.EraRule "LEDGERS" era)]
+data ApplyTxError era = ApplyTxError [PredicateFailure (Core.EraRule "LEDGER" era)]
 
 deriving stock instance
-  (Eq (PredicateFailure (Core.EraRule "LEDGERS" era))) =>
+  (Eq (PredicateFailure (Core.EraRule "LEDGER" era))) =>
   Eq (ApplyTxError era)
 
 deriving stock instance
-  (Show (PredicateFailure (Core.EraRule "LEDGERS" era))) =>
+  (Show (PredicateFailure (Core.EraRule "LEDGER" era))) =>
   Show (ApplyTxError era)
 
 instance
   ( ShelleyBased era,
-    ToCBOR (PredicateFailure (Core.EraRule "LEDGERS" era))
+    ToCBOR (PredicateFailure (Core.EraRule "LEDGER" era))
   ) =>
   ToCBOR (ApplyTxError era)
   where
   toCBOR (ApplyTxError es) = toCBOR es
 
 instance
   ( ShelleyBased era,
-    FromCBOR (PredicateFailure (Core.EraRule "LEDGERS" era))
+    FromCBOR (PredicateFailure (Core.EraRule "LEDGER" era))
   ) =>
   FromCBOR (ApplyTxError era)
   where
   fromCBOR = ApplyTxError <$> fromCBOR
 
+-- | Old 'applyTxs'
+applyTxs ::
+  ApplyTx era =>
+  MonadError (ApplyTxError era) m =>
+  Globals ->
+  SlotNo ->
+  Seq (Tx era) ->
+  NewEpochState era ->
+  m (NewEpochState era)
+applyTxs
+  globals
+  slot
+  txs
+  state =
+    overNewEpochState (applyTxsTransition globals mempoolEnv txs) state
+    where
+      mempoolEnv = mkMempoolEnv state slot
+
 applyTxsTransition ::
   forall era m.
-  ( STS (Core.EraRule "LEDGERS" era),
-    BaseM (Core.EraRule "LEDGERS" era) ~ ShelleyBase,
-    Environment (Core.EraRule "LEDGERS" era) ~ LedgersEnv era,
-    State (Core.EraRule "LEDGERS" era) ~ MempoolState era,
-    Signal (Core.EraRule "LEDGERS" era) ~ Seq (Tx era),
-    PredicateFailure (Core.EraRule "LEDGERS" era) ~ LedgersPredicateFailure era,
+  ( ApplyTx era,
     MonadError (ApplyTxError era) m
   ) =>
   Globals ->
@@ -174,13 +248,10 @@ applyTxsTransition ::
   MempoolState era ->
   m (MempoolState era)
 applyTxsTransition globals env txs state =
-  let res =
-        flip runReader globals
-          . applySTS @(Core.EraRule "LEDGERS" era)
-          $ TRC (env, state, txs)
-   in liftEither
-        . left (ApplyTxError . join)
-        $ res
+  foldM
+    (\st tx -> fst <$> validateTx globals env st tx)
+    state
+    txs
 
 -- | Transform a function over mempool states to one over the full
 -- 'NewEpochState'.
@@ -190,9 +261,14 @@ overNewEpochState ::
   NewEpochState era ->
   f (NewEpochState era)
 overNewEpochState f st = do
-  res <- f $ mkMempoolState st
-  pure $
-    st
-      { LedgerState.nesEs =
-          (LedgerState.nesEs st) {LedgerState.esLState = res}
-      }
+  f (mkMempoolState st)
+    >$< \(us, ds) ->
+      st
+        { LedgerState.nesEs =
+            (LedgerState.nesEs st)
+              { LedgerState.esLState =
+                  LedgerState.LedgerState us ds
+              }
+        }
+  where
+    (>$<) = flip (<$>)

shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs

@@ -857,7 +857,7 @@ instance
 
 instance
   ( Era era,
-    Arbitrary (STS.PredicateFailure (Core.EraRule "LEDGERS" era))
+    Arbitrary (STS.PredicateFailure (Core.EraRule "LEDGER" era))
   ) =>
   Arbitrary (ApplyTxError era)
   where