From 83faa561c8bf697c68a48bd1f9371caac3b0e308 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Wed, 27 May 2015 23:42:30 -0300 Subject: [PATCH] New collection of generic storage tests. --- serversession/serversession.cabal | 3 + .../Web/ServerSession/Core/StorageTests.hs | 174 ++++++++++++++++++ 2 files changed, 177 insertions(+) create mode 100644 serversession/src/Web/ServerSession/Core/StorageTests.hs diff --git a/serversession/serversession.cabal b/serversession/serversession.cabal index d30d16b..74a7d6b 100644 --- a/serversession/serversession.cabal +++ b/serversession/serversession.cabal @@ -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 diff --git a/serversession/src/Web/ServerSession/Core/StorageTests.hs b/serversession/src/Web/ServerSession/Core/StorageTests.hs new file mode 100644 index 0000000..9547a34 --- /dev/null +++ b/serversession/src/Web/ServerSession/Core/StorageTests.hs @@ -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