{-# 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.Applicative as A
import Control.Exception (Exception)
import Control.Monad
import DataTypeTest (roundUTCTime)
import Web.ServerSession.Core.Internal

import qualified Crypto.Nonce as N
import qualified Data.ByteString as B
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Time as TI


-- | Execute all storage tests using 'SessionMap'.
--
-- 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:
--
-- @
-- 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 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 sto. (Monad m, Storage sto, SessionData sto ~ SessionMap)
  => sto                                                       -- ^ 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 :: sto
-> (String -> IO () -> m ())
-> (forall a. IO a -> m a)
-> (m () -> m ())
-> (forall a. (Show a, Eq a) => a -> a -> IO ())
-> (forall a. (Show a, Eq a) => IO a -> a -> IO ())
-> (forall a e. Exception e => IO a -> (e -> Bool) -> IO ())
-> m ()
allStorageTests sto
storage String -> IO () -> m ()
it forall a. IO a -> m a
runIO m () -> m ()
parallel forall a. (Show a, Eq a) => a -> a -> IO ()
_shouldBe forall a. (Show a, Eq a) => IO a -> a -> IO ()
shouldReturn forall a e. Exception e => IO a -> (e -> Bool) -> IO ()
shouldThrow = do
  let run :: forall a. TransactionM sto a -> IO a
      run :: TransactionM sto a -> IO a
run = sto -> TransactionM sto a -> IO a
forall sto a. Storage sto => sto -> TransactionM sto a -> IO a
runTransactionM sto
storage

  Generator
gen <- IO Generator -> m Generator
forall a. IO a -> m a
runIO IO Generator
forall (m :: * -> *). MonadIO m => m Generator
N.new

  m () -> m ()
parallel (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    -- runTransactionM
    String -> IO () -> m ()
it String
"runTransactionM should be sane" (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      TransactionM sto Int -> IO Int
forall a. TransactionM sto a -> IO a
run (Int -> TransactionM sto Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
42) IO Int -> Int -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` (Int
42 :: Int)

    -- getSession
    String -> IO () -> m ()
it String
"getSession should return Nothing for inexistent sessions" (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
1000 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        (Generator -> IO (SessionId SessionMap)
forall sess. Generator -> IO (SessionId sess)
generateSessionId Generator
gen IO (SessionId SessionMap)
-> (SessionId SessionMap -> IO (Maybe (Session SessionMap)))
-> IO (Maybe (Session SessionMap))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (TransactionM sto (Maybe (Session SessionMap))
 -> IO (Maybe (Session SessionMap)))
-> (SessionId SessionMap
    -> TransactionM sto (Maybe (Session SessionMap)))
-> SessionId SessionMap
-> IO (Maybe (Session SessionMap))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage)
          IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Maybe (Session SessionMap)
forall a. Maybe a
Nothing

    -- deleteSession
    String -> IO () -> m ()
it String
"deleteSession should not fail for inexistent sessions" (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
1000 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Generator -> IO (SessionId SessionMap)
forall sess. Generator -> IO (SessionId sess)
generateSessionId Generator
gen IO (SessionId SessionMap)
-> (SessionId SessionMap -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (TransactionM sto () -> IO ())
-> (SessionId SessionMap -> TransactionM sto ())
-> SessionId SessionMap
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sto -> SessionId (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> SessionId (SessionData sto) -> TransactionM sto ()
deleteSession sto
storage

    String -> IO () -> m ()
it String
"deleteSession should delete the session" (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
20 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Session SessionMap
s <- Generator -> HasAuthId -> IO (Session SessionMap)
generateSession Generator
gen HasAuthId
HasAuthId
        let sid :: SessionId SessionMap
sid = Session SessionMap -> SessionId SessionMap
forall sess. Session sess -> SessionId sess
sessionKey Session SessionMap
s
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Maybe (Session SessionMap)
forall a. Maybe a
Nothing
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
insertSession sto
storage Session (SessionData sto)
Session SessionMap
s)
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Session SessionMap -> Maybe (Session SessionMap)
forall a. a -> Maybe a
Just Session SessionMap
s
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (sto -> SessionId (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> SessionId (SessionData sto) -> TransactionM sto ()
deleteSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid)
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Maybe (Session SessionMap)
forall a. Maybe a
Nothing


    -- deleteAllSessionsOfAuthId
    String -> IO () -> m ()
it String
"deleteAllSessionsOfAuthId should not fail for inexistent auth IDs" (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
1000 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Generator -> IO AuthId
generateAuthId Generator
gen IO AuthId -> (AuthId -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (TransactionM sto () -> IO ())
-> (AuthId -> TransactionM sto ()) -> AuthId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sto -> AuthId -> TransactionM sto ()
forall sto. Storage sto => sto -> AuthId -> TransactionM sto ()
deleteAllSessionsOfAuthId sto
storage

    String -> IO () -> m ()
it String
"deleteAllSessionsOfAuthId should delete the relevant sessions (but no more)" (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
20 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Session SessionMap
master <- Generator -> HasAuthId -> IO (Session SessionMap)
generateSession Generator
gen HasAuthId
HasAuthId
        let Just AuthId
authId = Session SessionMap -> Maybe AuthId
forall sess. Session sess -> Maybe AuthId
sessionAuthId Session SessionMap
master
        [Session SessionMap]
preslaves <-
          [Session SessionMap]
-> [Session SessionMap] -> [Session SessionMap]
forall a. [a] -> [a] -> [a]
(++) ([Session SessionMap]
 -> [Session SessionMap] -> [Session SessionMap])
-> IO [Session SessionMap]
-> IO ([Session SessionMap] -> [Session SessionMap])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> Int -> IO (Session SessionMap) -> IO [Session SessionMap]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
100 (Generator -> HasAuthId -> IO (Session SessionMap)
generateSession Generator
gen HasAuthId
HasAuthId)
               IO ([Session SessionMap] -> [Session SessionMap])
-> IO [Session SessionMap] -> IO [Session SessionMap]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (Session SessionMap) -> IO [Session SessionMap]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
100 (Generator -> HasAuthId -> IO (Session SessionMap)
generateSession Generator
gen HasAuthId
NoAuthId)
        let slaves :: [Session SessionMap]
slaves = (\Session SessionMap
s -> Session SessionMap
s { sessionAuthId :: Maybe AuthId
sessionAuthId = AuthId -> Maybe AuthId
forall a. a -> Maybe a
Just AuthId
authId }) (Session SessionMap -> Session SessionMap)
-> [Session SessionMap] -> [Session SessionMap]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Session SessionMap]
preslaves
        [Session SessionMap]
others <-
          [Session SessionMap]
-> [Session SessionMap] -> [Session SessionMap]
forall a. [a] -> [a] -> [a]
(++) ([Session SessionMap]
 -> [Session SessionMap] -> [Session SessionMap])
-> IO [Session SessionMap]
-> IO ([Session SessionMap] -> [Session SessionMap])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO (Session SessionMap) -> IO [Session SessionMap]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
30 (Generator -> HasAuthId -> IO (Session SessionMap)
generateSession Generator
gen HasAuthId
HasAuthId)
               IO ([Session SessionMap] -> [Session SessionMap])
-> IO [Session SessionMap] -> IO [Session SessionMap]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (Session SessionMap) -> IO [Session SessionMap]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
30 (Generator -> HasAuthId -> IO (Session SessionMap)
generateSession Generator
gen HasAuthId
NoAuthId)
        let allS :: [Session SessionMap]
allS = Session SessionMap
master Session SessionMap -> [Session SessionMap] -> [Session SessionMap]
forall a. a -> [a] -> [a]
: [Session SessionMap]
slaves [Session SessionMap]
-> [Session SessionMap] -> [Session SessionMap]
forall a. [a] -> [a] -> [a]
++ [Session SessionMap]
others

        -- Insert preslaves then replace them with slaves to
        -- further test if the storage backend is able to maintain
        -- its invariants regarding auth IDs.
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run ((Session SessionMap -> TransactionM sto ())
-> [Session SessionMap] -> TransactionM sto ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
insertSession sto
storage) (Session SessionMap
master Session SessionMap -> [Session SessionMap] -> [Session SessionMap]
forall a. a -> [a] -> [a]
: [Session SessionMap]
preslaves [Session SessionMap]
-> [Session SessionMap] -> [Session SessionMap]
forall a. [a] -> [a] -> [a]
++ [Session SessionMap]
others))
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run ((Session SessionMap -> TransactionM sto ())
-> [Session SessionMap] -> TransactionM sto ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
replaceSession sto
storage) [Session SessionMap]
slaves)

        TransactionM sto [Maybe (Session SessionMap)]
-> IO [Maybe (Session SessionMap)]
forall a. TransactionM sto a -> IO a
run ((Session SessionMap
 -> TransactionM sto (Maybe (Session SessionMap)))
-> [Session SessionMap]
-> TransactionM sto [Maybe (Session SessionMap)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage (SessionId SessionMap
 -> TransactionM sto (Maybe (Session SessionMap)))
-> (Session SessionMap -> SessionId SessionMap)
-> Session SessionMap
-> TransactionM sto (Maybe (Session SessionMap))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Session SessionMap -> SessionId SessionMap
forall sess. Session sess -> SessionId sess
sessionKey) [Session SessionMap]
allS) IO [Maybe (Session SessionMap)]
-> [Maybe (Session SessionMap)] -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` (Session SessionMap -> Maybe (Session SessionMap)
forall a. a -> Maybe a
Just (Session SessionMap -> Maybe (Session SessionMap))
-> [Session SessionMap] -> [Maybe (Session SessionMap)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Session SessionMap]
allS)
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (sto -> AuthId -> TransactionM sto ()
forall sto. Storage sto => sto -> AuthId -> TransactionM sto ()
deleteAllSessionsOfAuthId sto
storage AuthId
authId)
        TransactionM sto [Maybe (Session SessionMap)]
-> IO [Maybe (Session SessionMap)]
forall a. TransactionM sto a -> IO a
run ((Session SessionMap
 -> TransactionM sto (Maybe (Session SessionMap)))
-> [Session SessionMap]
-> TransactionM sto [Maybe (Session SessionMap)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage (SessionId SessionMap
 -> TransactionM sto (Maybe (Session SessionMap)))
-> (Session SessionMap -> SessionId SessionMap)
-> Session SessionMap
-> TransactionM sto (Maybe (Session SessionMap))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Session SessionMap -> SessionId SessionMap
forall sess. Session sess -> SessionId sess
sessionKey) [Session SessionMap]
allS) IO [Maybe (Session SessionMap)]
-> [Maybe (Session SessionMap)] -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn`
          ((Maybe (Session SessionMap)
forall a. Maybe a
Nothing Maybe (Session SessionMap)
-> [Session SessionMap] -> [Maybe (Session SessionMap)]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Session SessionMap
master Session SessionMap -> [Session SessionMap] -> [Session SessionMap]
forall a. a -> [a] -> [a]
: [Session SessionMap]
slaves)) [Maybe (Session SessionMap)]
-> [Maybe (Session SessionMap)] -> [Maybe (Session SessionMap)]
forall a. [a] -> [a] -> [a]
++ (Session SessionMap -> Maybe (Session SessionMap)
forall a. a -> Maybe a
Just (Session SessionMap -> Maybe (Session SessionMap))
-> [Session SessionMap] -> [Maybe (Session SessionMap)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Session SessionMap]
others))

    -- insertSession
    String -> IO () -> m ()
it String
"getSession should return the contents of insertSession" (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
20 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Session SessionMap
s <- Generator -> HasAuthId -> IO (Session SessionMap)
generateSession Generator
gen HasAuthId
HasAuthId
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage (Session SessionMap -> SessionId SessionMap
forall sess. Session sess -> SessionId sess
sessionKey Session SessionMap
s)) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Maybe (Session SessionMap)
forall a. Maybe a
Nothing
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
insertSession sto
storage Session (SessionData sto)
Session SessionMap
s)
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage (Session SessionMap -> SessionId SessionMap
forall sess. Session sess -> SessionId sess
sessionKey Session SessionMap
s)) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Session SessionMap -> Maybe (Session SessionMap)
forall a. a -> Maybe a
Just Session SessionMap
s

    String -> IO () -> m ()
it String
"insertSession throws an exception if a session already exists" (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
20 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Session SessionMap
s1 <- Generator -> HasAuthId -> IO (Session SessionMap)
generateSession Generator
gen HasAuthId
HasAuthId
        Session SessionMap
s2 <- Generator -> HasAuthId -> IO (Session SessionMap)
generateSession Generator
gen HasAuthId
HasAuthId
        let sid :: SessionId SessionMap
sid = Session SessionMap -> SessionId SessionMap
forall sess. Session sess -> SessionId sess
sessionKey Session SessionMap
s1
            s3 :: Session SessionMap
s3 = Session SessionMap
s2 { sessionKey :: SessionId SessionMap
sessionKey = SessionId SessionMap
sid }
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Maybe (Session SessionMap)
forall a. Maybe a
Nothing
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
insertSession sto
storage Session (SessionData sto)
Session SessionMap
s1)
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Session SessionMap -> Maybe (Session SessionMap)
forall a. a -> Maybe a
Just Session SessionMap
s1
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
insertSession sto
storage Session (SessionData sto)
Session SessionMap
s3) IO () -> (StorageException sto -> Bool) -> IO ()
forall a e. Exception e => IO a -> (e -> Bool) -> IO ()
`shouldThrow`
          (\(SessionAlreadyExists Session (SessionData sto)
s1' Session (SessionData sto)
s3' :: StorageException sto) ->
            Session SessionMap
s1 Session SessionMap -> Session SessionMap -> Bool
forall a. Eq a => a -> a -> Bool
== Session (SessionData sto)
Session SessionMap
s1' Bool -> Bool -> Bool
&& Session SessionMap
s3 Session SessionMap -> Session SessionMap -> Bool
forall a. Eq a => a -> a -> Bool
== Session (SessionData sto)
Session SessionMap
s3')
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Session SessionMap -> Maybe (Session SessionMap)
forall a. a -> Maybe a
Just Session SessionMap
s1

    -- replaceSession
    String -> IO () -> m ()
it String
"getSession should return the contents of replaceSession" (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
20 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Session SessionMap
s1  <- Generator -> HasAuthId -> IO (Session SessionMap)
generateSession Generator
gen HasAuthId
HasAuthId
        [Session SessionMap]
sxs <- Int -> IO (Session SessionMap) -> IO [Session SessionMap]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
20 (Generator -> HasAuthId -> IO (Session SessionMap)
generateSession Generator
gen HasAuthId
HasAuthId)
        let sid :: SessionId SessionMap
sid = Session SessionMap -> SessionId SessionMap
forall sess. Session sess -> SessionId sess
sessionKey Session SessionMap
s1
            sxs' :: [Session SessionMap]
sxs' = (Session SessionMap -> Session SessionMap)
-> [Session SessionMap] -> [Session SessionMap]
forall a b. (a -> b) -> [a] -> [b]
map (\Session SessionMap
s -> Session SessionMap
s { sessionKey :: SessionId SessionMap
sessionKey = SessionId SessionMap
sid }) [Session SessionMap]
sxs
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Maybe (Session SessionMap)
forall a. Maybe a
Nothing
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
insertSession sto
storage Session (SessionData sto)
Session SessionMap
s1)
        [(Session SessionMap, Session SessionMap)]
-> ((Session SessionMap, Session SessionMap) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Session SessionMap]
-> [Session SessionMap]
-> [(Session SessionMap, Session SessionMap)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Session SessionMap
s1Session SessionMap -> [Session SessionMap] -> [Session SessionMap]
forall a. a -> [a] -> [a]
:[Session SessionMap]
sxs') [Session SessionMap]
sxs') (((Session SessionMap, Session SessionMap) -> IO ()) -> IO ())
-> ((Session SessionMap, Session SessionMap) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Session SessionMap
before, Session SessionMap
after) -> do
          TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Session SessionMap -> Maybe (Session SessionMap)
forall a. a -> Maybe a
Just Session SessionMap
before
          TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
replaceSession sto
storage Session (SessionData sto)
Session SessionMap
after)
          TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Session SessionMap -> Maybe (Session SessionMap)
forall a. a -> Maybe a
Just Session SessionMap
after

    String -> IO () -> m ()
it String
"replaceSession throws an exception if a session does not exist" (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
20 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Session SessionMap
s <- Generator -> HasAuthId -> IO (Session SessionMap)
generateSession Generator
gen HasAuthId
HasAuthId
        let sid :: SessionId SessionMap
sid = Session SessionMap -> SessionId SessionMap
forall sess. Session sess -> SessionId sess
sessionKey Session SessionMap
s
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Maybe (Session SessionMap)
forall a. Maybe a
Nothing
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
replaceSession sto
storage Session (SessionData sto)
Session SessionMap
s) IO () -> (StorageException sto -> Bool) -> IO ()
forall a e. Exception e => IO a -> (e -> Bool) -> IO ()
`shouldThrow`
          (\(SessionDoesNotExist Session (SessionData sto)
s' :: StorageException sto) -> Session SessionMap
s Session SessionMap -> Session SessionMap -> Bool
forall a. Eq a => a -> a -> Bool
== Session (SessionData sto)
Session SessionMap
s')
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Maybe (Session SessionMap)
forall a. Maybe a
Nothing
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
insertSession sto
storage Session (SessionData sto)
Session SessionMap
s)
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Session SessionMap -> Maybe (Session SessionMap)
forall a. a -> Maybe a
Just Session SessionMap
s
        let s2 :: Session SessionMap
s2 = Session SessionMap
s { sessionAuthId :: Maybe AuthId
sessionAuthId = Maybe AuthId
forall a. Maybe a
Nothing }
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
replaceSession sto
storage Session (SessionData sto)
Session SessionMap
s2)
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Session SessionMap -> Maybe (Session SessionMap)
forall a. a -> Maybe a
Just Session SessionMap
s2
    -- End of call to 'parallel'

  -- Size and representation limits (not tested in parallel)
  let trySessionMap :: [(Text, AuthId)] -> IO ()
trySessionMap [(Text, AuthId)]
vals = do
        SessionId SessionMap
sid <- Generator -> IO (SessionId SessionMap)
forall sess. Generator -> IO (SessionId sess)
generateSessionId Generator
gen
        UTCTime
now <- IO UTCTime
TI.getCurrentTime
        let session :: Session SessionMap
session = Session :: forall sess.
SessionId sess
-> Maybe AuthId
-> Decomposed sess
-> UTCTime
-> UTCTime
-> Session sess
Session
              { sessionKey :: SessionId SessionMap
sessionKey        = SessionId SessionMap
sid
              , sessionAuthId :: Maybe AuthId
sessionAuthId     = Maybe AuthId
forall a. Maybe a
Nothing
              , sessionData :: Decomposed SessionMap
sessionData       = HashMap Text AuthId -> SessionMap
SessionMap (HashMap Text AuthId -> SessionMap)
-> HashMap Text AuthId -> SessionMap
forall a b. (a -> b) -> a -> b
$ [(Text, AuthId)] -> HashMap Text AuthId
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Text, AuthId)]
vals
              , sessionCreatedAt :: UTCTime
sessionCreatedAt  = UTCTime -> UTCTime
roundUTCTime UTCTime
now
              , sessionAccessedAt :: UTCTime
sessionAccessedAt = UTCTime -> UTCTime
roundUTCTime UTCTime
now
              }
            ver2 :: Session SessionMap
ver2 = Session SessionMap
session { sessionData :: Decomposed SessionMap
sessionData = HashMap Text AuthId -> SessionMap
SessionMap HashMap Text AuthId
forall k v. HashMap k v
HM.empty }
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Maybe (Session SessionMap)
forall a. Maybe a
Nothing
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
insertSession sto
storage Session (SessionData sto)
Session SessionMap
session)
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` (Session SessionMap -> Maybe (Session SessionMap)
forall a. a -> Maybe a
Just Session SessionMap
session)
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
replaceSession sto
storage Session (SessionData sto)
Session SessionMap
ver2)
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` (Session SessionMap -> Maybe (Session SessionMap)
forall a. a -> Maybe a
Just Session SessionMap
ver2)
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
replaceSession sto
storage Session (SessionData sto)
Session SessionMap
session)
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` (Session SessionMap -> Maybe (Session SessionMap)
forall a. a -> Maybe a
Just Session SessionMap
session)
        TransactionM sto () -> IO ()
forall a. TransactionM sto a -> IO a
run (sto -> SessionId (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> SessionId (SessionData sto) -> TransactionM sto ()
deleteSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid)
        TransactionM sto (Maybe (Session SessionMap))
-> IO (Maybe (Session SessionMap))
forall a. TransactionM sto a -> IO a
run (sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession sto
storage SessionId (SessionData sto)
SessionId SessionMap
sid) IO (Maybe (Session SessionMap))
-> Maybe (Session SessionMap) -> IO ()
forall a. (Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Maybe (Session SessionMap)
forall a. Maybe a
Nothing
      mib :: Int
mib = Int
1024Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1024

  String -> IO () -> m ()
it String
"stress test: one million small keys" (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    [(Text, AuthId)] -> IO ()
trySessionMap [(String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
i), AuthId
"bar") | Int
i <- [Int
1..(Int
1000000 :: Int)]]

  String -> IO () -> m ()
it String
"stress test: one 100 MiB value" (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    [(Text, AuthId)] -> IO ()
trySessionMap [(Text
"foo", Int -> Word8 -> AuthId
B.replicate (Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
mib) Word8
70)]

  String -> IO () -> m ()
it String
"stress test: one 1 MiB key" (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    [(Text, AuthId)] -> IO ()
trySessionMap [(Int -> Text -> Text
T.replicate Int
mib Text
"x", AuthId
"foo")]

  String -> IO () -> m ()
it String
"stress test: key with all possible Unicode code points and value with all possible byte values" (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    [(Text, AuthId)] -> IO ()
trySessionMap [(String -> Text
T.pack [Char
forall a. Bounded a => a
minBound..Char
forall a. Bounded a => a
maxBound], [Word8] -> AuthId
B.pack [Word8
forall a. Bounded a => a
minBound..Word8
forall a. Bounded a => a
maxBound])]


-- | Generate a random auth ID for our tests.
generateAuthId :: N.Generator -> IO AuthId
generateAuthId :: Generator -> IO AuthId
generateAuthId = Generator -> IO AuthId
forall (m :: * -> *). MonadIO m => Generator -> m AuthId
N.nonce128url


-- | Generate a random session for our tests.
generateSession :: N.Generator -> HasAuthId -> IO (Session SessionMap)
generateSession :: Generator -> HasAuthId -> IO (Session SessionMap)
generateSession Generator
gen HasAuthId
hasAuthId = do
  SessionId SessionMap
sid <- Generator -> IO (SessionId SessionMap)
forall sess. Generator -> IO (SessionId sess)
generateSessionId Generator
gen
  Maybe AuthId
authId <-
    case HasAuthId
hasAuthId of
      HasAuthId
HasAuthId -> AuthId -> Maybe AuthId
forall a. a -> Maybe a
Just (AuthId -> Maybe AuthId) -> IO AuthId -> IO (Maybe AuthId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Generator -> IO AuthId
generateAuthId Generator
gen
      HasAuthId
NoAuthId  -> Maybe AuthId -> IO (Maybe AuthId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthId
forall a. Maybe a
Nothing
  HashMap Text AuthId
data_ <- do
    [Text]
keys <- Int -> IO Text -> IO [Text]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
20 (Generator -> IO Text
forall (m :: * -> *). MonadIO m => Generator -> m Text
N.nonce128urlT Generator
gen)
    [AuthId]
vals <- Int -> IO AuthId -> IO [AuthId]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
20 (Generator -> IO AuthId
forall (m :: * -> *). MonadIO m => Generator -> m AuthId
N.nonce128url  Generator
gen)
    HashMap Text AuthId -> IO (HashMap Text AuthId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap Text AuthId -> IO (HashMap Text AuthId))
-> HashMap Text AuthId -> IO (HashMap Text AuthId)
forall a b. (a -> b) -> a -> b
$ [(Text, AuthId)] -> HashMap Text AuthId
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([Text] -> [AuthId] -> [(Text, AuthId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
keys [AuthId]
vals)
  UTCTime
now <- IO UTCTime
TI.getCurrentTime
  Session SessionMap -> IO (Session SessionMap)
forall (m :: * -> *) a. Monad m => a -> m a
return Session :: forall sess.
SessionId sess
-> Maybe AuthId
-> Decomposed sess
-> UTCTime
-> UTCTime
-> Session sess
Session
    { sessionKey :: SessionId SessionMap
sessionKey        = SessionId SessionMap
sid
    , sessionAuthId :: Maybe AuthId
sessionAuthId     = Maybe AuthId
authId
    , sessionData :: Decomposed SessionMap
sessionData       = HashMap Text AuthId -> SessionMap
SessionMap HashMap Text AuthId
data_
    , sessionCreatedAt :: UTCTime
sessionCreatedAt  = UTCTime -> UTCTime
roundUTCTime (UTCTime -> UTCTime) -> UTCTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
TI.addUTCTime (-NominalDiffTime
1000) UTCTime
now
    , sessionAccessedAt :: UTCTime
sessionAccessedAt = UTCTime -> UTCTime
roundUTCTime (UTCTime -> UTCTime) -> UTCTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ UTCTime
now
    }

data HasAuthId = HasAuthId | NoAuthId