Do not run large data tests in parallel.

Brings peak memory usage of the persistent test suite from 6 GiB to 4 GiB. Still very bad, though.
2015-05-28 12:16:32 -03:00 · 2015-05-28 12:16:32 -03:00 · ec4623da34
commit ec4623da34
parent 11bb9cafa4
5 changed files with 114 additions and 107 deletions
--- a/serversession-backend-acid-state/tests/Main.hs
+++ b/serversession-backend-acid-state/tests/Main.hs
@ -13,9 +13,9 @@ main =
  E.bracket
    (AcidStorage <$> openLocalState emptyState)
    (createCheckpointAndClose . acidState) $
-    \acidLocal -> hspec $ parallel $ do
+    \acidLocal -> hspec $ do
      acidMem <- runIO $ AcidStorage <$> openMemoryState emptyState
      describe "AcidStorage on memory only" $
-        allStorageTests acidMem it runIO shouldBe shouldReturn shouldThrow
+        allStorageTests acidMem it runIO parallel shouldBe shouldReturn shouldThrow
      describe "AcidStorage on local storage" $
-        allStorageTests acidLocal it runIO shouldBe shouldReturn shouldThrow
+        allStorageTests acidLocal it runIO parallel shouldBe shouldReturn shouldThrow
--- a/serversession-backend-persistent/tests/Main.hs
+++ b/serversession-backend-persistent/tests/Main.hs
@ -16,7 +16,7 @@ import qualified Database.Persist.Sql as P
 P.mkMigrate "migrateAll" serverSessionDefs

 main :: IO ()
-main = hspec $ parallel $
+main = hspec $
  forM_ [ ("PostgreSQL", createPostgresqlPool "host=localhost user=test dbname=test password=test" 20)
        , ("SQLite",     createSqlitePool "test.db" 1) ] $
    \(rdbms, createPool) ->
@ -32,4 +32,4 @@ main = hspec $ parallel $
          pendingWith (show exc)
      Right pool ->
        afterAll_ (destroyAllResources pool) $
-          parallel $ allStorageTests (SqlStorage pool) it runIO shouldBe shouldReturn shouldThrow
+          allStorageTests (SqlStorage pool) it runIO parallel shouldBe shouldReturn shouldThrow
--- a/serversession-backend-redis/tests/Main.hs
+++ b/serversession-backend-redis/tests/Main.hs
@ -8,5 +8,5 @@ import Web.ServerSession.Core.StorageTests
 main :: IO ()
 main = do
  conn <- connect defaultConnectInfo
-  hspec $ describe "RedisStorage" $ parallel $
-    allStorageTests (RedisStorage conn) it runIO shouldBe shouldReturn shouldThrow
+  hspec $ describe "RedisStorage" $
+    allStorageTests (RedisStorage conn) it runIO parallel shouldBe shouldReturn shouldThrow
--- a/serversession/src/Web/ServerSession/Core/StorageTests.hs
+++ b/serversession/src/Web/ServerSession/Core/StorageTests.hs
@ -26,136 +26,143 @@ import qualified Data.Time as TI
 -- called:
 --
 -- @
-- parallel $ allStorageTests myStorageBackend it runIO shouldBe shouldReturn shouldThrow
+-- allStorageTests myStorageBackend it runIO parallel shouldBe shouldReturn shouldThrow
 -- @
 --
 -- Some storage backends are difficult to test with a clean
 -- slate.  For this reason, this collection of tests works with
-- unclean storage backends.  In addition, this test suite can be
-- executed in parallel, there are no dependencies between tests.
-- In order to enforce these claims, we always test with an
-- unclean storage backend by getting a single reference to it
-- instead of asking for a function that creates storage backends
-- and calling it on every test.
+-- unclean storage backends.  In order to enforce these claims,
+-- we always test with an unclean storage backend by getting a
+-- single reference to it instead of asking for a function that
+-- creates storage backends and calling it on every test.
+--
+-- In addition, this test suite can be executed in parallel,
+-- there are no dependencies between tests.  However, some tests
+-- require a large amount of memory so we try to run them
+-- sequentially in order to reduce the peak memory usage of the
+-- test suite.
 allStorageTests
  :: forall m s. (Monad m, Storage s)
  => s                                                         -- ^ Storage backend.
  -> (String -> IO () -> m ())                                 -- ^ @hspec@'s it.
  -> (forall a. IO a -> m a)                                   -- ^ @hspec@'s runIO.
+  -> (m () -> m ())                                            -- ^ @hspec@'s parallel
  -> (forall a. (Show a, Eq a) => a    -> a -> IO ())          -- ^ @hspec@'s shouldBe.
  -> (forall a. (Show a, Eq a) => IO a -> a -> IO ())          -- ^ @hspec@'s shouldReturn.
  -> (forall a e. Exception e => IO a -> (e -> Bool) -> IO ()) -- ^ @hspec@'s shouldThrow.
  -> m ()
-allStorageTests storage it runIO _shouldBe shouldReturn shouldThrow = do
+allStorageTests storage it runIO parallel _shouldBe shouldReturn shouldThrow = do
  let run :: forall a. TransactionM s a -> IO a
      run = runTransactionM storage

  gen <- runIO N.new

-  -- runTransactionM
-  it "runTransactionM should be sane" $ do
-    run (return 42) `shouldReturn` (42 :: Int)
+  parallel $ do
+    -- runTransactionM
+    it "runTransactionM should be sane" $ do
+      run (return 42) `shouldReturn` (42 :: Int)

-  -- getSession
-  it "getSession should return Nothing for inexistent sessions" $ do
-    replicateM_ 1000 $
-      (generateSessionId gen >>= run . getSession storage)
-        `shouldReturn` Nothing
+    -- getSession
+    it "getSession should return Nothing for inexistent sessions" $ do
+      replicateM_ 1000 $
+        (generateSessionId gen >>= run . getSession storage)
+          `shouldReturn` Nothing

-  -- deleteSession
-  it "deleteSession should not fail for inexistent sessions" $ do
-    replicateM_ 1000 $
-      generateSessionId gen >>= run . deleteSession storage
+    -- deleteSession
+    it "deleteSession should not fail for inexistent sessions" $ do
+      replicateM_ 1000 $
+        generateSessionId gen >>= run . deleteSession storage

-  it "deleteSession should delete the session" $ do
-    replicateM_ 20 $ do
-      s <- generateSession gen HasAuthId
-      let sid = sessionKey s
-      run (getSession storage sid) `shouldReturn` Nothing
-      run (insertSession storage s)
-      run (getSession storage sid) `shouldReturn` Just s
-      run (deleteSession storage sid)
-      run (getSession storage sid) `shouldReturn` Nothing
+    it "deleteSession should delete the session" $ do
+      replicateM_ 20 $ do
+        s <- generateSession gen HasAuthId
+        let sid = sessionKey s
+        run (getSession storage sid) `shouldReturn` Nothing
+        run (insertSession storage s)
+        run (getSession storage sid) `shouldReturn` Just s
+        run (deleteSession storage sid)
+        run (getSession storage sid) `shouldReturn` Nothing


-  -- deleteAllSessionsOfAuthId
-  it "deleteAllSessionsOfAuthId should not fail for inexistent auth IDs" $ do
-    replicateM_ 1000 $
-      generateAuthId gen >>= run . deleteAllSessionsOfAuthId storage
+    -- deleteAllSessionsOfAuthId
+    it "deleteAllSessionsOfAuthId should not fail for inexistent auth IDs" $ do
+      replicateM_ 1000 $
+        generateAuthId gen >>= run . deleteAllSessionsOfAuthId storage

-  it "deleteAllSessionsOfAuthId should delete the relevant sessions (but no more)" $ do
-    replicateM_ 20 $ do
-      master <- generateSession gen HasAuthId
-      let Just authId = sessionAuthId master
-      preslaves <-
-        (++) <$> replicateM 100 (generateSession gen HasAuthId)
-             <*> replicateM 100 (generateSession gen NoAuthId)
-      let slaves = (\s -> s { sessionAuthId = Just authId }) <$> preslaves
-      others <-
-        (++) <$> replicateM 30 (generateSession gen HasAuthId)
-             <*> replicateM 30 (generateSession gen NoAuthId)
-      let allS = master : slaves ++ others
+    it "deleteAllSessionsOfAuthId should delete the relevant sessions (but no more)" $ do
+      replicateM_ 20 $ do
+        master <- generateSession gen HasAuthId
+        let Just authId = sessionAuthId master
+        preslaves <-
+          (++) <$> replicateM 100 (generateSession gen HasAuthId)
+               <*> replicateM 100 (generateSession gen NoAuthId)
+        let slaves = (\s -> s { sessionAuthId = Just authId }) <$> preslaves
+        others <-
+          (++) <$> replicateM 30 (generateSession gen HasAuthId)
+               <*> replicateM 30 (generateSession gen NoAuthId)
+        let allS = master : slaves ++ others

-      -- Insert preslaves then replace them with slaves to
-      -- further test if the storage backend is able to maintain
-      -- its invariants regarding auth IDs.
-      run (mapM_ (insertSession storage) (master : preslaves ++ others))
-      run (mapM_ (replaceSession storage) slaves)
+        -- Insert preslaves then replace them with slaves to
+        -- further test if the storage backend is able to maintain
+        -- its invariants regarding auth IDs.
+        run (mapM_ (insertSession storage) (master : preslaves ++ others))
+        run (mapM_ (replaceSession storage) slaves)

-      run (mapM (getSession storage . sessionKey) allS) `shouldReturn` (Just <$> allS)
-      run (deleteAllSessionsOfAuthId storage authId)
-      run (mapM (getSession storage . sessionKey) allS) `shouldReturn`
-        ((Nothing <$ (master : slaves)) ++ (Just <$> others))
+        run (mapM (getSession storage . sessionKey) allS) `shouldReturn` (Just <$> allS)
+        run (deleteAllSessionsOfAuthId storage authId)
+        run (mapM (getSession storage . sessionKey) allS) `shouldReturn`
+          ((Nothing <$ (master : slaves)) ++ (Just <$> others))

-  -- insertSession
-  it "getSession should return the contents of insertSession" $ do
-    replicateM_ 20 $ do
-      s <- generateSession gen HasAuthId
-      run (getSession storage (sessionKey s)) `shouldReturn` Nothing
-      run (insertSession storage s)
-      run (getSession storage (sessionKey s)) `shouldReturn` Just s
+    -- insertSession
+    it "getSession should return the contents of insertSession" $ do
+      replicateM_ 20 $ do
+        s <- generateSession gen HasAuthId
+        run (getSession storage (sessionKey s)) `shouldReturn` Nothing
+        run (insertSession storage s)
+        run (getSession storage (sessionKey s)) `shouldReturn` Just s

-  it "insertSession throws an exception if a session already exists" $ do
-    replicateM_ 20 $ do
-      s1 <- generateSession gen HasAuthId
-      s2 <- generateSession gen HasAuthId
-      let sid = sessionKey s1
-          s3 = s2 { sessionKey = sid }
-      run (getSession storage sid) `shouldReturn` Nothing
-      run (insertSession storage s1)
-      run (getSession storage sid) `shouldReturn` Just s1
-      run (insertSession storage s3) `shouldThrow`
-        (\(SessionAlreadyExists s1' s3') -> s1 == s1' && s3 == s3')
-      run (getSession storage sid) `shouldReturn` Just s1
+    it "insertSession throws an exception if a session already exists" $ do
+      replicateM_ 20 $ do
+        s1 <- generateSession gen HasAuthId
+        s2 <- generateSession gen HasAuthId
+        let sid = sessionKey s1
+            s3 = s2 { sessionKey = sid }
+        run (getSession storage sid) `shouldReturn` Nothing
+        run (insertSession storage s1)
+        run (getSession storage sid) `shouldReturn` Just s1
+        run (insertSession storage s3) `shouldThrow`
+          (\(SessionAlreadyExists s1' s3') -> s1 == s1' && s3 == s3')
+        run (getSession storage sid) `shouldReturn` Just s1

-  -- replaceSession
-  it "getSession should return the contents of replaceSession" $ do
-    replicateM_ 20 $ do
-      s1  <- generateSession gen HasAuthId
-      sxs <- replicateM 20 (generateSession gen HasAuthId)
-      let sid = sessionKey s1
-          sxs' = map (\s -> s { sessionKey = sid }) sxs
-      run (getSession storage sid) `shouldReturn` Nothing
-      run (insertSession storage s1)
-      forM_ (zip (s1:sxs') sxs') $ \(before, after) -> do
-        run (getSession storage sid) `shouldReturn` Just before
-        run (replaceSession storage after)
-        run (getSession storage sid) `shouldReturn` Just after
+    -- replaceSession
+    it "getSession should return the contents of replaceSession" $ do
+      replicateM_ 20 $ do
+        s1  <- generateSession gen HasAuthId
+        sxs <- replicateM 20 (generateSession gen HasAuthId)
+        let sid = sessionKey s1
+            sxs' = map (\s -> s { sessionKey = sid }) sxs
+        run (getSession storage sid) `shouldReturn` Nothing
+        run (insertSession storage s1)
+        forM_ (zip (s1:sxs') sxs') $ \(before, after) -> do
+          run (getSession storage sid) `shouldReturn` Just before
+          run (replaceSession storage after)
+          run (getSession storage sid) `shouldReturn` Just after

-  it "replaceSession throws an exception if a session does not exist" $ do
-    replicateM_ 20 $ do
-      s <- generateSession gen HasAuthId
-      let sid = sessionKey s
-      run (getSession storage sid) `shouldReturn` Nothing
-      run (replaceSession storage s) `shouldThrow` (\(SessionDoesNotExist s') -> s == s')
-      run (getSession storage sid) `shouldReturn` Nothing
-      run (insertSession storage s)
-      run (getSession storage sid) `shouldReturn` Just s
-      let s2 = s { sessionAuthId = Nothing }
-      run (replaceSession storage s2)
-      run (getSession storage sid) `shouldReturn` Just s2
+    it "replaceSession throws an exception if a session does not exist" $ do
+      replicateM_ 20 $ do
+        s <- generateSession gen HasAuthId
+        let sid = sessionKey s
+        run (getSession storage sid) `shouldReturn` Nothing
+        run (replaceSession storage s) `shouldThrow` (\(SessionDoesNotExist s') -> s == s')
+        run (getSession storage sid) `shouldReturn` Nothing
+        run (insertSession storage s)
+        run (getSession storage sid) `shouldReturn` Just s
+        let s2 = s { sessionAuthId = Nothing }
+        run (replaceSession storage s2)
+        run (getSession storage sid) `shouldReturn` Just s2
+    -- End of call to 'parallel'

-  -- Size and representation limits
+  -- Size and representation limits (not tested in parallel)
  let trySessionMap vals = do
        sid <- generateSessionId gen
        now <- TI.getCurrentTime
--- a/serversession/tests/Main.hs
+++ b/serversession/tests/Main.hs
@ -275,7 +275,7 @@ main = hspec $ parallel $ do

  describe "MockStorage" $ do
    sto <- runIO emptyMockStorage
-    parallel $ allStorageTests sto it runIO shouldBe shouldReturn shouldThrow
+    allStorageTests sto it runIO parallel shouldBe shouldReturn shouldThrow


 -- | Used to generate session maps on QuickCheck properties.