{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Internal module exposing the guts of the package.  Use at
-- your own risk.  No API stability guarantees apply.
module Web.ServerSession.Backend.Acid.Internal
  ( SessionIdToSession
  , AuthIdToSessionId
  , ServerSessionAcidState(..)
  , emptyState
  , removeSessionFromAuthId
  , insertSessionForAuthId

  , getSession
  , deleteSession
  , deleteAllSessionsOfAuthId
  , insertSession
  , replaceSession

  , GetSession
  , DeleteSession
  , DeleteAllSessionsOfAuthId
  , InsertSession
  , ReplaceSession

  , AcidStorage(..)
  ) where

import Control.Applicative as A
import Control.Monad.Reader (ask)
import Control.Monad.State (get, modify, put)
import Data.Acid
import Data.Acid.Advanced
import Data.SafeCopy
import Data.Typeable (Typeable)

import qualified Control.Exception as E
import qualified Data.HashMap.Strict as HM
import qualified Data.Set as S
import qualified Web.ServerSession.Core as SS
import qualified Web.ServerSession.Core.Internal as SSI


----------------------------------------------------------------------


-- | Map from session IDs to sessions.  The most important map,
-- allowing us efficient access to a session given its ID.
type SessionIdToSession sess = HM.HashMap (SS.SessionId sess) (SS.Session sess)


-- | Map from auth IDs to session IDs.  Allow us to invalidate
-- all sessions of given user without having to iterate through
-- the whole 'SessionIdToSession' map.
type AuthIdToSessionId sess = HM.HashMap SS.AuthId (S.Set (SS.SessionId sess))


-- | The current sessions.
--
-- Besides the obvious map from session IDs to sessions, we also
-- maintain a map of auth IDs to session IDs.  This allow us to
-- quickly invalidate all sessions of a given user.
data ServerSessionAcidState sess =
  ServerSessionAcidState
    { ServerSessionAcidState sess -> SessionIdToSession sess
sessionIdToSession :: !(SessionIdToSession sess)
    , ServerSessionAcidState sess -> AuthIdToSessionId sess
authIdToSessionId  :: !(AuthIdToSessionId sess)
    } deriving (Typeable)


-- | Empty 'ServerSessionAcidState' used to bootstrap the 'AcidState'.
emptyState :: ServerSessionAcidState sess
emptyState :: ServerSessionAcidState sess
emptyState = SessionIdToSession sess
-> AuthIdToSessionId sess -> ServerSessionAcidState sess
forall sess.
SessionIdToSession sess
-> AuthIdToSessionId sess -> ServerSessionAcidState sess
ServerSessionAcidState SessionIdToSession sess
forall k v. HashMap k v
HM.empty AuthIdToSessionId sess
forall k v. HashMap k v
HM.empty


-- | Remove the given 'SessionId' from the set of the given
-- 'AuthId' on the map.  Does not do anything if no 'AuthId' is
-- provided.
removeSessionFromAuthId
  :: SS.SessionId sess
  -> Maybe SS.AuthId
  -> AuthIdToSessionId sess
  -> AuthIdToSessionId sess
removeSessionFromAuthId :: SessionId sess
-> Maybe AuthId -> AuthIdToSessionId sess -> AuthIdToSessionId sess
removeSessionFromAuthId SessionId sess
sid = (AuthIdToSessionId sess -> AuthIdToSessionId sess)
-> (AuthId -> AuthIdToSessionId sess -> AuthIdToSessionId sess)
-> Maybe AuthId
-> AuthIdToSessionId sess
-> AuthIdToSessionId sess
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AuthIdToSessionId sess -> AuthIdToSessionId sess
forall a. a -> a
id AuthId -> AuthIdToSessionId sess -> AuthIdToSessionId sess
removeIt
  where
    removeIt :: AuthId -> AuthIdToSessionId sess -> AuthIdToSessionId sess
removeIt AuthId
authId AuthIdToSessionId sess
aits
      | Set (SessionId sess) -> Bool
forall a. Set a -> Bool
S.null Set (SessionId sess)
newSet = AuthId -> AuthIdToSessionId sess -> AuthIdToSessionId sess
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete AuthId
authId AuthIdToSessionId sess
aits
      | Bool
otherwise     = AuthId
-> Set (SessionId sess)
-> AuthIdToSessionId sess
-> AuthIdToSessionId sess
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert AuthId
authId Set (SessionId sess)
newSet AuthIdToSessionId sess
aits
      where newSet :: Set (SessionId sess)
newSet = Set (SessionId sess)
-> (Set (SessionId sess) -> Set (SessionId sess))
-> Maybe (Set (SessionId sess))
-> Set (SessionId sess)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set (SessionId sess)
forall a. Set a
S.empty (SessionId sess -> Set (SessionId sess) -> Set (SessionId sess)
forall a. Ord a => a -> Set a -> Set a
S.delete SessionId sess
sid) (AuthId -> AuthIdToSessionId sess -> Maybe (Set (SessionId sess))
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup AuthId
authId AuthIdToSessionId sess
aits)


-- | Insert the given session ID as being part of the given auth
-- ID.  Conceptually the opposite of 'removeSessionFromAuthId'.
-- Does not do anything if no 'AuthId' is provided.
insertSessionForAuthId
  :: SS.SessionId sess
  -> Maybe SS.AuthId
  -> AuthIdToSessionId sess
  -> AuthIdToSessionId sess
insertSessionForAuthId :: SessionId sess
-> Maybe AuthId -> AuthIdToSessionId sess -> AuthIdToSessionId sess
insertSessionForAuthId SessionId sess
sid = (AuthIdToSessionId sess -> AuthIdToSessionId sess)
-> (AuthId -> AuthIdToSessionId sess -> AuthIdToSessionId sess)
-> Maybe AuthId
-> AuthIdToSessionId sess
-> AuthIdToSessionId sess
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AuthIdToSessionId sess -> AuthIdToSessionId sess
forall a. a -> a
id ((AuthId
 -> Set (SessionId sess)
 -> AuthIdToSessionId sess
 -> AuthIdToSessionId sess)
-> Set (SessionId sess)
-> AuthId
-> AuthIdToSessionId sess
-> AuthIdToSessionId sess
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Set (SessionId sess)
 -> Set (SessionId sess) -> Set (SessionId sess))
-> AuthId
-> Set (SessionId sess)
-> AuthIdToSessionId sess
-> AuthIdToSessionId sess
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HM.insertWith Set (SessionId sess)
-> Set (SessionId sess) -> Set (SessionId sess)
forall a. Ord a => Set a -> Set a -> Set a
S.union) (SessionId sess -> Set (SessionId sess)
forall a. a -> Set a
S.singleton SessionId sess
sid))


----------------------------------------------------------------------


-- | We can't @deriveSafeCopy 0 'base ''SS.SessionMap@ because
-- @safeCopy@ doesn't contain instances for @HashMap@ as of now.
instance SafeCopy SS.SessionMap where
  putCopy :: SessionMap -> Contained Put
putCopy = Put -> Contained Put
forall a. a -> Contained a
contain (Put -> Contained Put)
-> (SessionMap -> Put) -> SessionMap -> Contained Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, AuthId)] -> Put
forall a. SafeCopy a => a -> Put
safePut ([(Text, AuthId)] -> Put)
-> (SessionMap -> [(Text, AuthId)]) -> SessionMap -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text AuthId -> [(Text, AuthId)]
forall k v. HashMap k v -> [(k, v)]
HM.toList (HashMap Text AuthId -> [(Text, AuthId)])
-> (SessionMap -> HashMap Text AuthId)
-> SessionMap
-> [(Text, AuthId)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionMap -> HashMap Text AuthId
SS.unSessionMap
  getCopy :: Contained (Get SessionMap)
getCopy = Get SessionMap -> Contained (Get SessionMap)
forall a. a -> Contained a
contain (Get SessionMap -> Contained (Get SessionMap))
-> Get SessionMap -> Contained (Get SessionMap)
forall a b. (a -> b) -> a -> b
$ HashMap Text AuthId -> SessionMap
SS.SessionMap (HashMap Text AuthId -> SessionMap)
-> ([(Text, AuthId)] -> HashMap Text AuthId)
-> [(Text, AuthId)]
-> SessionMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, AuthId)] -> HashMap Text AuthId
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, AuthId)] -> SessionMap)
-> Get [(Text, AuthId)] -> Get SessionMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> Get [(Text, AuthId)]
forall a. SafeCopy a => Get a
safeGet


-- | We can't @deriveSafeCopy 0 'base ''SS.SessionId@ as
-- otherwise we'd require an unneeded @SafeCopy sess@.
instance Typeable sess => SafeCopy (SS.SessionId sess) where
  putCopy :: SessionId sess -> Contained Put
putCopy = Put -> Contained Put
forall a. a -> Contained a
contain (Put -> Contained Put)
-> (SessionId sess -> Put) -> SessionId sess -> Contained Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Put
forall a. SafeCopy a => a -> Put
safePut (Text -> Put) -> (SessionId sess -> Text) -> SessionId sess -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionId sess -> Text
forall sess. SessionId sess -> Text
SSI.unS
  getCopy :: Contained (Get (SessionId sess))
getCopy = Get (SessionId sess) -> Contained (Get (SessionId sess))
forall a. a -> Contained a
contain (Get (SessionId sess) -> Contained (Get (SessionId sess)))
-> Get (SessionId sess) -> Contained (Get (SessionId sess))
forall a b. (a -> b) -> a -> b
$ Text -> SessionId sess
forall sess. Text -> SessionId sess
SSI.S (Text -> SessionId sess) -> Get Text -> Get (SessionId sess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Text
forall a. SafeCopy a => Get a
safeGet


-- | We can't @deriveSafeCopy 0 'base ''SS.Session@ due to the
-- required context.
instance (Typeable sess, SafeCopy (SS.Decomposed sess)) => SafeCopy (SS.Session sess) where
  putCopy :: Session sess -> Contained Put
putCopy (SS.Session SessionId sess
key Maybe AuthId
authId Decomposed sess
data_ UTCTime
createdAt UTCTime
accessedAt) = Put -> Contained Put
forall a. a -> Contained a
contain (Put -> Contained Put) -> Put -> Contained Put
forall a b. (a -> b) -> a -> b
$ do
    UTCTime -> Put
put_t <- PutM (UTCTime -> Put)
forall a. SafeCopy a => PutM (a -> Put)
getSafePut
    SessionId sess -> Put
forall a. SafeCopy a => a -> Put
safePut SessionId sess
key
    Maybe AuthId -> Put
forall a. SafeCopy a => a -> Put
safePut Maybe AuthId
authId
    Decomposed sess -> Put
forall a. SafeCopy a => a -> Put
safePut Decomposed sess
data_
    UTCTime -> Put
put_t UTCTime
createdAt
    UTCTime -> Put
put_t UTCTime
accessedAt
  getCopy :: Contained (Get (Session sess))
getCopy = Get (Session sess) -> Contained (Get (Session sess))
forall a. a -> Contained a
contain (Get (Session sess) -> Contained (Get (Session sess)))
-> Get (Session sess) -> Contained (Get (Session sess))
forall a b. (a -> b) -> a -> b
$ do
    Get UTCTime
get_t <- Get (Get UTCTime)
forall a. SafeCopy a => Get (Get a)
getSafeGet
    SessionId sess
-> Maybe AuthId
-> Decomposed sess
-> UTCTime
-> UTCTime
-> Session sess
forall sess.
SessionId sess
-> Maybe AuthId
-> Decomposed sess
-> UTCTime
-> UTCTime
-> Session sess
SS.Session
      (SessionId sess
 -> Maybe AuthId
 -> Decomposed sess
 -> UTCTime
 -> UTCTime
 -> Session sess)
-> Get (SessionId sess)
-> Get
     (Maybe AuthId
      -> Decomposed sess -> UTCTime -> UTCTime -> Session sess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (SessionId sess)
forall a. SafeCopy a => Get a
safeGet
      Get
  (Maybe AuthId
   -> Decomposed sess -> UTCTime -> UTCTime -> Session sess)
-> Get (Maybe AuthId)
-> Get (Decomposed sess -> UTCTime -> UTCTime -> Session sess)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (Maybe AuthId)
forall a. SafeCopy a => Get a
safeGet
      Get (Decomposed sess -> UTCTime -> UTCTime -> Session sess)
-> Get (Decomposed sess)
-> Get (UTCTime -> UTCTime -> Session sess)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (Decomposed sess)
forall a. SafeCopy a => Get a
safeGet
      Get (UTCTime -> UTCTime -> Session sess)
-> Get UTCTime -> Get (UTCTime -> Session sess)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get UTCTime
get_t
      Get (UTCTime -> Session sess) -> Get UTCTime -> Get (Session sess)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get UTCTime
get_t


-- | We can't @deriveSafeCopy 0 'base ''ServerSessionAcidState@ due
-- to the required context.
instance (Typeable sess, SafeCopy (SS.Decomposed sess)) => SafeCopy (ServerSessionAcidState sess) where
  putCopy :: ServerSessionAcidState sess -> Contained Put
putCopy (ServerSessionAcidState SessionIdToSession sess
sits AuthIdToSessionId sess
aits) = Put -> Contained Put
forall a. a -> Contained a
contain (Put -> Contained Put) -> Put -> Contained Put
forall a b. (a -> b) -> a -> b
$ do
    [(SessionId sess, Session sess)] -> Put
forall a. SafeCopy a => a -> Put
safePut (SessionIdToSession sess -> [(SessionId sess, Session sess)]
forall k v. HashMap k v -> [(k, v)]
HM.toList SessionIdToSession sess
sits)
    [(AuthId, Set (SessionId sess))] -> Put
forall a. SafeCopy a => a -> Put
safePut (AuthIdToSessionId sess -> [(AuthId, Set (SessionId sess))]
forall k v. HashMap k v -> [(k, v)]
HM.toList AuthIdToSessionId sess
aits)
  getCopy :: Contained (Get (ServerSessionAcidState sess))
getCopy = Get (ServerSessionAcidState sess)
-> Contained (Get (ServerSessionAcidState sess))
forall a. a -> Contained a
contain (Get (ServerSessionAcidState sess)
 -> Contained (Get (ServerSessionAcidState sess)))
-> Get (ServerSessionAcidState sess)
-> Contained (Get (ServerSessionAcidState sess))
forall a b. (a -> b) -> a -> b
$
    SessionIdToSession sess
-> AuthIdToSessionId sess -> ServerSessionAcidState sess
forall sess.
SessionIdToSession sess
-> AuthIdToSessionId sess -> ServerSessionAcidState sess
ServerSessionAcidState
      (SessionIdToSession sess
 -> AuthIdToSessionId sess -> ServerSessionAcidState sess)
-> Get (SessionIdToSession sess)
-> Get (AuthIdToSessionId sess -> ServerSessionAcidState sess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(SessionId sess, Session sess)] -> SessionIdToSession sess
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(SessionId sess, Session sess)] -> SessionIdToSession sess)
-> Get [(SessionId sess, Session sess)]
-> Get (SessionIdToSession sess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get [(SessionId sess, Session sess)]
forall a. SafeCopy a => Get a
safeGet)
      Get (AuthIdToSessionId sess -> ServerSessionAcidState sess)
-> Get (AuthIdToSessionId sess)
-> Get (ServerSessionAcidState sess)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([(AuthId, Set (SessionId sess))] -> AuthIdToSessionId sess
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(AuthId, Set (SessionId sess))] -> AuthIdToSessionId sess)
-> Get [(AuthId, Set (SessionId sess))]
-> Get (AuthIdToSessionId sess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get [(AuthId, Set (SessionId sess))]
forall a. SafeCopy a => Get a
safeGet)


----------------------------------------------------------------------


-- | Get the session for the given session ID.
getSession
  :: SS.Storage (AcidStorage sess)
  => SS.SessionId sess
  -> Query (ServerSessionAcidState sess) (Maybe (SS.Session sess))
getSession :: SessionId sess
-> Query (ServerSessionAcidState sess) (Maybe (Session sess))
getSession SessionId sess
sid = SessionId sess
-> HashMap (SessionId sess) (Session sess) -> Maybe (Session sess)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup SessionId sess
sid (HashMap (SessionId sess) (Session sess) -> Maybe (Session sess))
-> (ServerSessionAcidState sess
    -> HashMap (SessionId sess) (Session sess))
-> ServerSessionAcidState sess
-> Maybe (Session sess)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerSessionAcidState sess
-> HashMap (SessionId sess) (Session sess)
forall sess. ServerSessionAcidState sess -> SessionIdToSession sess
sessionIdToSession (ServerSessionAcidState sess -> Maybe (Session sess))
-> Query
     (ServerSessionAcidState sess) (ServerSessionAcidState sess)
-> Query (ServerSessionAcidState sess) (Maybe (Session sess))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Query (ServerSessionAcidState sess) (ServerSessionAcidState sess)
forall r (m :: * -> *). MonadReader r m => m r
ask


-- | Delete the session with given session ID.
deleteSession
  :: SS.Storage (AcidStorage sess)
  => SS.SessionId sess
  -> Update (ServerSessionAcidState sess) ()
deleteSession :: SessionId sess -> Update (ServerSessionAcidState sess) ()
deleteSession SessionId sess
sid =
  (ServerSessionAcidState sess -> ServerSessionAcidState sess)
-> Update (ServerSessionAcidState sess) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ServerSessionAcidState sess -> ServerSessionAcidState sess)
 -> Update (ServerSessionAcidState sess) ())
-> (ServerSessionAcidState sess -> ServerSessionAcidState sess)
-> Update (ServerSessionAcidState sess) ()
forall a b. (a -> b) -> a -> b
$ \ServerSessionAcidState sess
state ->
    let oldSession :: Maybe (Session sess)
oldSession            = SessionId sess
-> HashMap (SessionId sess) (Session sess) -> Maybe (Session sess)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup SessionId sess
sid (ServerSessionAcidState sess
-> HashMap (SessionId sess) (Session sess)
forall sess. ServerSessionAcidState sess -> SessionIdToSession sess
sessionIdToSession ServerSessionAcidState sess
state)
        newSessionIdToSession :: HashMap (SessionId sess) (Session sess)
newSessionIdToSession = SessionId sess
-> HashMap (SessionId sess) (Session sess)
-> HashMap (SessionId sess) (Session sess)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete SessionId sess
sid (ServerSessionAcidState sess
-> HashMap (SessionId sess) (Session sess)
forall sess. ServerSessionAcidState sess -> SessionIdToSession sess
sessionIdToSession ServerSessionAcidState sess
state)
        newAuthIdToSessionId :: AuthIdToSessionId sess
newAuthIdToSessionId  = SessionId sess
-> Maybe AuthId -> AuthIdToSessionId sess -> AuthIdToSessionId sess
forall sess.
SessionId sess
-> Maybe AuthId -> AuthIdToSessionId sess -> AuthIdToSessionId sess
removeSessionFromAuthId SessionId sess
sid Maybe AuthId
mauthId (AuthIdToSessionId sess -> AuthIdToSessionId sess)
-> AuthIdToSessionId sess -> AuthIdToSessionId sess
forall a b. (a -> b) -> a -> b
$ ServerSessionAcidState sess -> AuthIdToSessionId sess
forall sess. ServerSessionAcidState sess -> AuthIdToSessionId sess
authIdToSessionId ServerSessionAcidState sess
state
          where mauthId :: Maybe AuthId
mauthId = Maybe (Session sess)
oldSession Maybe (Session sess)
-> (Session sess -> Maybe AuthId) -> Maybe AuthId
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Session sess -> Maybe AuthId
forall sess. Session sess -> Maybe AuthId
SS.sessionAuthId
    in HashMap (SessionId sess) (Session sess)
-> AuthIdToSessionId sess -> ServerSessionAcidState sess
forall sess.
SessionIdToSession sess
-> AuthIdToSessionId sess -> ServerSessionAcidState sess
ServerSessionAcidState HashMap (SessionId sess) (Session sess)
newSessionIdToSession AuthIdToSessionId sess
newAuthIdToSessionId


-- | Delete all sessions of the given auth ID.
deleteAllSessionsOfAuthId
  :: SS.Storage (AcidStorage sess)
  => SS.AuthId
  -> Update (ServerSessionAcidState sess) ()
deleteAllSessionsOfAuthId :: AuthId -> Update (ServerSessionAcidState sess) ()
deleteAllSessionsOfAuthId AuthId
authId =
  (ServerSessionAcidState sess -> ServerSessionAcidState sess)
-> Update (ServerSessionAcidState sess) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ServerSessionAcidState sess -> ServerSessionAcidState sess)
 -> Update (ServerSessionAcidState sess) ())
-> (ServerSessionAcidState sess -> ServerSessionAcidState sess)
-> Update (ServerSessionAcidState sess) ()
forall a b. (a -> b) -> a -> b
$ \ServerSessionAcidState sess
state ->
    let sessionIds :: Maybe (Set (SessionId sess))
sessionIds            = AuthId
-> HashMap AuthId (Set (SessionId sess))
-> Maybe (Set (SessionId sess))
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup AuthId
authId (ServerSessionAcidState sess
-> HashMap AuthId (Set (SessionId sess))
forall sess. ServerSessionAcidState sess -> AuthIdToSessionId sess
authIdToSessionId ServerSessionAcidState sess
state)
        newAuthIdToSessionId :: HashMap AuthId (Set (SessionId sess))
newAuthIdToSessionId  = AuthId
-> HashMap AuthId (Set (SessionId sess))
-> HashMap AuthId (Set (SessionId sess))
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete AuthId
authId (ServerSessionAcidState sess
-> HashMap AuthId (Set (SessionId sess))
forall sess. ServerSessionAcidState sess -> AuthIdToSessionId sess
authIdToSessionId ServerSessionAcidState sess
state)
        newSessionIdToSession :: HashMap (SessionId sess) (Session sess)
newSessionIdToSession = (HashMap (SessionId sess) (Session sess)
 -> HashMap (SessionId sess) (Session sess))
-> (Set (SessionId sess)
    -> HashMap (SessionId sess) (Session sess)
    -> HashMap (SessionId sess) (Session sess))
-> Maybe (Set (SessionId sess))
-> HashMap (SessionId sess) (Session sess)
-> HashMap (SessionId sess) (Session sess)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HashMap (SessionId sess) (Session sess)
-> HashMap (SessionId sess) (Session sess)
forall a. a -> a
id Set (SessionId sess)
-> HashMap (SessionId sess) (Session sess)
-> HashMap (SessionId sess) (Session sess)
forall v.
Set (SessionId sess)
-> HashMap (SessionId sess) v -> HashMap (SessionId sess) v
removeSession Maybe (Set (SessionId sess))
sessionIds (HashMap (SessionId sess) (Session sess)
 -> HashMap (SessionId sess) (Session sess))
-> HashMap (SessionId sess) (Session sess)
-> HashMap (SessionId sess) (Session sess)
forall a b. (a -> b) -> a -> b
$ ServerSessionAcidState sess
-> HashMap (SessionId sess) (Session sess)
forall sess. ServerSessionAcidState sess -> SessionIdToSession sess
sessionIdToSession ServerSessionAcidState sess
state
          where removeSession :: Set (SessionId sess)
-> HashMap (SessionId sess) v -> HashMap (SessionId sess) v
removeSession = (HashMap (SessionId sess) v
 -> HashMap (SessionId sess) () -> HashMap (SessionId sess) v)
-> HashMap (SessionId sess) ()
-> HashMap (SessionId sess) v
-> HashMap (SessionId sess) v
forall a b c. (a -> b -> c) -> b -> a -> c
flip HashMap (SessionId sess) v
-> HashMap (SessionId sess) () -> HashMap (SessionId sess) v
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
HM.difference (HashMap (SessionId sess) ()
 -> HashMap (SessionId sess) v -> HashMap (SessionId sess) v)
-> (Set (SessionId sess) -> HashMap (SessionId sess) ())
-> Set (SessionId sess)
-> HashMap (SessionId sess) v
-> HashMap (SessionId sess) v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SessionId sess, ())] -> HashMap (SessionId sess) ()
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(SessionId sess, ())] -> HashMap (SessionId sess) ())
-> (Set (SessionId sess) -> [(SessionId sess, ())])
-> Set (SessionId sess)
-> HashMap (SessionId sess) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SessionId sess -> (SessionId sess, ()))
-> [SessionId sess] -> [(SessionId sess, ())]
forall a b. (a -> b) -> [a] -> [b]
map ((SessionId sess -> () -> (SessionId sess, ()))
-> () -> SessionId sess -> (SessionId sess, ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) ()) ([SessionId sess] -> [(SessionId sess, ())])
-> (Set (SessionId sess) -> [SessionId sess])
-> Set (SessionId sess)
-> [(SessionId sess, ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (SessionId sess) -> [SessionId sess]
forall a. Set a -> [a]
S.toList
    in HashMap (SessionId sess) (Session sess)
-> HashMap AuthId (Set (SessionId sess))
-> ServerSessionAcidState sess
forall sess.
SessionIdToSession sess
-> AuthIdToSessionId sess -> ServerSessionAcidState sess
ServerSessionAcidState HashMap (SessionId sess) (Session sess)
newSessionIdToSession HashMap AuthId (Set (SessionId sess))
newAuthIdToSessionId


-- | Insert a new session.
insertSession
  :: SS.Storage (AcidStorage sess)
  => SS.Session sess
  -> Update (ServerSessionAcidState sess) ()
insertSession :: Session sess -> Update (ServerSessionAcidState sess) ()
insertSession Session sess
session = do
  let insertSess :: HashMap (SessionId sess) (Session sess)
-> HashMap (SessionId sess) (Session sess)
insertSess HashMap (SessionId sess) (Session sess)
sits =
        case SessionId sess
-> HashMap (SessionId sess) (Session sess) -> Maybe (Session sess)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup SessionId sess
sid HashMap (SessionId sess) (Session sess)
sits of
          Maybe (Session sess)
Nothing  -> SessionId sess
-> Session sess
-> HashMap (SessionId sess) (Session sess)
-> HashMap (SessionId sess) (Session sess)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert SessionId sess
sid Session sess
session HashMap (SessionId sess) (Session sess)
sits
          Just Session sess
old -> StorageException (AcidStorage sess)
-> HashMap (SessionId sess) (Session sess)
forall sess a.
Storage (AcidStorage sess) =>
StorageException (AcidStorage sess) -> a
throwAS (StorageException (AcidStorage sess)
 -> HashMap (SessionId sess) (Session sess))
-> StorageException (AcidStorage sess)
-> HashMap (SessionId sess) (Session sess)
forall a b. (a -> b) -> a -> b
$ Session (SessionData (AcidStorage sess))
-> Session (SessionData (AcidStorage sess))
-> StorageException (AcidStorage sess)
forall sto.
Session (SessionData sto)
-> Session (SessionData sto) -> StorageException sto
SS.SessionAlreadyExists Session sess
Session (SessionData (AcidStorage sess))
old Session sess
Session (SessionData (AcidStorage sess))
session
      insertAuth :: AuthIdToSessionId sess -> AuthIdToSessionId sess
insertAuth = SessionId sess
-> Maybe AuthId -> AuthIdToSessionId sess -> AuthIdToSessionId sess
forall sess.
SessionId sess
-> Maybe AuthId -> AuthIdToSessionId sess -> AuthIdToSessionId sess
insertSessionForAuthId SessionId sess
sid (Session sess -> Maybe AuthId
forall sess. Session sess -> Maybe AuthId
SS.sessionAuthId Session sess
session)
      sid :: SessionId sess
sid        = Session sess -> SessionId sess
forall sess. Session sess -> SessionId sess
SS.sessionKey Session sess
session
  (ServerSessionAcidState sess -> ServerSessionAcidState sess)
-> Update (ServerSessionAcidState sess) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ServerSessionAcidState sess -> ServerSessionAcidState sess)
 -> Update (ServerSessionAcidState sess) ())
-> (ServerSessionAcidState sess -> ServerSessionAcidState sess)
-> Update (ServerSessionAcidState sess) ()
forall a b. (a -> b) -> a -> b
$ \ServerSessionAcidState sess
state ->
    HashMap (SessionId sess) (Session sess)
-> AuthIdToSessionId sess -> ServerSessionAcidState sess
forall sess.
SessionIdToSession sess
-> AuthIdToSessionId sess -> ServerSessionAcidState sess
ServerSessionAcidState
      (HashMap (SessionId sess) (Session sess)
-> HashMap (SessionId sess) (Session sess)
insertSess (HashMap (SessionId sess) (Session sess)
 -> HashMap (SessionId sess) (Session sess))
-> HashMap (SessionId sess) (Session sess)
-> HashMap (SessionId sess) (Session sess)
forall a b. (a -> b) -> a -> b
$ ServerSessionAcidState sess
-> HashMap (SessionId sess) (Session sess)
forall sess. ServerSessionAcidState sess -> SessionIdToSession sess
sessionIdToSession ServerSessionAcidState sess
state)
      (AuthIdToSessionId sess -> AuthIdToSessionId sess
insertAuth (AuthIdToSessionId sess -> AuthIdToSessionId sess)
-> AuthIdToSessionId sess -> AuthIdToSessionId sess
forall a b. (a -> b) -> a -> b
$ ServerSessionAcidState sess -> AuthIdToSessionId sess
forall sess. ServerSessionAcidState sess -> AuthIdToSessionId sess
authIdToSessionId  ServerSessionAcidState sess
state)


-- | Replace the contents of a session.
replaceSession
  :: SS.Storage (AcidStorage sess)
  => SS.Session sess
  -> Update (ServerSessionAcidState sess) ()
replaceSession :: Session sess -> Update (ServerSessionAcidState sess) ()
replaceSession Session sess
session = do
  -- Check that the old session exists while replacing it.
  ServerSessionAcidState SessionIdToSession sess
sits AuthIdToSessionId sess
aits <- Update (ServerSessionAcidState sess) (ServerSessionAcidState sess)
forall s (m :: * -> *). MonadState s m => m s
get
  let sid :: SessionId sess
sid = Session sess -> SessionId sess
forall sess. Session sess -> SessionId sess
SS.sessionKey Session sess
session
  case SessionId sess -> SessionIdToSession sess -> Maybe (Session sess)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup SessionId sess
sid SessionIdToSession sess
sits of
    Maybe (Session sess)
Nothing -> StorageException (AcidStorage sess)
-> Update (ServerSessionAcidState sess) ()
forall sess a.
Storage (AcidStorage sess) =>
StorageException (AcidStorage sess) -> a
throwAS (StorageException (AcidStorage sess)
 -> Update (ServerSessionAcidState sess) ())
-> StorageException (AcidStorage sess)
-> Update (ServerSessionAcidState sess) ()
forall a b. (a -> b) -> a -> b
$ Session (SessionData (AcidStorage sess))
-> StorageException (AcidStorage sess)
forall sto. Session (SessionData sto) -> StorageException sto
SS.SessionDoesNotExist Session sess
Session (SessionData (AcidStorage sess))
session
    Just Session sess
oldSession -> do
      -- Remove/insert the old auth ID from the map if needed.
      let modAits :: AuthIdToSessionId sess -> AuthIdToSessionId sess
modAits | Maybe AuthId
oldAuthId Maybe AuthId -> Maybe AuthId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe AuthId
newAuthId = AuthIdToSessionId sess -> AuthIdToSessionId sess
forall a. a -> a
id
                  | Bool
otherwise = SessionId sess
-> Maybe AuthId -> AuthIdToSessionId sess -> AuthIdToSessionId sess
forall sess.
SessionId sess
-> Maybe AuthId -> AuthIdToSessionId sess -> AuthIdToSessionId sess
insertSessionForAuthId SessionId sess
sid Maybe AuthId
newAuthId
                              (AuthIdToSessionId sess -> AuthIdToSessionId sess)
-> (AuthIdToSessionId sess -> AuthIdToSessionId sess)
-> AuthIdToSessionId sess
-> AuthIdToSessionId sess
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionId sess
-> Maybe AuthId -> AuthIdToSessionId sess -> AuthIdToSessionId sess
forall sess.
SessionId sess
-> Maybe AuthId -> AuthIdToSessionId sess -> AuthIdToSessionId sess
removeSessionFromAuthId SessionId sess
sid Maybe AuthId
oldAuthId
            where oldAuthId :: Maybe AuthId
oldAuthId = Session sess -> Maybe AuthId
forall sess. Session sess -> Maybe AuthId
SS.sessionAuthId Session sess
oldSession
                  newAuthId :: Maybe AuthId
newAuthId = Session sess -> Maybe AuthId
forall sess. Session sess -> Maybe AuthId
SS.sessionAuthId Session sess
session
          aits' :: AuthIdToSessionId sess
aits' = AuthIdToSessionId sess -> AuthIdToSessionId sess
modAits AuthIdToSessionId sess
aits
          sits' :: SessionIdToSession sess
sits' = SessionId sess
-> Session sess
-> SessionIdToSession sess
-> SessionIdToSession sess
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert SessionId sess
sid Session sess
session SessionIdToSession sess
sits
      -- Put modified state in place
      ServerSessionAcidState sess
-> Update (ServerSessionAcidState sess) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (SessionIdToSession sess
-> AuthIdToSessionId sess -> ServerSessionAcidState sess
forall sess.
SessionIdToSession sess
-> AuthIdToSessionId sess -> ServerSessionAcidState sess
ServerSessionAcidState SessionIdToSession sess
sits' AuthIdToSessionId sess
aits')


-- | Specialization of 'E.throw' for 'AcidStorage'.
throwAS
  :: SS.Storage (AcidStorage sess)
  => SS.StorageException (AcidStorage sess)
  -> a
throwAS :: StorageException (AcidStorage sess) -> a
throwAS = StorageException (AcidStorage sess) -> a
forall a e. Exception e => e -> a
E.throw


----------------------------------------------------------------------


-- | Session storage backend using @acid-state@.
newtype AcidStorage sess =
  AcidStorage
    { AcidStorage sess -> AcidState (ServerSessionAcidState sess)
acidState :: AcidState (ServerSessionAcidState sess)
      -- ^ Open 'AcidState' of server sessions.
    } deriving (Typeable)


-- | We do not provide any ACID guarantees for different actions
-- running inside the same @TransactionM AcidStorage@.
instance ( SS.IsSessionData sess
         , SafeCopy sess
         , SafeCopy (SS.Decomposed sess)
         ) => SS.Storage (AcidStorage sess) where
  type SessionData  (AcidStorage sess) = sess
  type TransactionM (AcidStorage sess) = IO
  runTransactionM :: AcidStorage sess -> TransactionM (AcidStorage sess) a -> IO a
runTransactionM = (IO a -> IO a) -> AcidStorage sess -> IO a -> IO a
forall a b. a -> b -> a
const IO a -> IO a
forall a. a -> a
id
  getSession :: AcidStorage sess
-> SessionId (SessionData (AcidStorage sess))
-> TransactionM
     (AcidStorage sess)
     (Maybe (Session (SessionData (AcidStorage sess))))
getSession                (AcidStorage AcidState (ServerSessionAcidState sess)
s) = AcidState (EventState (GetSession sess))
-> GetSession sess -> IO (EventResult (GetSession sess))
forall event.
QueryEvent event =>
AcidState (EventState event) -> event -> IO (EventResult event)
query  AcidState (EventState (GetSession sess))
AcidState (ServerSessionAcidState sess)
s (GetSession sess -> IO (Maybe (Session sess)))
-> (SessionId sess -> GetSession sess)
-> SessionId sess
-> IO (Maybe (Session sess))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionId sess -> GetSession sess
forall sess. SessionId sess -> GetSession sess
GetSession
  deleteSession :: AcidStorage sess
-> SessionId (SessionData (AcidStorage sess))
-> TransactionM (AcidStorage sess) ()
deleteSession             (AcidStorage AcidState (ServerSessionAcidState sess)
s) = AcidState (EventState (DeleteSession sess))
-> DeleteSession sess -> IO (EventResult (DeleteSession sess))
forall event.
UpdateEvent event =>
AcidState (EventState event) -> event -> IO (EventResult event)
update AcidState (EventState (DeleteSession sess))
AcidState (ServerSessionAcidState sess)
s (DeleteSession sess -> IO ())
-> (SessionId sess -> DeleteSession sess)
-> SessionId sess
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionId sess -> DeleteSession sess
forall sess. SessionId sess -> DeleteSession sess
DeleteSession
  deleteAllSessionsOfAuthId :: AcidStorage sess -> AuthId -> TransactionM (AcidStorage sess) ()
deleteAllSessionsOfAuthId (AcidStorage AcidState (ServerSessionAcidState sess)
s) = AcidState (EventState (DeleteAllSessionsOfAuthId sess))
-> DeleteAllSessionsOfAuthId sess
-> IO (EventResult (DeleteAllSessionsOfAuthId sess))
forall event.
UpdateEvent event =>
AcidState (EventState event) -> event -> IO (EventResult event)
update AcidState (EventState (DeleteAllSessionsOfAuthId sess))
AcidState (ServerSessionAcidState sess)
s (DeleteAllSessionsOfAuthId sess -> IO ())
-> (AuthId -> DeleteAllSessionsOfAuthId sess) -> AuthId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthId -> DeleteAllSessionsOfAuthId sess
forall sess. AuthId -> DeleteAllSessionsOfAuthId sess
DeleteAllSessionsOfAuthId
  insertSession :: AcidStorage sess
-> Session (SessionData (AcidStorage sess))
-> TransactionM (AcidStorage sess) ()
insertSession             (AcidStorage AcidState (ServerSessionAcidState sess)
s) = AcidState (EventState (InsertSession sess))
-> InsertSession sess -> IO (EventResult (InsertSession sess))
forall event.
UpdateEvent event =>
AcidState (EventState event) -> event -> IO (EventResult event)
update AcidState (EventState (InsertSession sess))
AcidState (ServerSessionAcidState sess)
s (InsertSession sess -> IO ())
-> (Session sess -> InsertSession sess) -> Session sess -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Session sess -> InsertSession sess
forall sess. Session sess -> InsertSession sess
InsertSession
  replaceSession :: AcidStorage sess
-> Session (SessionData (AcidStorage sess))
-> TransactionM (AcidStorage sess) ()
replaceSession            (AcidStorage AcidState (ServerSessionAcidState sess)
s) = AcidState (EventState (ReplaceSession sess))
-> ReplaceSession sess -> IO (EventResult (ReplaceSession sess))
forall event.
UpdateEvent event =>
AcidState (EventState event) -> event -> IO (EventResult event)
update AcidState (EventState (ReplaceSession sess))
AcidState (ServerSessionAcidState sess)
s (ReplaceSession sess -> IO ())
-> (Session sess -> ReplaceSession sess) -> Session sess -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Session sess -> ReplaceSession sess
forall sess. Session sess -> ReplaceSession sess
ReplaceSession


----------------------------------------------------------------------

-- makeAcidic can't handle type variables, so we have to do
-- everything by hand. :(

data GetSession sess = GetSession (SS.SessionId sess) deriving (Typeable)
data DeleteSession sess = DeleteSession (SS.SessionId sess) deriving (Typeable)
data DeleteAllSessionsOfAuthId sess = DeleteAllSessionsOfAuthId SS.AuthId deriving (Typeable)
data InsertSession sess = InsertSession (SS.Session sess) deriving (Typeable)
data ReplaceSession sess = ReplaceSession (SS.Session sess) deriving (Typeable)

instance Typeable sess => SafeCopy (GetSession sess) where
  putCopy :: GetSession sess -> Contained Put
putCopy (GetSession SessionId sess
v) = Put -> Contained Put
forall a. a -> Contained a
contain (Put -> Contained Put) -> Put -> Contained Put
forall a b. (a -> b) -> a -> b
$ SessionId sess -> Put
forall a. SafeCopy a => a -> Put
safePut SessionId sess
v
  getCopy :: Contained (Get (GetSession sess))
getCopy = Get (GetSession sess) -> Contained (Get (GetSession sess))
forall a. a -> Contained a
contain (Get (GetSession sess) -> Contained (Get (GetSession sess)))
-> Get (GetSession sess) -> Contained (Get (GetSession sess))
forall a b. (a -> b) -> a -> b
$ SessionId sess -> GetSession sess
forall sess. SessionId sess -> GetSession sess
GetSession (SessionId sess -> GetSession sess)
-> Get (SessionId sess) -> Get (GetSession sess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (SessionId sess)
forall a. SafeCopy a => Get a
safeGet

instance Typeable sess => SafeCopy (DeleteSession sess) where
  putCopy :: DeleteSession sess -> Contained Put
putCopy (DeleteSession SessionId sess
v) = Put -> Contained Put
forall a. a -> Contained a
contain (Put -> Contained Put) -> Put -> Contained Put
forall a b. (a -> b) -> a -> b
$ SessionId sess -> Put
forall a. SafeCopy a => a -> Put
safePut SessionId sess
v
  getCopy :: Contained (Get (DeleteSession sess))
getCopy = Get (DeleteSession sess) -> Contained (Get (DeleteSession sess))
forall a. a -> Contained a
contain (Get (DeleteSession sess) -> Contained (Get (DeleteSession sess)))
-> Get (DeleteSession sess) -> Contained (Get (DeleteSession sess))
forall a b. (a -> b) -> a -> b
$ SessionId sess -> DeleteSession sess
forall sess. SessionId sess -> DeleteSession sess
DeleteSession (SessionId sess -> DeleteSession sess)
-> Get (SessionId sess) -> Get (DeleteSession sess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (SessionId sess)
forall a. SafeCopy a => Get a
safeGet

instance Typeable sess => SafeCopy (DeleteAllSessionsOfAuthId sess) where
  putCopy :: DeleteAllSessionsOfAuthId sess -> Contained Put
putCopy (DeleteAllSessionsOfAuthId AuthId
v) = Put -> Contained Put
forall a. a -> Contained a
contain (Put -> Contained Put) -> Put -> Contained Put
forall a b. (a -> b) -> a -> b
$ AuthId -> Put
forall a. SafeCopy a => a -> Put
safePut AuthId
v
  getCopy :: Contained (Get (DeleteAllSessionsOfAuthId sess))
getCopy = Get (DeleteAllSessionsOfAuthId sess)
-> Contained (Get (DeleteAllSessionsOfAuthId sess))
forall a. a -> Contained a
contain (Get (DeleteAllSessionsOfAuthId sess)
 -> Contained (Get (DeleteAllSessionsOfAuthId sess)))
-> Get (DeleteAllSessionsOfAuthId sess)
-> Contained (Get (DeleteAllSessionsOfAuthId sess))
forall a b. (a -> b) -> a -> b
$ AuthId -> DeleteAllSessionsOfAuthId sess
forall sess. AuthId -> DeleteAllSessionsOfAuthId sess
DeleteAllSessionsOfAuthId (AuthId -> DeleteAllSessionsOfAuthId sess)
-> Get AuthId -> Get (DeleteAllSessionsOfAuthId sess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get AuthId
forall a. SafeCopy a => Get a
safeGet

instance (Typeable sess, SafeCopy (SS.Decomposed sess)) => SafeCopy (InsertSession sess) where
  putCopy :: InsertSession sess -> Contained Put
putCopy (InsertSession Session sess
v) = Put -> Contained Put
forall a. a -> Contained a
contain (Put -> Contained Put) -> Put -> Contained Put
forall a b. (a -> b) -> a -> b
$ Session sess -> Put
forall a. SafeCopy a => a -> Put
safePut Session sess
v
  getCopy :: Contained (Get (InsertSession sess))
getCopy = Get (InsertSession sess) -> Contained (Get (InsertSession sess))
forall a. a -> Contained a
contain (Get (InsertSession sess) -> Contained (Get (InsertSession sess)))
-> Get (InsertSession sess) -> Contained (Get (InsertSession sess))
forall a b. (a -> b) -> a -> b
$ Session sess -> InsertSession sess
forall sess. Session sess -> InsertSession sess
InsertSession (Session sess -> InsertSession sess)
-> Get (Session sess) -> Get (InsertSession sess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (Session sess)
forall a. SafeCopy a => Get a
safeGet

instance (Typeable sess, SafeCopy (SS.Decomposed sess)) => SafeCopy (ReplaceSession sess) where
  putCopy :: ReplaceSession sess -> Contained Put
putCopy (ReplaceSession Session sess
v) = Put -> Contained Put
forall a. a -> Contained a
contain (Put -> Contained Put) -> Put -> Contained Put
forall a b. (a -> b) -> a -> b
$ Session sess -> Put
forall a. SafeCopy a => a -> Put
safePut Session sess
v
  getCopy :: Contained (Get (ReplaceSession sess))
getCopy = Get (ReplaceSession sess) -> Contained (Get (ReplaceSession sess))
forall a. a -> Contained a
contain (Get (ReplaceSession sess)
 -> Contained (Get (ReplaceSession sess)))
-> Get (ReplaceSession sess)
-> Contained (Get (ReplaceSession sess))
forall a b. (a -> b) -> a -> b
$ Session sess -> ReplaceSession sess
forall sess. Session sess -> ReplaceSession sess
ReplaceSession (Session sess -> ReplaceSession sess)
-> Get (Session sess) -> Get (ReplaceSession sess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (Session sess)
forall a. SafeCopy a => Get a
safeGet

type AcidContext sess =
  ( SS.IsSessionData sess
  , SafeCopy sess
  , SafeCopy (SS.Decomposed sess) )

instance AcidContext sess => QueryEvent  (GetSession sess)
instance AcidContext sess => UpdateEvent (DeleteSession sess)
instance AcidContext sess => UpdateEvent (DeleteAllSessionsOfAuthId sess)
instance AcidContext sess => UpdateEvent (InsertSession sess)
instance AcidContext sess => UpdateEvent (ReplaceSession sess)

instance AcidContext sess => Method (GetSession sess) where
  type MethodResult (GetSession sess) = Maybe (SS.Session sess)
  type MethodState (GetSession sess) = ServerSessionAcidState sess
instance AcidContext sess => Method (DeleteSession sess) where
  type MethodResult (DeleteSession sess) = ()
  type MethodState (DeleteSession sess) = ServerSessionAcidState sess
instance AcidContext sess => Method (DeleteAllSessionsOfAuthId sess) where
  type MethodResult (DeleteAllSessionsOfAuthId sess) = ()
  type MethodState (DeleteAllSessionsOfAuthId sess) = ServerSessionAcidState sess
instance AcidContext sess => Method (InsertSession sess) where
  type MethodResult (InsertSession sess) = ()
  type MethodState (InsertSession sess) = ServerSessionAcidState sess
instance AcidContext sess => Method (ReplaceSession sess) where
  type MethodResult (ReplaceSession sess) = ()
  type MethodState (ReplaceSession sess) = ServerSessionAcidState sess

instance AcidContext sess => IsAcidic (ServerSessionAcidState sess) where
  acidEvents :: [Event (ServerSessionAcidState sess)]
acidEvents =
    [ (GetSession sess
 -> Query
      (EventState (GetSession sess)) (EventResult (GetSession sess)))
-> MethodSerialiser (GetSession sess)
-> Event (EventState (GetSession sess))
forall ev.
QueryEvent ev =>
(ev -> Query (EventState ev) (EventResult ev))
-> MethodSerialiser ev -> Event (EventState ev)
QueryEvent  (\(GetSession SessionId sess
sid)                   -> SessionId sess
-> Query (ServerSessionAcidState sess) (Maybe (Session sess))
forall sess.
Storage (AcidStorage sess) =>
SessionId sess
-> Query (ServerSessionAcidState sess) (Maybe (Session sess))
getSession SessionId sess
sid) MethodSerialiser (GetSession sess)
forall method.
(SafeCopy method, SafeCopy (MethodResult method)) =>
MethodSerialiser method
safeCopyMethodSerialiser
    , (DeleteSession sess
 -> Update
      (EventState (DeleteSession sess))
      (EventResult (DeleteSession sess)))
-> MethodSerialiser (DeleteSession sess)
-> Event (EventState (DeleteSession sess))
forall ev.
UpdateEvent ev =>
(ev -> Update (EventState ev) (EventResult ev))
-> MethodSerialiser ev -> Event (EventState ev)
UpdateEvent (\(DeleteSession SessionId sess
sid)                -> SessionId sess -> Update (ServerSessionAcidState sess) ()
forall sess.
Storage (AcidStorage sess) =>
SessionId sess -> Update (ServerSessionAcidState sess) ()
deleteSession SessionId sess
sid) MethodSerialiser (DeleteSession sess)
forall method.
(SafeCopy method, SafeCopy (MethodResult method)) =>
MethodSerialiser method
safeCopyMethodSerialiser
    , (DeleteAllSessionsOfAuthId sess
 -> Update
      (EventState (DeleteAllSessionsOfAuthId sess))
      (EventResult (DeleteAllSessionsOfAuthId sess)))
-> MethodSerialiser (DeleteAllSessionsOfAuthId sess)
-> Event (EventState (DeleteAllSessionsOfAuthId sess))
forall ev.
UpdateEvent ev =>
(ev -> Update (EventState ev) (EventResult ev))
-> MethodSerialiser ev -> Event (EventState ev)
UpdateEvent (\(DeleteAllSessionsOfAuthId AuthId
authId) -> AuthId -> Update (ServerSessionAcidState sess) ()
forall sess.
Storage (AcidStorage sess) =>
AuthId -> Update (ServerSessionAcidState sess) ()
deleteAllSessionsOfAuthId AuthId
authId) MethodSerialiser (DeleteAllSessionsOfAuthId sess)
forall method.
(SafeCopy method, SafeCopy (MethodResult method)) =>
MethodSerialiser method
safeCopyMethodSerialiser
    , (InsertSession sess
 -> Update
      (EventState (InsertSession sess))
      (EventResult (InsertSession sess)))
-> MethodSerialiser (InsertSession sess)
-> Event (EventState (InsertSession sess))
forall ev.
UpdateEvent ev =>
(ev -> Update (EventState ev) (EventResult ev))
-> MethodSerialiser ev -> Event (EventState ev)
UpdateEvent (\(InsertSession Session sess
session)            -> Session sess -> Update (ServerSessionAcidState sess) ()
forall sess.
Storage (AcidStorage sess) =>
Session sess -> Update (ServerSessionAcidState sess) ()
insertSession Session sess
session) MethodSerialiser (InsertSession sess)
forall method.
(SafeCopy method, SafeCopy (MethodResult method)) =>
MethodSerialiser method
safeCopyMethodSerialiser
    , (ReplaceSession sess
 -> Update
      (EventState (ReplaceSession sess))
      (EventResult (ReplaceSession sess)))
-> MethodSerialiser (ReplaceSession sess)
-> Event (EventState (ReplaceSession sess))
forall ev.
UpdateEvent ev =>
(ev -> Update (EventState ev) (EventResult ev))
-> MethodSerialiser ev -> Event (EventState ev)
UpdateEvent (\(ReplaceSession Session sess
session)           -> Session sess -> Update (ServerSessionAcidState sess) ()
forall sess.
Storage (AcidStorage sess) =>
Session sess -> Update (ServerSessionAcidState sess) ()
replaceSession Session sess
session) MethodSerialiser (ReplaceSession sess)
forall method.
(SafeCopy method, SafeCopy (MethodResult method)) =>
MethodSerialiser method
safeCopyMethodSerialiser ]