Fail fast when adding a redundant transaction to the mempool (#4967)

* Fail fast when adding a redundant transaction to the mempool

Closes #1294
Closes #4849

Author: neilmayhew

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

@@ -113,7 +113,7 @@ library
     nothunks,
     plutus-ledger-api >=1.37,
     set-algebra,
-    small-steps >=1.1,
+    small-steps >=1.1.2,
     text,
     transformers,
     validation-selective,

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

@@ -47,6 +47,8 @@ import Control.State.Transition (
   failOnNonEmpty,
   judgmentContext,
   transitionRules,
+  whenFailureFreeDefault,
+  (?!),
  )
 import Control.State.Transition.Extended (Embed (..), trans)
 import qualified Data.List.NonEmpty as NE
@@ -100,24 +102,40 @@ mempoolTransition ::
 mempoolTransition = do
   TRC trc@(_ledgerEnv, ledgerState, tx) <-
     judgmentContext
+
   -- This rule only gets invoked on transactions within the mempool.
   -- Add checks here that sanitize undesired transactions.
+
+  -- Detect whether the transaction is probably a duplicate
   let
-    authorizedElectedHotCreds = authorizedElectedHotCommitteeCredentials ledgerState
-    collectUnelectedCommitteeVotes !unelectedHotCreds voter _ =
-      case voter of
-        CommitteeVoter hotCred
-          | hotCred `Set.notMember` authorizedElectedHotCreds ->
-              Set.insert hotCred unelectedHotCreds
-        _ -> unelectedHotCreds
-    unelectedCommitteeVoters =
-      Map.foldlWithKey' collectUnelectedCommitteeVotes Set.empty $
-        unVotingProcedures (tx ^. bodyTxL . votingProceduresTxBodyL)
-    addPrefix =
-      ("Unelected committee members are not allowed to cast votes: " <>)
-  failOnNonEmpty unelectedCommitteeVoters $
-    ConwayMempoolFailure . addPrefix . T.pack . show . NE.toList
-  trans @(EraRule "LEDGER" era) $ TRC trc
+    inputs = tx ^. bodyTxL . inputsTxBodyL
+    UTxO utxo = ledgerState ^. utxoG
+    notAllSpent = any (`Map.member` utxo) inputs
+  notAllSpent
+    ?! ConwayMempoolFailure
+      "All inputs are spent. Transaction has probably already been included"
+
+  -- Skip all other checks if the transaction is probably a duplicate
+  whenFailureFreeDefault ledgerState $ do
+    -- Disallow votes by unelected committee members
+    let
+      authorizedElectedHotCreds = authorizedElectedHotCommitteeCredentials ledgerState
+      collectUnelectedCommitteeVotes !unelectedHotCreds voter _ =
+        case voter of
+          CommitteeVoter hotCred
+            | hotCred `Set.notMember` authorizedElectedHotCreds ->
+                Set.insert hotCred unelectedHotCreds
+          _ -> unelectedHotCreds
+      unelectedCommitteeVoters =
+        Map.foldlWithKey' collectUnelectedCommitteeVotes Set.empty $
+          unVotingProcedures (tx ^. bodyTxL . votingProceduresTxBodyL)
+      addPrefix =
+        ("Unelected committee members are not allowed to cast votes: " <>)
+    failOnNonEmpty unelectedCommitteeVoters $
+      ConwayMempoolFailure . addPrefix . T.pack . show . NE.toList
+
+    -- Continue with LEDGER rules
+    trans @(EraRule "LEDGER" era) $ TRC trc
 
 instance
   ( AlonzoEraTx era

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

@@ -28,6 +28,7 @@ import Cardano.Ledger.Conway.Rules (
   ConwayHardForkEvent,
   ConwayLedgerPredFailure,
   ConwayNewEpochEvent,
+  ConwayUtxoPredFailure,
  )
 import Cardano.Ledger.Conway.TxInfo (ConwayContextError)
 import Cardano.Ledger.Shelley.API.Mempool (ApplyTx (..))
@@ -78,6 +79,7 @@ spec ::
   , InjectRuleFailure "LEDGER" ConwayDelegPredFailure era
   , InjectRuleFailure "LEDGER" ConwayGovCertPredFailure era
   , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era
+  , InjectRuleFailure "LEDGER" ConwayUtxoPredFailure era
   , InjectRuleFailure "BBODY" ConwayBbodyPredFailure era
   , InjectRuleEvent "TICK" ConwayEpochEvent era
   , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
@@ -113,6 +115,7 @@ conwaySpec ::
   , InjectRuleFailure "LEDGER" ConwayDelegPredFailure era
   , InjectRuleFailure "LEDGER" ConwayGovCertPredFailure era
   , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era
+  , InjectRuleFailure "LEDGER" ConwayUtxoPredFailure era
   , InjectRuleFailure "BBODY" ConwayBbodyPredFailure era
   , InjectRuleEvent "TICK" ConwayEpochEvent era
   , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era

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

@@ -6,7 +6,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
 
 module Test.Cardano.Ledger.Conway.Imp.LedgerSpec (spec) where
 
@@ -16,6 +15,7 @@ import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Governance
 import Cardano.Ledger.Conway.Rules (
   ConwayLedgerPredFailure (..),
+  ConwayUtxoPredFailure (BadInputsUTxO),
   maxRefScriptSizePerTx,
  )
 import Cardano.Ledger.Credential (Credential (..))
@@ -24,10 +24,12 @@ import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
 import Cardano.Ledger.Shelley.API.Mempool (ApplyTx (..), ApplyTxError (..), applyTx, mkMempoolEnv)
 import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase)
 import Cardano.Ledger.Shelley.LedgerState
+import Control.Monad.Reader (asks)
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.Text as T
-import Lens.Micro ((&), (.~), (^.))
+import GHC.Exts (fromList)
+import Lens.Micro ((&), (.~), (<>~), (^.))
 import Lens.Micro.Mtl (use)
 import Test.Cardano.Ledger.Conway.ImpTest
 import Test.Cardano.Ledger.Core.Rational (IsRatio (..))
@@ -41,6 +43,7 @@ spec ::
   forall era.
   ( ConwayEraImp era
   , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era
+  , InjectRuleFailure "LEDGER" ConwayUtxoPredFailure era
   , ApplyTx era
   ) =>
   SpecWith (ImpInit (LedgerSpec era))
@@ -212,9 +215,54 @@ spec = do
         mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(ra, mempty)]
 
   describe "Mempool" $ do
+    let
+      submitFailingMempoolTx cause tx expectedFailures = do
+        globals <- use impGlobalsL
+        nes <- use impNESL
+        slotNo <- use impLastTickG
+        let
+          mempoolEnv = mkMempoolEnv nes slotNo
+          ls = nes ^. nesEsL . esLStateL
+        txFixed <- (tx &) =<< asks iteFixup
+        logToExpr txFixed
+        case applyTx globals mempoolEnv ls txFixed of
+          Left err -> do
+            err `shouldBe` ApplyTxError @era expectedFailures
+          Right _ ->
+            assertFailure $ "Expected failure due to " <> cause <> ": " <> show txFixed
+        pure txFixed
+      submitFailingMempoolTx_ c t = void . submitFailingMempoolTx c t
+
+    it "Duplicate transactions" $ do
+      let
+        newInput = do
+          addr <- freshKeyAddr_
+          amount <- Coin <$> choose (2_000_000, 8_000_000)
+          sendCoinTo addr amount
+
+      inputsCommon <- replicateM 5 newInput
+      inputs1 <- replicateM 2 newInput
+      inputs2 <- replicateM 3 newInput
+
+      txFinal <-
+        submitTx $
+          mkBasicTx $
+            mkBasicTxBody & inputsTxBodyL <>~ fromList (inputsCommon <> inputs1)
+
+      impAnn "Identical transaction" $ do
+        withNoFixup $
+          submitFailingMempoolTx_ "duplicate transaction" txFinal $
+            pure . injectFailure . ConwayMempoolFailure $
+              "All inputs are spent. Transaction has probably already been included"
+
+      impAnn "Overlapping transaction" $ do
+        let txOverlap = mkBasicTx $ mkBasicTxBody & inputsTxBodyL <>~ fromList (inputsCommon <> inputs2)
+        submitFailingMempoolTx_
+          "overlapping transaction"
+          txOverlap
+          [injectFailure $ BadInputsUTxO $ fromList inputsCommon]
+
     it "Unelected Committee voting" $ whenPostBootstrap $ do
-      globals <- use impGlobalsL
-      slotNo <- use impLastTickG
       _ <- registerInitialCommittee
       ccCold <- KeyHashObj <$> freshKeyHash
       curEpochNo <- getsNES nesELL
@@ -232,11 +280,8 @@ spec = do
         rewardAccount <- registerRewardAccount
         submitTreasuryWithdrawals [(rewardAccount, Coin 1)]
 
-      nes <- use impNESL
-      let ls = nes ^. nesEsL . esLStateL
-          mempoolEnv = mkMempoolEnv nes slotNo
-      tx <-
-        fixupTx $
+      let
+        tx =
           mkBasicTx $
             mkBasicTxBody
               & votingProceduresTxBodyL
@@ -246,11 +291,11 @@ spec = do
                       (Map.singleton govActionId (VotingProcedure VoteYes SNothing))
                   )
 
-      case applyTx globals mempoolEnv ls tx of
-        Left err ->
-          let expectedFailure =
-                ConwayMempoolFailure $
-                  "Unelected committee members are not allowed to cast votes: " <> T.pack (show (pure @[] ccHot))
-           in err `shouldBe` ApplyTxError @era (pure (injectFailure expectedFailure))
-        Right _ -> assertFailure $ "Expected failure due to an unallowed vote: " <> show tx
-      withNoFixup $ submitTx_ tx
+      txFixed <-
+        submitFailingMempoolTx "unallowed votes" tx $
+          pure . injectFailure . ConwayMempoolFailure $
+            "Unelected committee members are not allowed to cast votes: " <> T.pack (show (pure @[] ccHot))
+
+      -- The tx should pass all other rules
+      withNoFixup $
+        submitTx_ txFixed

libs/small-steps/CHANGELOG.md

@@ -1,8 +1,8 @@
 # Version history for `small-steps`
 
-## 1.1.1.1
+## 1.1.2.0
 
-*
+* Add `whenFailureFreeDefault`
 
 ## 1.1.1.0
 

libs/small-steps/small-steps.cabal

@@ -1,6 +1,6 @@
 cabal-version: 3.0
 name: small-steps
-version: 1.1.1.0
+version: 1.1.2.0
 license: Apache-2.0
 maintainer: operations@iohk.io
 author: IOHK

libs/small-steps/src/Control/State/Transition/Extended.hs

@@ -51,6 +51,7 @@ module Control.State.Transition.Extended (
   labeledPredE,
   ifFailureFree,
   whenFailureFree,
+  whenFailureFreeDefault,
   failBecause,
   failOnJust,
   failOnNonEmpty,
@@ -449,7 +450,11 @@ ifFailureFree :: Rule sts rtype a -> Rule sts rtype a -> Rule sts rtype a
 ifFailureFree x y = liftF (IfFailureFree x y)
 
 whenFailureFree :: Rule sts rtype () -> Rule sts rtype ()
-whenFailureFree action = ifFailureFree action (pure ())
+whenFailureFree = whenFailureFreeDefault ()
+
+whenFailureFreeDefault :: a -> Rule sts rtype a -> Rule sts rtype a
+whenFailureFreeDefault defValOnFailure actionOnNoFailure =
+  ifFailureFree actionOnNoFailure (pure defValOnFailure)
 
 liftSTS ::
   STS sts =>