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.
This commit is contained in:
Felipe Lessa 2015-05-28 12:16:32 -03:00
parent 11bb9cafa4
commit ec4623da34
5 changed files with 114 additions and 107 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -26,32 +26,38 @@ 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
parallel $ do
-- runTransactionM
it "runTransactionM should be sane" $ do
run (return 42) `shouldReturn` (42 :: Int)
@ -154,8 +160,9 @@ allStorageTests storage it runIO _shouldBe shouldReturn shouldThrow = do
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

View File

@ -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.