tx-test: fix test case counting of valid and invalid txs

In case of duplicate txids a second invalid txids could be counted as
valid because it was tracked with txid along

Author: karknu

ouroboros-network/ouroboros-network.cabal

@@ -970,6 +970,7 @@ library ouroboros-network-tests-lib
     Test.Ouroboros.Network.TxSubmission.AppV1
     Test.Ouroboros.Network.TxSubmission.AppV2
     Test.Ouroboros.Network.TxSubmission.Mempool.Simple
+    Test.Ouroboros.Network.TxSubmission.MempoolWriter
     Test.Ouroboros.Network.TxSubmission.TxLogic
     Test.Ouroboros.Network.TxSubmission.Types
 

ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission.hs

@@ -2,13 +2,15 @@ module Test.Ouroboros.Network.TxSubmission (tests) where
 
 import Test.Ouroboros.Network.TxSubmission.AppV1 qualified as AppV1
 import Test.Ouroboros.Network.TxSubmission.AppV2 qualified as AppV2
+import Test.Ouroboros.Network.TxSubmission.MempoolWriter qualified as MempoolWriter
 import Test.Ouroboros.Network.TxSubmission.TxLogic qualified as TxLogic
 
 import Test.Tasty (TestTree, testGroup)
 
 tests :: TestTree
 tests = testGroup "Ouroboros.Network.TxSubmission"
   [ AppV1.tests
+  , MempoolWriter.tests
   , TxLogic.tests
   , AppV2.tests
   ]

ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/MempoolWriter.hs

@@ -0,0 +1,45 @@
+module Test.Ouroboros.Network.TxSubmission.MempoolWriter (tests) where
+
+import Control.Concurrent.Class.MonadSTM (newTVarIO, readTVarIO)
+import Control.Monad.IOSim (runSimOrThrow)
+
+import Ouroboros.Network.Protocol.TxSubmission2.Type (SizeInBytes (..))
+import Ouroboros.Network.TxSubmission.Inbound.V1 (TxSubmissionMempoolWriter (..))
+
+import Test.Ouroboros.Network.TxSubmission.Types
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (testCaseSteps, (@?=))
+
+
+tests :: TestTree
+tests = testGroup "MempoolWriter"
+  [ testCaseSteps "getMempoolWriter records only valid duplicates" unit_getMempoolWriter_recordsOnlyValidDuplicates
+  ]
+
+
+unit_getMempoolWriter_recordsOnlyValidDuplicates :: (String -> IO ()) -> IO ()
+unit_getMempoolWriter_recordsOnlyValidDuplicates step = do
+  step "Populate the inbound mempool with one valid tx and submit one invalid duplicate plus one valid duplicate"
+  let (accepted, rejected, duplicateTxIds) =
+        runSimOrThrow $ do
+          duplicateVar <- newTVarIO []
+          mempool <- newMempool [mkTx 17 True]
+          let writer = getMempoolWriter duplicateVar mempool
+          result <- mempoolAddTxs writer [mkTx 17 False, mkTx 17 True]
+          duplicates <- readTVarIO duplicateVar
+          pure (fst result, snd result, duplicates)
+
+  step "Assert both submissions are rejected as duplicates but only the valid duplicate is recorded for result accounting"
+  accepted @?= []
+  rejected @?= [(17, DuplicateTx), (17, DuplicateTx)]
+  duplicateTxIds @?= [17]
+  where
+    mkTx :: TxId -> Bool -> Tx TxId
+    mkTx txid isValid =
+      Tx {
+          getTxId = txid,
+          getTxSize = SizeInBytes 1,
+          getTxAdvSize = SizeInBytes 1,
+          getTxValid = isValid
+        }

ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Types.hs

@@ -17,6 +17,7 @@ module Test.Ouroboros.Network.TxSubmission.Types
   , readMempool
   , getMempoolReader
   , getMempoolWriter
+  , InvalidTx (..)
   , maxTxSize
   , LargeNonEmptyList (..)
   , SimResults (..)
@@ -31,6 +32,7 @@ import Prelude hiding (seq)
 import NoThunks.Class
 
 import Control.Concurrent.Class.MonadSTM
+import Control.Concurrent.Class.MonadSTM.Strict qualified as StrictSTM
 import Control.DeepSeq
 import Control.Exception (SomeException (..))
 import Control.Monad.Class.MonadAsync
@@ -48,6 +50,10 @@ import Codec.CBOR.Encoding qualified as CBOR
 import Codec.CBOR.Read qualified as CBOR
 
 import Data.ByteString.Lazy (ByteString)
+import Data.Either (partitionEithers)
+import Data.List qualified as List
+import Data.Sequence qualified as Seq
+import Data.Set qualified as Set
 import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 
@@ -137,18 +143,73 @@ getMempoolWriter :: forall txid m.
                  => TVar m [txid]
                  -> Mempool m txid (Tx txid)
                  -> TxSubmissionMempoolWriter txid (Tx txid) Integer m InvalidTx
-getMempoolWriter duplicateVar =
-  Mempool.getWriter DuplicateTx
-                    getTxId
-                    (\_ txs -> return
-                                [ if getTxValid tx
-                                  then Right tx
-                                  else Left (getTxId tx, InvalidTx)
-                                | tx <- txs
-                                ]
-                    )
-                    (\t -> atomically $ modifyTVar' duplicateVar
-                      (map fst (filter ((== DuplicateTx) . snd) t) <>))
+getMempoolWriter duplicateVar (Mempool.Mempool mempoolVar) =
+  TxSubmissionMempoolWriter {
+      txId = getTxId,
+      mempoolAddTxs = \txs -> do
+        (acceptedTxs, rejectedTxs, duplicateValidTxIds) <- atomically $ do
+          Mempool.MempoolSeq { Mempool.mempoolSet, Mempool.mempoolSeq, Mempool.nextIdx } <-
+            StrictSTM.readTVar mempoolVar
+
+          let (duplicateTxs, txsToValidate) =
+                List.partition (\tx -> getTxId tx `Set.member` mempoolSet) txs
+              duplicateRejectedTxs =
+                [ (getTxId tx, DuplicateTx)
+                | tx <- duplicateTxs
+                ]
+              duplicateValidTxIds =
+                [ getTxId tx
+                | tx <- duplicateTxs
+                , getTxValid tx
+                ]
+              (invalidRejectedTxs, validTxs) =
+                partitionEithers
+                  [ if getTxValid tx
+                      then Right tx
+                      else Left (getTxId tx, InvalidTx)
+                  | tx <- txsToValidate
+                  ]
+
+              (delta, mempoolSeq', nextIdx', acceptedTxs, duplicateValidTxIds') =
+                List.foldl'
+                  (\(set, seq, idx, accepted, duplicates) tx ->
+                    let txid = getTxId tx in
+                    if txid `Set.member` set
+                      then ( set
+                           , seq
+                           , idx
+                           , accepted
+                           , txid : duplicates
+                           )
+                      else ( Set.insert txid set
+                           , seq Seq.|> Mempool.WithIndex idx tx
+                           , succ idx
+                           , txid : accepted
+                           , duplicates
+                           )
+                  )
+                  (Set.empty, mempoolSeq, nextIdx, [], [])
+                  validTxs
+
+          StrictSTM.writeTVar
+            mempoolVar
+            Mempool.MempoolSeq {
+              Mempool.mempoolSet = mempoolSet `Set.union` delta,
+              Mempool.mempoolSeq = mempoolSeq',
+              Mempool.nextIdx = nextIdx'
+            }
+
+          pure
+            ( acceptedTxs
+            , invalidRejectedTxs
+                ++ duplicateRejectedTxs
+                ++ [ (txid, DuplicateTx) | txid <- duplicateValidTxIds' ]
+            , duplicateValidTxIds ++ duplicateValidTxIds'
+            )
+
+        atomically $ modifyTVar' duplicateVar (duplicateValidTxIds <>)
+        pure (acceptedTxs, rejectedTxs)
+    }
 
 
 txSubmissionCodec2 :: MonadST m