Re-enable Mempool's parallel QSM test

Author: jasagredo

ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs

@@ -52,7 +52,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol
   )
 import Ouroboros.Consensus.Ledger.Tables.Utils
 import Ouroboros.Consensus.Mempool
-import Ouroboros.Consensus.Mempool.Impl.Common (tickLedgerState)
+import Ouroboros.Consensus.Mempool.Impl.Common (MempoolLedgerDBView (..), tickLedgerState)
 import Ouroboros.Consensus.Mempool.TxSeq
 import Ouroboros.Consensus.Mock.Ledger.Address
 import Ouroboros.Consensus.Mock.Ledger.Block
@@ -88,16 +88,6 @@ import Test.Util.ToExpr ()
   Datatypes
 -------------------------------------------------------------------------------}
 
--- | Whether the LedgerDB should be wiped out
-data ModifyDB = KeepDB | ClearDB deriving (Generic, ToExpr, NoThunks)
-
-instance Arbitrary ModifyDB where
-  arbitrary = elements [KeepDB, ClearDB]
-
-keepsDB :: ModifyDB -> Bool
-keepsDB KeepDB = True
-keepsDB ClearDB = False
-
 -- | The model
 data Model blk r = Model
   { modelMempoolIntermediateState :: !(TickedLedgerState blk ValuesMK)
@@ -116,12 +106,8 @@ data Model blk r = Model
 
     modelLedgerDBTip :: !(LedgerState blk ValuesMK)
   -- ^ The current tip on the ledgerdb
-  , modelReachableStates :: !(Set (LedgerState blk ValuesMK))
-  -- ^ The old states which are still on the LedgerDB. These should
-  -- technically be ancestors of the tip, but for the mempool we don't care.
-  , modelOtherStates :: !(Set (LedgerState blk ValuesMK))
-  -- ^ States which were previously on the LedgerDB. We keep these so that
-  -- 'ChangeLedger' does not generate a different state with the same hash.
+  , modelLedgerDBOtherStates :: !(Set (LedgerState blk ValuesMK))
+  -- ^ The old states which are still on the LedgerDB.
   }
 
 -- | The commands used by QSM
@@ -152,7 +138,6 @@ data Action blk r
 data Event blk r
   = ChangeLedger
       !(LedgerState blk ValuesMK)
-      !ModifyDB
   deriving Generic1
   deriving (Rank2.Functor, Rank2.Foldable, Rank2.Traversable, CommandNames)
 
@@ -240,27 +225,23 @@ generator ma gTxs model =
                                        ( getTip modelLedgerDBTip
                                            `Set.insert` Set.map
                                              getTip
-                                             ( modelOtherStates
-                                                 `Set.union` modelReachableStates
-                                             )
+                                             modelLedgerDBOtherStates
                                        )
                                      . getTip
                                  )
                   ]
-                    ++ (if Set.null modelReachableStates then [] else [elements (Set.toList modelReachableStates)])
-                    ++ (if Set.null modelOtherStates then [] else [elements (Set.toList modelOtherStates)])
+                    ++ (if Set.null modelLedgerDBOtherStates then [] else [elements (Set.toList modelLedgerDBOtherStates)])
                 )
                 `suchThat` (not . (== (getTip modelLedgerDBTip)) . getTip)
-            Event . ChangeLedger ls <$> arbitrary
+            pure $ Event $ ChangeLedger ls
         )
       , (10, pure $ Action GetSnapshot)
       ]
  where
   Model
     { modelMempoolIntermediateState
     , modelLedgerDBTip
-    , modelReachableStates
-    , modelOtherStates
+    , modelLedgerDBOtherStates
     } = model
 
 data Response blk r
@@ -286,14 +267,13 @@ initModel ::
 initModel cfg capacity initialState =
   Model
     { modelMempoolIntermediateState = ticked
-    , modelReachableStates = Set.empty
+    , modelLedgerDBOtherStates = Set.empty
     , modelLedgerDBTip = initialState
     , modelTxs = []
     , modelCurrentSize = Measure.zero
     , modelLastSeenTicketNo = zeroTicketNo
     , modelCapacity = capacity
     , modelConfig = cfg
-    , modelOtherStates = Set.empty
     }
  where
   ticked = tick cfg initialState
@@ -306,7 +286,7 @@ mock model = \case
   Action (TryAddTxs _) -> pure Void
   Action SyncLedger -> pure Void
   Action GetSnapshot -> pure $ GotSnapshot $ modelTxs model
-  Event (ChangeLedger _ _) -> pure Void
+  Event (ChangeLedger _) -> pure Void
 
 {-------------------------------------------------------------------------------
   Transitions
@@ -347,25 +327,17 @@ doChangeLedger ::
   (StandardHash blk, GetTip (LedgerState blk)) =>
   Model blk r ->
   LedgerState blk ValuesMK ->
-  ModifyDB ->
   Model blk r
-doChangeLedger model l' b' =
+doChangeLedger model l' =
   model
     { modelLedgerDBTip = l'
-    , modelReachableStates =
-        if keepsDB b'
-          then l' `Set.delete` Set.insert modelLedgerDBTip modelReachableStates
-          else Set.empty
-    , modelOtherStates =
-        if keepsDB b'
-          then modelOtherStates
-          else modelLedgerDBTip `Set.insert` (modelOtherStates `Set.union` modelReachableStates)
+    , modelLedgerDBOtherStates =
+        Set.insert modelLedgerDBTip modelLedgerDBOtherStates
     }
  where
   Model
     { modelLedgerDBTip
-    , modelReachableStates
-    , modelOtherStates
+    , modelLedgerDBOtherStates
     } = model
 
 doTryAddTxs ::
@@ -381,8 +353,8 @@ doTryAddTxs model [] = model
 doTryAddTxs model txs =
   case Foldable.find
     ((castPoint (getTip st) ==) . getTip)
-    (Set.insert modelLedgerDBTip modelReachableStates) of
-    Nothing -> doTryAddTxs (doSync model) txs
+    (Set.insert modelLedgerDBTip modelLedgerDBOtherStates) of
+    Nothing -> error "Impossible!"
     Just _ ->
       let nextTicket = succ $ modelLastSeenTicketNo model
           (validTxs, tk, newSize, st'') =
@@ -399,7 +371,7 @@ doTryAddTxs model txs =
     { modelMempoolIntermediateState = st
     , modelTxs
     , modelCurrentSize
-    , modelReachableStates
+    , modelLedgerDBOtherStates
     , modelLedgerDBTip
     , modelConfig = cfg
     , modelCapacity
@@ -419,7 +391,7 @@ transition ::
   Model blk r
 transition model cmd resp = case (cmd, resp) of
   (Action (TryAddTxs txs), Void) -> doTryAddTxs model txs
-  (Event (ChangeLedger l b), Void) -> doChangeLedger model l b
+  (Event (ChangeLedger l), Void) -> doChangeLedger model l
   (Action GetSnapshot, GotSnapshot{}) -> model
   (Action SyncLedger, Void) -> doSync model
   _ ->
@@ -539,8 +511,6 @@ data MockedLedgerDB blk = MockedLedgerDB
   -- ^ The current LedgerDB tip
   , reachableTips :: !(Set (LedgerState blk ValuesMK))
   -- ^ States which are still reachable in the LedgerDB
-  , otherStates :: !(Set (LedgerState blk ValuesMK))
-  -- ^ States which are no longer reachable in the LedgerDB
   }
   deriving Generic
 
@@ -554,23 +524,24 @@ newLedgerInterface ::
   LedgerState blk ValuesMK ->
   m (LedgerInterface m blk, StrictTVar m (MockedLedgerDB blk))
 newLedgerInterface initialLedger = do
-  t <- newTVarIO $ MockedLedgerDB initialLedger Set.empty Set.empty
+  t <- newTVarIO $ MockedLedgerDB initialLedger Set.empty
   pure
     ( LedgerInterface
         { getCurrentLedgerState = \_reg -> do
             st <- ldbTip <$> readTVar t
-            pure
-              ( forgetLedgerTables st
-              , pure $
-                  Right $
-                    ReadOnlyForker
-                      { roforkerClose = pure ()
-                      , roforkerReadStatistics = pure Nothing
-                      , roforkerReadTables = pure . (projectLedgerTables st `restrictValues'`)
-                      , roforkerRangeReadTables = const $ pure emptyLedgerTables
-                      , roforkerGetLedgerState = pure $ forgetLedgerTables st
-                      }
-              )
+            pure $
+              MempoolLedgerDBView
+                (forgetLedgerTables st)
+                ( pure $
+                    Right $
+                      ReadOnlyForker
+                        { roforkerClose = pure ()
+                        , roforkerReadStatistics = pure Nothing
+                        , roforkerReadTables = pure . (projectLedgerTables st `restrictValues'`)
+                        , roforkerRangeReadTables = const $ pure emptyLedgerTables
+                        , roforkerGetLedgerState = pure $ forgetLedgerTables st
+                        }
+                )
         }
     , t
     )
@@ -619,38 +590,20 @@ semantics trcr cmd r = do
       mapM_ (addTx m AddTxForRemotePeer) txs
       pure Void
     Action SyncLedger -> do
-      void $ syncWithLedger m
+      void $ testSyncWithLedger m
       pure Void
     Action GetSnapshot -> do
       txs <- snapshotTxs <$> atomically (getSnapshot m)
       pure $ GotSnapshot [(txForgetValidated vtx, tk) | (vtx, tk, _) <- txs]
-    Event (ChangeLedger l' newReachable) -> do
+    Event (ChangeLedger l') -> do
       CT.traceWith trcr $ "ChangingLedger to " <> show (getTip l')
       atomically $ do
-        MockedLedgerDB ledgerTip oldReachableTips oldUnreachableTips <- readTVar t
+        MockedLedgerDB ledgerTip oldReachableTips <- readTVar t
         if getTip l' == getTip ledgerTip
           then
-            if keepsDB newReachable
-              then pure ()
-              else
-                let (newReachableTips, newUnreachableTips) =
-                      ( Set.empty
-                      , Set.insert ledgerTip $
-                          Set.union oldUnreachableTips oldReachableTips
-                      )
-                 in writeTVar t (MockedLedgerDB l' newReachableTips newUnreachableTips)
+            pure ()
           else
-            let
-              (newReachableTips, newUnreachableTips) =
-                if keepsDB newReachable
-                  then (Set.insert ledgerTip oldReachableTips, oldUnreachableTips)
-                  else
-                    ( Set.empty
-                    , Set.insert ledgerTip $
-                        Set.union oldUnreachableTips oldReachableTips
-                    )
-             in
-              writeTVar t (MockedLedgerDB l' newReachableTips newUnreachableTips)
+            writeTVar t (MockedLedgerDB l' (Set.insert ledgerTip oldReachableTips))
         pure Void
 
 {-------------------------------------------------------------------------------
@@ -827,14 +780,11 @@ tests =
             \i -> fmap (fmap fst . fst) . genTxs i
     , testGroup
         "parallel"
-        [ -- See ouroboros-consensus#1549 for why this test is disabled.
-
-          -- testProperty "atomic" $
-          --     withMaxSuccess 1000 $
-          --       prop_mempoolParallel testLedgerConfigNoSizeLimits txMaxBytes' testInitLedger Atomic $
-          --         \i -> fmap (fmap fst . fst) . genTxs i
-          -- ,
-          testProperty "non atomic" $
+        [ testProperty "atomic" $
+            withMaxSuccess 10000 $
+              prop_mempoolParallel testLedgerConfigNoSizeLimits txMaxBytes' testInitLedger Atomic $
+                \i -> fmap (fmap fst . fst) . genTxs i
+        , testProperty "non atomic" $
             withMaxSuccess 10 $
               prop_mempoolParallel testLedgerConfigNoSizeLimits txMaxBytes' testInitLedger NonAtomic $
                 \i -> fmap (fmap fst . fst) . genTxs i
@@ -927,11 +877,10 @@ instance ToExpr (Action TestBlock r) where
   toExpr GetSnapshot = App "GetSnapshot" []
 
 instance ToExpr (LedgerState blk ValuesMK) => ToExpr (Event blk r) where
-  toExpr (ChangeLedger ls b) =
+  toExpr (ChangeLedger ls) =
     Rec "ChangeLedger" $
       TD.fromList
         [ ("tip", toExpr ls)
-        , ("newFork", toExpr b)
         ]
 
 instance ToExpr (Command TestBlock r) where