haskell/serversession
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Do not run large data tests in parallel.

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
serversession-backend-acid-state/tests/Main.hs
View File

@ -13,9 +13,9 @@ main =
E.bracket E.bracket
(AcidStorage <$> openLocalState emptyState) (AcidStorage <$> openLocalState emptyState)
(createCheckpointAndClose . acidState) $ (createCheckpointAndClose . acidState) $
\acidLocal -> hspec $ parallel $ do \acidLocal -> hspec $ do
acidMem <- runIO $ AcidStorage <$> openMemoryState emptyState acidMem <- runIO $ AcidStorage <$> openMemoryState emptyState
describe "AcidStorage on memory only" $ 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" $ describe "AcidStorage on local storage" $
allStorageTests acidLocal it runIO shouldBe shouldReturn shouldThrow allStorageTests acidLocal it runIO parallel shouldBe shouldReturn shouldThrow

4
serversession-backend-persistent/tests/Main.hs
View File

@ -16,7 +16,7 @@ import qualified Database.Persist.Sql as P
P.mkMigrate "migrateAll" serverSessionDefs P.mkMigrate "migrateAll" serverSessionDefs
main :: IO () main :: IO ()
main = hspec $ parallel $ main = hspec $
forM_ [ ("PostgreSQL", createPostgresqlPool "host=localhost user=test dbname=test password=test" 20) forM_ [ ("PostgreSQL", createPostgresqlPool "host=localhost user=test dbname=test password=test" 20)
, ("SQLite", createSqlitePool "test.db" 1) ] $ , ("SQLite", createSqlitePool "test.db" 1) ] $
\(rdbms, createPool) -> \(rdbms, createPool) ->
@ -32,4 +32,4 @@ main = hspec $ parallel $
pendingWith (show exc) pendingWith (show exc)
Right pool -> Right pool ->
afterAll_ (destroyAllResources pool) $ afterAll_ (destroyAllResources pool) $
parallel $ allStorageTests (SqlStorage pool) it runIO shouldBe shouldReturn shouldThrow allStorageTests (SqlStorage pool) it runIO parallel shouldBe shouldReturn shouldThrow

4
serversession-backend-redis/tests/Main.hs
View File

@ -8,5 +8,5 @@ import Web.ServerSession.Core.StorageTests
main :: IO () main :: IO ()
main = do main = do
conn <- connect defaultConnectInfo conn <- connect defaultConnectInfo
hspec $ describe "RedisStorage" $ parallel $ hspec $ describe "RedisStorage" $
allStorageTests (RedisStorage conn) it runIO shouldBe shouldReturn shouldThrow allStorageTests (RedisStorage conn) it runIO parallel shouldBe shouldReturn shouldThrow

205
serversession/src/Web/ServerSession/Core/StorageTests.hs
View File

@ -26,136 +26,143 @@ import qualified Data.Time as TI
-- called: -- 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 -- Some storage backends are difficult to test with a clean
-- slate. For this reason, this collection of tests works with -- slate. For this reason, this collection of tests works with
-- unclean storage backends. In addition, this test suite can be -- unclean storage backends. In order to enforce these claims,
-- executed in parallel, there are no dependencies between tests. -- we always test with an unclean storage backend by getting a
-- In order to enforce these claims, we always test with an -- single reference to it instead of asking for a function that
-- unclean storage backend by getting a single reference to it -- creates storage backends and calling it on every test.
-- 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 allStorageTests
:: forall m s. (Monad m, Storage s) :: forall m s. (Monad m, Storage s)
=> s -- ^ Storage backend. => s -- ^ Storage backend.
-> (String -> IO () -> m ()) -- ^ @hspec@'s it. -> (String -> IO () -> m ()) -- ^ @hspec@'s it.
-> (forall a. IO a -> m a) -- ^ @hspec@'s runIO. -> (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) => a -> a -> IO ()) -- ^ @hspec@'s shouldBe.
-> (forall a. (Show a, Eq a) => IO a -> a -> IO ()) -- ^ @hspec@'s shouldReturn. -> (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. -> (forall a e. Exception e => IO a -> (e -> Bool) -> IO ()) -- ^ @hspec@'s shouldThrow.
-> m () -> 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 let run :: forall a. TransactionM s a -> IO a
run = runTransactionM storage run = runTransactionM storage
gen <- runIO N.new gen <- runIO N.new
-- runTransactionM parallel $ do
it "runTransactionM should be sane" $ do -- runTransactionM
run (return 42) `shouldReturn` (42 :: Int) it "runTransactionM should be sane" $ do
run (return 42) `shouldReturn` (42 :: Int)
-- getSession -- getSession
it "getSession should return Nothing for inexistent sessions" $ do it "getSession should return Nothing for inexistent sessions" $ do
replicateM_ 1000 $ replicateM_ 1000 $
(generateSessionId gen >>= run . getSession storage) (generateSessionId gen >>= run . getSession storage)
`shouldReturn` Nothing `shouldReturn` Nothing
-- deleteSession -- deleteSession
it "deleteSession should not fail for inexistent sessions" $ do it "deleteSession should not fail for inexistent sessions" $ do
replicateM_ 1000 $ replicateM_ 1000 $
generateSessionId gen >>= run . deleteSession storage generateSessionId gen >>= run . deleteSession storage
it "deleteSession should delete the session" $ do it "deleteSession should delete the session" $ do
replicateM_ 20 $ do replicateM_ 20 $ do
s <- generateSession gen HasAuthId s <- generateSession gen HasAuthId
let sid = sessionKey s let sid = sessionKey s
run (getSession storage sid) `shouldReturn` Nothing run (getSession storage sid) `shouldReturn` Nothing
run (insertSession storage s) run (insertSession storage s)
run (getSession storage sid) `shouldReturn` Just s run (getSession storage sid) `shouldReturn` Just s
run (deleteSession storage sid) run (deleteSession storage sid)
run (getSession storage sid) `shouldReturn` Nothing run (getSession storage sid) `shouldReturn` Nothing
-- deleteAllSessionsOfAuthId -- deleteAllSessionsOfAuthId
it "deleteAllSessionsOfAuthId should not fail for inexistent auth IDs" $ do it "deleteAllSessionsOfAuthId should not fail for inexistent auth IDs" $ do
replicateM_ 1000 $ replicateM_ 1000 $
generateAuthId gen >>= run . deleteAllSessionsOfAuthId storage generateAuthId gen >>= run . deleteAllSessionsOfAuthId storage
it "deleteAllSessionsOfAuthId should delete the relevant sessions (but no more)" $ do it "deleteAllSessionsOfAuthId should delete the relevant sessions (but no more)" $ do
replicateM_ 20 $ do replicateM_ 20 $ do
master <- generateSession gen HasAuthId master <- generateSession gen HasAuthId
let Just authId = sessionAuthId master let Just authId = sessionAuthId master
preslaves <- preslaves <-
(++) <$> replicateM 100 (generateSession gen HasAuthId) (++) <$> replicateM 100 (generateSession gen HasAuthId)
<*> replicateM 100 (generateSession gen NoAuthId) <*> replicateM 100 (generateSession gen NoAuthId)
let slaves = (\s -> s { sessionAuthId = Just authId }) <$> preslaves let slaves = (\s -> s { sessionAuthId = Just authId }) <$> preslaves
others <- others <-
(++) <$> replicateM 30 (generateSession gen HasAuthId) (++) <$> replicateM 30 (generateSession gen HasAuthId)
<*> replicateM 30 (generateSession gen NoAuthId) <*> replicateM 30 (generateSession gen NoAuthId)
let allS = master : slaves ++ others let allS = master : slaves ++ others
-- Insert preslaves then replace them with slaves to -- Insert preslaves then replace them with slaves to
-- further test if the storage backend is able to maintain -- further test if the storage backend is able to maintain
-- its invariants regarding auth IDs. -- its invariants regarding auth IDs.
run (mapM_ (insertSession storage) (master : preslaves ++ others)) run (mapM_ (insertSession storage) (master : preslaves ++ others))
run (mapM_ (replaceSession storage) slaves) run (mapM_ (replaceSession storage) slaves)
run (mapM (getSession storage . sessionKey) allS) `shouldReturn` (Just <$> allS) run (mapM (getSession storage . sessionKey) allS) `shouldReturn` (Just <$> allS)
run (deleteAllSessionsOfAuthId storage authId) run (deleteAllSessionsOfAuthId storage authId)
run (mapM (getSession storage . sessionKey) allS) `shouldReturn` run (mapM (getSession storage . sessionKey) allS) `shouldReturn`
((Nothing <$ (master : slaves)) ++ (Just <$> others)) ((Nothing <$ (master : slaves)) ++ (Just <$> others))
-- insertSession -- insertSession
it "getSession should return the contents of insertSession" $ do it "getSession should return the contents of insertSession" $ do
replicateM_ 20 $ do replicateM_ 20 $ do
s <- generateSession gen HasAuthId s <- generateSession gen HasAuthId
run (getSession storage (sessionKey s)) `shouldReturn` Nothing run (getSession storage (sessionKey s)) `shouldReturn` Nothing
run (insertSession storage s) run (insertSession storage s)
run (getSession storage (sessionKey s)) `shouldReturn` Just s run (getSession storage (sessionKey s)) `shouldReturn` Just s
it "insertSession throws an exception if a session already exists" $ do it "insertSession throws an exception if a session already exists" $ do
replicateM_ 20 $ do replicateM_ 20 $ do
s1 <- generateSession gen HasAuthId s1 <- generateSession gen HasAuthId
s2 <- generateSession gen HasAuthId s2 <- generateSession gen HasAuthId
let sid = sessionKey s1 let sid = sessionKey s1
s3 = s2 { sessionKey = sid } s3 = s2 { sessionKey = sid }
run (getSession storage sid) `shouldReturn` Nothing run (getSession storage sid) `shouldReturn` Nothing
run (insertSession storage s1) run (insertSession storage s1)
run (getSession storage sid) `shouldReturn` Just s1 run (getSession storage sid) `shouldReturn` Just s1
run (insertSession storage s3) `shouldThrow` run (insertSession storage s3) `shouldThrow`
(\(SessionAlreadyExists s1' s3') -> s1 == s1' && s3 == s3') (\(SessionAlreadyExists s1' s3') -> s1 == s1' && s3 == s3')
run (getSession storage sid) `shouldReturn` Just s1 run (getSession storage sid) `shouldReturn` Just s1
-- replaceSession -- replaceSession
it "getSession should return the contents of replaceSession" $ do it "getSession should return the contents of replaceSession" $ do
replicateM_ 20 $ do replicateM_ 20 $ do
s1 <- generateSession gen HasAuthId s1 <- generateSession gen HasAuthId
sxs <- replicateM 20 (generateSession gen HasAuthId) sxs <- replicateM 20 (generateSession gen HasAuthId)
let sid = sessionKey s1 let sid = sessionKey s1
sxs' = map (\s -> s { sessionKey = sid }) sxs sxs' = map (\s -> s { sessionKey = sid }) sxs
run (getSession storage sid) `shouldReturn` Nothing run (getSession storage sid) `shouldReturn` Nothing
run (insertSession storage s1) run (insertSession storage s1)
forM_ (zip (s1:sxs') sxs') $ \(before, after) -> do forM_ (zip (s1:sxs') sxs') $ \(before, after) -> do
run (getSession storage sid) `shouldReturn` Just before run (getSession storage sid) `shouldReturn` Just before
run (replaceSession storage after) run (replaceSession storage after)
run (getSession storage sid) `shouldReturn` Just after run (getSession storage sid) `shouldReturn` Just after
it "replaceSession throws an exception if a session does not exist" $ do it "replaceSession throws an exception if a session does not exist" $ do
replicateM_ 20 $ do replicateM_ 20 $ do
s <- generateSession gen HasAuthId s <- generateSession gen HasAuthId
let sid = sessionKey s let sid = sessionKey s
run (getSession storage sid) `shouldReturn` Nothing run (getSession storage sid) `shouldReturn` Nothing
run (replaceSession storage s) `shouldThrow` (\(SessionDoesNotExist s') -> s == s') run (replaceSession storage s) `shouldThrow` (\(SessionDoesNotExist s') -> s == s')
run (getSession storage sid) `shouldReturn` Nothing run (getSession storage sid) `shouldReturn` Nothing
run (insertSession storage s) run (insertSession storage s)
run (getSession storage sid) `shouldReturn` Just s run (getSession storage sid) `shouldReturn` Just s
let s2 = s { sessionAuthId = Nothing } let s2 = s { sessionAuthId = Nothing }
run (replaceSession storage s2) run (replaceSession storage s2)
run (getSession storage sid) `shouldReturn` Just 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 let trySessionMap vals = do
sid <- generateSessionId gen sid <- generateSessionId gen
now <- TI.getCurrentTime now <- TI.getCurrentTime

2
serversession/tests/Main.hs
View File

@ -275,7 +275,7 @@ main = hspec $ parallel $ do
describe "MockStorage" $ do describe "MockStorage" $ do
sto <- runIO emptyMockStorage 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. -- | Used to generate session maps on QuickCheck properties.