New collection of generic storage tests.
This commit is contained in:
Felipe Lessa
parent
adf97f5d07
commit
83faa561c8
@ -30,11 +30,13 @@ library
|
||||
exposed-modules:
|
||||
Web.ServerSession.Core
|
||||
Web.ServerSession.Core.Internal
|
||||
Web.ServerSession.Core.StorageTests
|
||||
extensions:
|
||||
DeriveDataTypeable
|
||||
FlexibleContexts
|
||||
OverloadedStrings
|
||||
RecordWildCards
|
||||
ScopedTypeVariables
|
||||
TypeFamilies
|
||||
ghc-options: -Wall
|
||||
|
||||
@ -52,6 +54,7 @@ test-suite tests
|
||||
extensions:
|
||||
DeriveDataTypeable
|
||||
OverloadedStrings
|
||||
TupleSections
|
||||
TypeFamilies
|
||||
main-is: Main.hs
|
||||
ghc-options: -Wall -threaded -with-rtsopts=-N
|
||||
|
||||
174
serversession/src/Web/ServerSession/Core/StorageTests.hs
Normal file
174
serversession/src/Web/ServerSession/Core/StorageTests.hs
Normal file
@ -0,0 +1,174 @@
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
-- | This module contains tests that should pass for every
|
||||
-- storage backend. These are not intended for end-users of the
|
||||
-- @serversession@ library. However, they are part of the
|
||||
-- supported API, so they're not an @Internal@ module.
|
||||
module Web.ServerSession.Core.StorageTests
|
||||
( allStorageTests
|
||||
) where
|
||||
|
||||
import Control.Exception (Exception)
|
||||
import Control.Monad
|
||||
import Web.ServerSession.Core.Internal
|
||||
|
||||
import qualified Crypto.Nonce as N
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Time as TI
|
||||
|
||||
|
||||
-- | Execute all storage tests.
|
||||
--
|
||||
-- This function is meant to be used with @hspec@. However, we
|
||||
-- don't want to depend on @hspec@, so it takes the relevant
|
||||
-- @hspec@ functions as arguments. Here's how it should be
|
||||
-- called:
|
||||
--
|
||||
-- @
|
||||
-- parallel $ allStorageTests myStorageBackend it runIO 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.
|
||||
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.
|
||||
-> (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
|
||||
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)
|
||||
|
||||
-- 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
|
||||
|
||||
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
|
||||
|
||||
it "deleteAllSessionsOfAuthId should delete the relevant sessions (but no more)" $ do
|
||||
replicateM_ 20 $ do
|
||||
master <- generateSession gen HasAuthId
|
||||
let Just authId = sessionAuthId master
|
||||
slaves <- (map $ \s -> s { sessionAuthId = Just authId }) <$>
|
||||
replicateM 200 (generateSession gen NoAuthId)
|
||||
others <- (++) <$> replicateM 30 (generateSession gen HasAuthId)
|
||||
<*> replicateM 30 (generateSession gen NoAuthId)
|
||||
let allS = master : slaves ++ others
|
||||
run (mapM_ (insertSession storage) allS)
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
|
||||
-- | Generate a random auth ID for our tests.
|
||||
generateAuthId :: N.Generator -> IO AuthId
|
||||
generateAuthId = N.nonce128url
|
||||
|
||||
|
||||
-- | Generate a random session for our tests.
|
||||
generateSession :: N.Generator -> HasAuthId -> IO Session
|
||||
generateSession gen hasAuthId = do
|
||||
sid <- generateSessionId gen
|
||||
authId <-
|
||||
case hasAuthId of
|
||||
HasAuthId -> Just <$> generateAuthId gen
|
||||
NoAuthId -> return Nothing
|
||||
data_ <- do
|
||||
keys <- replicateM 20 (N.nonce128urlT gen)
|
||||
vals <- replicateM 20 (N.nonce128url gen)
|
||||
return $ M.fromList (zip keys vals)
|
||||
now <- TI.getCurrentTime
|
||||
return Session
|
||||
{ sessionKey = sid
|
||||
, sessionAuthId = authId
|
||||
, sessionData = data_
|
||||
, sessionCreatedAt = TI.addUTCTime (-1000) now
|
||||
, sessionAccessedAt = now
|
||||
}
|
||||
|
||||
data HasAuthId = HasAuthId | NoAuthId
|
||||
Loading…
Reference in New Issue
Block a user