Mempool rule

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

@@ -125,7 +125,7 @@ ledgerTransition ::
   ) =>
   TransitionRule (someLEDGER era)
 ledgerTransition = do
-  TRC (LedgerEnv slot txIx pp account, LedgerState utxoSt certState, tx) <- judgmentContext
+  TRC (LedgerEnv slot txIx pp account _, LedgerState utxoSt certState, tx) <- judgmentContext
   let txBody = tx ^. bodyTxL
 
   certState' <-

eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Trace.hs

@@ -73,6 +73,7 @@ instance
     LedgerEnv (SlotNo 0) minBound
       <$> genEraPParams @era geConstants
       <*> genAccountState geConstants
+      <*> pure False
 
   sigGen genenv env state = genTx genenv env state
 

eras/conway/impl/CHANGELOG.md

@@ -2,6 +2,10 @@
 
 ## 1.17.0.0
 
+* Add `ConwayMempoolEvent` type
+* Add `MempoolEvent` to `ConwayLedgerEvent`
+* Add `Mempool` module, `ConwayMEMPOOL` and `ConwayMempoolPredFailure`
+* Add `ConwayMempoolFailure` to `ConwayLedgerPredFailure`
 * Add `ZeroTreasuryWithdrawals` to `ConwayGovPredFailure`
 * Add `ProtVer` argument to `TxInfo` functions:
   * `transTxCert`

eras/conway/impl/cardano-ledger-conway.cabal

@@ -62,6 +62,7 @@ library
         Cardano.Ledger.Conway.Rules.Epoch
         Cardano.Ledger.Conway.Rules.Ledger
         Cardano.Ledger.Conway.Rules.Ledgers
+        Cardano.Ledger.Conway.Rules.Mempool
         Cardano.Ledger.Conway.Rules.NewEpoch
         Cardano.Ledger.Conway.Rules.Gov
         Cardano.Ledger.Conway.Rules.Pool

eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs

@@ -9,6 +9,7 @@ module Cardano.Ledger.Conway.Era (
   ConwayGOVCERT,
   ConwayCERTS,
   ConwayGOV,
+  ConwayMEMPOOL,
   ConwayNEWEPOCH,
   ConwayEPOCH,
   ConwayENACT,
@@ -135,6 +136,10 @@ data ConwayBBODY era
 
 type instance EraRule "BBODY" (ConwayEra c) = ConwayBBODY (ConwayEra c)
 
+data ConwayMEMPOOL era
+
+type instance EraRule "MEMPOOL" (ConwayEra c) = ConwayMEMPOOL (ConwayEra c)
+
 -- Rules inherited from Shelley
 
 type instance EraRule "LEDGERS" (ConwayEra c) = API.ShelleyLEDGERS (ConwayEra c)

eras/conway/impl/src/Cardano/Ledger/Conway/Rules.hs

@@ -12,6 +12,7 @@ module Cardano.Ledger.Conway.Rules (
   module Cardano.Ledger.Conway.Rules.Enact,
   module Cardano.Ledger.Conway.Rules.Epoch,
   module Cardano.Ledger.Conway.Rules.Ledger,
+  module Cardano.Ledger.Conway.Rules.Mempool,
   module Cardano.Ledger.Conway.Rules.NewEpoch,
   module Cardano.Ledger.Conway.Rules.Tickf,
   module Cardano.Ledger.Conway.Rules.Ratify,
@@ -34,6 +35,7 @@ import Cardano.Ledger.Conway.Rules.Gov
 import Cardano.Ledger.Conway.Rules.GovCert
 import Cardano.Ledger.Conway.Rules.Ledger
 import Cardano.Ledger.Conway.Rules.Ledgers ()
+import Cardano.Ledger.Conway.Rules.Mempool
 import Cardano.Ledger.Conway.Rules.NewEpoch
 import Cardano.Ledger.Conway.Rules.Pool ()
 import Cardano.Ledger.Conway.Rules.Ratify

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs

@@ -50,6 +50,7 @@ import Cardano.Ledger.Conway.Era (
   ConwayEra,
   ConwayGOV,
   ConwayLEDGER,
+  ConwayMEMPOOL,
   ConwayUTXOW,
  )
 import Cardano.Ledger.Conway.Governance (
@@ -75,6 +76,7 @@ import Cardano.Ledger.Conway.Rules.Gov (
   GovSignal (..),
  )
 import Cardano.Ledger.Conway.Rules.GovCert (ConwayGovCertPredFailure)
+import Cardano.Ledger.Conway.Rules.Mempool (ConwayMempoolEvent (..), ConwayMempoolPredFailure (..))
 import Cardano.Ledger.Conway.Rules.Utxo (ConwayUtxoPredFailure)
 import Cardano.Ledger.Conway.Rules.Utxos (ConwayUtxosPredFailure)
 import Cardano.Ledger.Conway.Rules.Utxow (ConwayUtxowPredFailure)
@@ -109,7 +111,7 @@ import Cardano.Ledger.UMap (UView (..))
 import qualified Cardano.Ledger.UMap as UMap
 import Cardano.Ledger.UTxO (EraUTxO (..))
 import Control.DeepSeq (NFData)
-import Control.Monad (unless)
+import Control.Monad (unless, void, when)
 import Control.Monad.Trans.Reader (asks)
 import Control.State.Transition.Extended (
   Embed (..),
@@ -128,6 +130,7 @@ import qualified Data.Map.Strict as Map
 import Data.Sequence (Seq)
 import qualified Data.Sequence.Strict as StrictSeq
 import qualified Data.Set as Set
+import Data.Text (Text)
 import GHC.Generics (Generic (..))
 import Lens.Micro as L
 import NoThunks.Class (NoThunks (..))
@@ -147,6 +150,7 @@ data ConwayLedgerPredFailure era
       Int
       -- | Maximum allowed total reference script size
       Int
+  | ConwayMempoolFailure Text
   deriving (Generic)
 
 -- | In the next era this will become a proper protocol parameter. For now this is a hard
@@ -212,6 +216,9 @@ instance InjectRuleFailure "LEDGER" ConwayGovCertPredFailure (ConwayEra c) where
 instance InjectRuleFailure "LEDGER" ConwayGovPredFailure (ConwayEra c) where
   injectFailure = ConwayGovFailure
 
+instance InjectRuleFailure "LEDGER" ConwayMempoolPredFailure (ConwayEra c) where
+  injectFailure (ConwayMempoolPredFailure t) = ConwayMempoolFailure t
+
 deriving instance
   ( Era era
   , Eq (PredicateFailure (EraRule "UTXOW" era))
@@ -262,6 +269,7 @@ instance
       ConwayTreasuryValueMismatch actual submitted ->
         Sum (ConwayTreasuryValueMismatch @era) 5 !> To actual !> To submitted
       ConwayTxRefScriptsSizeTooBig x y -> Sum ConwayTxRefScriptsSizeTooBig 6 !> To x !> To y
+      ConwayMempoolFailure t -> Sum ConwayMempoolFailure 7 !> To t
 
 instance
   ( Era era
@@ -279,25 +287,29 @@ instance
       4 -> SumD ConwayWdrlNotDelegatedToDRep <! From
       5 -> SumD ConwayTreasuryValueMismatch <! From <! From
       6 -> SumD ConwayTxRefScriptsSizeTooBig <! From <! From
+      7 -> SumD ConwayMempoolFailure <! From
       n -> Invalid n
 
 data ConwayLedgerEvent era
   = UtxowEvent (Event (EraRule "UTXOW" era))
   | CertsEvent (Event (EraRule "CERTS" era))
   | GovEvent (Event (EraRule "GOV" era))
+  | MempoolEvent (Event (EraRule "MEMPOOL" era))
   deriving (Generic)
 
 deriving instance
   ( Eq (Event (EraRule "CERTS" era))
   , Eq (Event (EraRule "UTXOW" era))
   , Eq (Event (EraRule "GOV" era))
+  , Eq (Event (EraRule "MEMPOOL" era))
   ) =>
   Eq (ConwayLedgerEvent era)
 
 instance
   ( NFData (Event (EraRule "CERTS" era))
   , NFData (Event (EraRule "UTXOW" era))
   , NFData (Event (EraRule "GOV" era))
+  , NFData (Event (EraRule "MEMPOOL" era))
   ) =>
   NFData (ConwayLedgerEvent era)
 
@@ -309,15 +321,19 @@ instance
   , Embed (EraRule "UTXOW" era) (ConwayLEDGER era)
   , Embed (EraRule "GOV" era) (ConwayLEDGER era)
   , Embed (EraRule "CERTS" era) (ConwayLEDGER era)
+  , Embed (EraRule "MEMPOOL" era) (ConwayLEDGER era)
   , State (EraRule "UTXOW" era) ~ UTxOState era
   , State (EraRule "CERTS" era) ~ CertState era
   , State (EraRule "GOV" era) ~ Proposals era
+  , State (EraRule "MEMPOOL" era) ~ LedgerState era
   , Environment (EraRule "UTXOW" era) ~ UtxoEnv era
   , Environment (EraRule "CERTS" era) ~ CertsEnv era
   , Environment (EraRule "GOV" era) ~ GovEnv era
+  , Environment (EraRule "MEMPOOL" era) ~ LedgerEnv era
   , Signal (EraRule "UTXOW" era) ~ Tx era
   , Signal (EraRule "CERTS" era) ~ Seq (TxCert era)
   , Signal (EraRule "GOV" era) ~ GovSignal era
+  , Signal (EraRule "MEMPOOL" era) ~ Tx era
   ) =>
   STS (ConwayLEDGER era)
   where
@@ -350,21 +366,31 @@ ledgerTransition ::
   , Embed (EraRule "UTXOW" era) (someLEDGER era)
   , Embed (EraRule "GOV" era) (someLEDGER era)
   , Embed (EraRule "CERTS" era) (someLEDGER era)
+  , Embed (EraRule "MEMPOOL" era) (someLEDGER era)
   , State (EraRule "UTXOW" era) ~ UTxOState era
   , State (EraRule "CERTS" era) ~ CertState era
   , State (EraRule "GOV" era) ~ Proposals era
+  , State (EraRule "MEMPOOL" era) ~ LedgerState era
   , Environment (EraRule "UTXOW" era) ~ UtxoEnv era
   , Environment (EraRule "GOV" era) ~ GovEnv era
   , Environment (EraRule "CERTS" era) ~ CertsEnv era
+  , Environment (EraRule "MEMPOOL" era) ~ LedgerEnv era
   , Signal (EraRule "UTXOW" era) ~ Tx era
   , Signal (EraRule "CERTS" era) ~ Seq (TxCert era)
   , Signal (EraRule "GOV" era) ~ GovSignal era
+  , Signal (EraRule "MEMPOOL" era) ~ Tx era
   , BaseM (someLEDGER era) ~ ShelleyBase
   , STS (someLEDGER era)
   ) =>
   TransitionRule (someLEDGER era)
 ledgerTransition = do
-  TRC (LedgerEnv slot _txIx pp account, LedgerState utxoState certState, tx) <- judgmentContext
+  TRC (le@(LedgerEnv slot _txIx pp account mempool), ls@(LedgerState utxoState certState), tx) <-
+    judgmentContext
+
+  when mempool $
+    void $
+      trans @(EraRule "MEMPOOL" era) $
+        TRC (le, ls, tx)
 
   currentEpoch <- liftSTS $ do
     ei <- asks epochInfoPure
@@ -496,6 +522,7 @@ instance
   ( Embed (EraRule "UTXOW" era) (ConwayLEDGER era)
   , Embed (EraRule "CERTS" era) (ConwayLEDGER era)
   , Embed (EraRule "GOV" era) (ConwayLEDGER era)
+  , Embed (EraRule "MEMPOOL" era) (ConwayLEDGER era)
   , ConwayEraGov era
   , AlonzoEraTx era
   , ConwayEraTxBody era
@@ -504,12 +531,15 @@ instance
   , Environment (EraRule "UTXOW" era) ~ UtxoEnv era
   , Environment (EraRule "CERTS" era) ~ CertsEnv era
   , Environment (EraRule "GOV" era) ~ GovEnv era
+  , Environment (EraRule "MEMPOOL" era) ~ LedgerEnv era
   , Signal (EraRule "UTXOW" era) ~ Tx era
   , Signal (EraRule "CERTS" era) ~ Seq (TxCert era)
   , Signal (EraRule "GOV" era) ~ GovSignal era
+  , Signal (EraRule "MEMPOOL" era) ~ Tx era
   , State (EraRule "UTXOW" era) ~ UTxOState era
   , State (EraRule "CERTS" era) ~ CertState era
   , State (EraRule "GOV" era) ~ Proposals era
+  , State (EraRule "MEMPOOL" era) ~ LedgerState era
   , EraRule "GOV" era ~ ConwayGOV era
   , PredicateFailure (EraRule "LEDGER" era) ~ ConwayLedgerPredFailure era
   , Event (EraRule "LEDGER" era) ~ ConwayLedgerEvent era
@@ -546,3 +576,15 @@ instance
   where
   wrapFailed = ConwayCertsFailure . CertFailure . DelegFailure
   wrapEvent = CertsEvent . CertEvent . DelegEvent
+
+instance
+  ( EraGov era
+  , EraTx era
+  , EraRule "MEMPOOL" era ~ ConwayMEMPOOL era
+  , PredicateFailure (EraRule "MEMPOOL" era) ~ ConwayMempoolPredFailure era
+  , Event (EraRule "MEMPOOL" era) ~ ConwayMempoolEvent era
+  ) =>
+  Embed (ConwayMEMPOOL era) (ConwayLEDGER era)
+  where
+  wrapFailed (ConwayMempoolPredFailure t) = ConwayMempoolFailure t
+  wrapEvent = MempoolEvent

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Mempool.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE EmptyDataDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Cardano.Ledger.Conway.Rules.Mempool (
+  ConwayMEMPOOL,
+  ConwayMempoolEvent (..),
+  ConwayMempoolPredFailure (..),
+) where
+
+import Cardano.Ledger.BaseTypes (ShelleyBase)
+import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), FromCBOR, ToCBOR)
+import Cardano.Ledger.Conway.Core
+import Cardano.Ledger.Conway.Era (ConwayEra, ConwayMEMPOOL)
+import Cardano.Ledger.Shelley.LedgerState
+import Cardano.Ledger.Shelley.Rules (LedgerEnv (..))
+import Control.DeepSeq (NFData)
+import Control.State.Transition (
+  BaseM,
+  Environment,
+  Event,
+  PredicateFailure,
+  STS (..),
+  Signal,
+  State,
+  TRC (TRC),
+  TransitionRule,
+  judgmentContext,
+  tellEvent,
+  transitionRules,
+ )
+import Data.Text (Text, pack)
+import GHC.Generics (Generic)
+import NoThunks.Class (NoThunks)
+
+newtype ConwayMempoolPredFailure era = ConwayMempoolPredFailure Text
+  deriving (Eq, Show, Generic)
+  deriving newtype (NoThunks, NFData, ToCBOR, FromCBOR, EncCBOR, DecCBOR)
+
+type instance EraRuleFailure "MEMPOOL" (ConwayEra c) = ConwayMempoolPredFailure (ConwayEra c)
+instance InjectRuleFailure "MEMPOOL" ConwayMempoolPredFailure (ConwayEra c)
+
+newtype ConwayMempoolEvent era = ConwayMempoolEvent Text
+  deriving (Generic, Eq)
+  deriving newtype (NFData)
+
+type instance EraRuleEvent "MEMPOOL" (ConwayEra c) = ConwayMempoolEvent (ConwayEra c)
+
+instance
+  ( EraTx era
+  , EraGov era
+  , State (EraRule "MEMPOOL" era) ~ LedgerState era
+  , Signal (EraRule "MEMPOOL" era) ~ Tx era
+  , Environment (EraRule "MEMPOOL" era) ~ LedgerEnv era
+  , EraRule "MEMPOOL" era ~ ConwayMEMPOOL era
+  ) =>
+  STS (ConwayMEMPOOL era)
+  where
+  type State (ConwayMEMPOOL era) = LedgerState era
+  type Signal (ConwayMEMPOOL era) = Tx era
+  type Environment (ConwayMEMPOOL era) = LedgerEnv era
+  type BaseM (ConwayMEMPOOL era) = ShelleyBase
+  type PredicateFailure (ConwayMEMPOOL era) = ConwayMempoolPredFailure era
+  type Event (ConwayMEMPOOL era) = ConwayMempoolEvent era
+
+  transitionRules = [mempoolTransition @era]
+
+mempoolTransition :: EraTx era => TransitionRule (ConwayMEMPOOL era)
+mempoolTransition = do
+  TRC (_ledgerEnv, ledgerState, tx) <-
+    judgmentContext
+  -- This rule only gets invoked on transactions within the mempool.
+  -- Add checks here that sanitize undesired transactions.
+  tellEvent . ConwayMempoolEvent . ("Mempool rule for tx " <>) . pack . show . txIdTx $ tx
+  pure ledgerState

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs

@@ -16,7 +16,7 @@ import Cardano.Ledger.Alonzo.Rules (
  )
 import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure)
 import Cardano.Ledger.Babbage.TxInfo (BabbageContextError)
-import Cardano.Ledger.BaseTypes (Inject, natVersion)
+import Cardano.Ledger.BaseTypes (Inject, ShelleyBase, natVersion)
 import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Rules (
   ConwayBbodyPredFailure,
@@ -25,11 +25,20 @@ import Cardano.Ledger.Conway.Rules (
   ConwayEpochEvent,
   ConwayGovCertPredFailure,
   ConwayGovPredFailure,
+  ConwayLedgerEvent,
   ConwayLedgerPredFailure,
+  ConwayMempoolEvent,
   ConwayNewEpochEvent,
  )
 import Cardano.Ledger.Conway.TxInfo (ConwayContextError)
-import Cardano.Ledger.Shelley.Rules (Event, ShelleyUtxoPredFailure, ShelleyUtxowPredFailure)
+import Cardano.Ledger.Shelley.Rules (
+  ShelleyLedgersEnv,
+  ShelleyLedgersEvent,
+  ShelleyUtxoPredFailure,
+  ShelleyUtxowPredFailure,
+ )
+import Control.State.Transition.Extended
+import Data.Sequence (Seq)
 import Data.Typeable (Typeable)
 import qualified Test.Cardano.Ledger.Babbage.Imp as BabbageImp
 import Test.Cardano.Ledger.Common
@@ -73,6 +82,13 @@ spec ::
   , InjectRuleEvent "TICK" ConwayEpochEvent era
   , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
   , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
+  , Event (EraRule "MEMPOOL" era) ~ ConwayMempoolEvent era
+  , Event (EraRule "LEDGERS" era) ~ ShelleyLedgersEvent era
+  , Event (EraRule "LEDGER" era) ~ ConwayLedgerEvent era
+  , BaseM (EraRule "LEDGERS" era) ~ ShelleyBase
+  , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era
+  , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era)
+  , STS (EraRule "LEDGERS" era)
   ) =>
   Spec
 spec = do