Emit a new event whenever the Mempool rule gets invoked

IntersectMBO · Sep 25, 2024 · 71fc771 · 71fc771
1 parent 4634c58
commit 71fc771
Show file tree

Hide file tree

Showing 4 changed files with 27 additions and 12 deletions.
diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md
@@ -2,6 +2,8 @@
 
 ## 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`

diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs
@@ -76,7 +76,7 @@ import Cardano.Ledger.Conway.Rules.Gov (
   GovSignal (..),
  )
 import Cardano.Ledger.Conway.Rules.GovCert (ConwayGovCertPredFailure)
-import Cardano.Ledger.Conway.Rules.Mempool (ConwayMempoolPredFailure (..))
+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)
@@ -131,7 +131,6 @@ import Data.Sequence (Seq)
 import qualified Data.Sequence.Strict as StrictSeq
 import qualified Data.Set as Set
 import Data.Text (Text)
-import Data.Void (Void, absurd)
 import GHC.Generics (Generic (..))
 import Lens.Micro as L
 import NoThunks.Class (NoThunks (..))
@@ -295,19 +294,22 @@ 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)
 
@@ -577,11 +579,12 @@ instance
 
 instance
   ( EraGov era
+  , EraTx era
   , EraRule "MEMPOOL" era ~ ConwayMEMPOOL era
   , PredicateFailure (EraRule "MEMPOOL" era) ~ ConwayMempoolPredFailure era
-  , Event (EraRule "MEMPOOL" era) ~ Void
+  , Event (EraRule "MEMPOOL" era) ~ ConwayMempoolEvent era
   ) =>
   Embed (ConwayMEMPOOL era) (ConwayLEDGER era)
   where
   wrapFailed (ConwayMempoolPredFailure t) = ConwayMempoolFailure t
-  wrapEvent = absurd
+  wrapEvent = MempoolEvent
diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Mempool.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Mempool.hs
@@ -15,6 +15,7 @@
 
 module Cardano.Ledger.Conway.Rules.Mempool (
   ConwayMEMPOOL,
+  ConwayMempoolEvent (..),
   ConwayMempoolPredFailure (..),
 ) where
 
@@ -36,10 +37,10 @@ import Control.State.Transition (
   TRC (TRC),
   TransitionRule,
   judgmentContext,
+  tellEvent,
   transitionRules,
  )
-import Data.Text (Text)
-import Data.Void (Void)
+import Data.Text (Text, pack)
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks)
 
@@ -50,10 +51,15 @@ newtype ConwayMempoolPredFailure era = ConwayMempoolPredFailure Text
 type instance EraRuleFailure "MEMPOOL" (ConwayEra c) = ConwayMempoolPredFailure (ConwayEra c)
 instance InjectRuleFailure "MEMPOOL" ConwayMempoolPredFailure (ConwayEra c)
 
-type instance EraRuleEvent "MEMPOOL" (ConwayEra c) = VoidEraRule "MEMPOOL" (ConwayEra c)
+newtype ConwayMempoolEvent era = ConwayMempoolEvent Text
+  deriving (Generic, Eq)
+  deriving newtype (NFData)
+
+type instance EraRuleEvent "MEMPOOL" (ConwayEra c) = ConwayMempoolEvent (ConwayEra c)
 
 instance
-  ( EraGov era
+  ( EraTx era
+  , EraGov era
   , State (EraRule "MEMPOOL" era) ~ LedgerState era
   , Signal (EraRule "MEMPOOL" era) ~ Tx era
   , Environment (EraRule "MEMPOOL" era) ~ LedgerEnv era
@@ -66,14 +72,15 @@ instance
   type Environment (ConwayMEMPOOL era) = LedgerEnv era
   type BaseM (ConwayMEMPOOL era) = ShelleyBase
   type PredicateFailure (ConwayMEMPOOL era) = ConwayMempoolPredFailure era
-  type Event (ConwayMEMPOOL era) = Void
+  type Event (ConwayMEMPOOL era) = ConwayMempoolEvent era
 
   transitionRules = [mempoolTransition @era]
 
-mempoolTransition :: TransitionRule (ConwayMEMPOOL era)
+mempoolTransition :: EraTx era => TransitionRule (ConwayMEMPOOL era)
 mempoolTransition = do
-  TRC (_ledgerEnv, _ledgerState, _tx) <-
+  TRC (_ledgerEnv, ledgerState, tx) <-
     judgmentContext
   -- This rule only gets invoked on transactions within the mempool.
   -- Add checks here that sanitize undesired transactions.
-  pure _ledgerState
+  tellEvent . ConwayMempoolEvent . ("Mempool rule for tx " <>) . pack . show . txIdTx $ tx
+  pure ledgerState
diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs
@@ -204,6 +204,7 @@ instance
   ( ToExpr (Event (EraRule "CERTS" era))
   , ToExpr (Event (EraRule "UTXOW" era))
   , ToExpr (Event (EraRule "GOV" era))
+  , ToExpr (Event (EraRule "MEMPOOL" era))
   ) =>
   ToExpr (ConwayLedgerEvent era)
 
@@ -277,3 +278,5 @@ instance
   , ToExpr (Tx era)
   ) =>
   ToExpr (CertsEnv era)
+
+instance ToExpr (ConwayMempoolEvent era)