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 ((<$>), (<*>))
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
type SessionIdToSession sess = HM.HashMap (SS.SessionId sess) (SS.Session sess)
type AuthIdToSessionId sess = HM.HashMap SS.AuthId (S.Set (SS.SessionId sess))
data ServerSessionAcidState sess =
ServerSessionAcidState
{ sessionIdToSession :: !(SessionIdToSession sess)
, authIdToSessionId :: !(AuthIdToSessionId sess)
} deriving (Typeable)
emptyState :: ServerSessionAcidState sess
emptyState = ServerSessionAcidState HM.empty HM.empty
removeSessionFromAuthId
:: SS.SessionId sess
-> Maybe SS.AuthId
-> AuthIdToSessionId sess
-> AuthIdToSessionId sess
removeSessionFromAuthId sid = maybe id removeIt
where
removeIt authId aits
| S.null newSet = HM.delete authId aits
| otherwise = HM.insert authId newSet aits
where newSet = maybe S.empty (S.delete sid) (HM.lookup authId aits)
insertSessionForAuthId
:: SS.SessionId sess
-> Maybe SS.AuthId
-> AuthIdToSessionId sess
-> AuthIdToSessionId sess
insertSessionForAuthId sid = maybe id (flip (HM.insertWith S.union) (S.singleton sid))
instance SafeCopy SS.SessionMap where
putCopy = contain . safePut . HM.toList . SS.unSessionMap
getCopy = contain $ SS.SessionMap . HM.fromList <$> safeGet
instance SafeCopy (SS.SessionId sess) where
putCopy = contain . safePut . SSI.unS
getCopy = contain $ SSI.S <$> safeGet
instance SafeCopy (SS.Decomposed sess) => SafeCopy (SS.Session sess) where
putCopy (SS.Session key authId data_ createdAt accessedAt) = contain $ do
put_t <- getSafePut
safePut key
safePut authId
safePut data_
put_t createdAt
put_t accessedAt
getCopy = contain $ do
get_t <- getSafeGet
SS.Session
<$> safeGet
<*> safeGet
<*> safeGet
<*> get_t
<*> get_t
instance SafeCopy (SS.Decomposed sess) => SafeCopy (ServerSessionAcidState sess) where
putCopy (ServerSessionAcidState sits aits) = contain $ do
safePut (HM.toList sits)
safePut (HM.toList aits)
getCopy = contain $
ServerSessionAcidState
<$> (HM.fromList <$> safeGet)
<*> (HM.fromList <$> safeGet)
getSession
:: SS.Storage (AcidStorage sess)
=> SS.SessionId sess
-> Query (ServerSessionAcidState sess) (Maybe (SS.Session sess))
getSession sid = HM.lookup sid . sessionIdToSession <$> ask
deleteSession
:: SS.Storage (AcidStorage sess)
=> SS.SessionId sess
-> Update (ServerSessionAcidState sess) ()
deleteSession sid =
modify $ \state ->
let oldSession = HM.lookup sid (sessionIdToSession state)
newSessionIdToSession = HM.delete sid (sessionIdToSession state)
newAuthIdToSessionId = removeSessionFromAuthId sid mauthId $ authIdToSessionId state
where mauthId = oldSession >>= SS.sessionAuthId
in ServerSessionAcidState newSessionIdToSession newAuthIdToSessionId
deleteAllSessionsOfAuthId
:: SS.Storage (AcidStorage sess)
=> SS.AuthId
-> Update (ServerSessionAcidState sess) ()
deleteAllSessionsOfAuthId authId =
modify $ \state ->
let sessionIds = HM.lookup authId (authIdToSessionId state)
newAuthIdToSessionId = HM.delete authId (authIdToSessionId state)
newSessionIdToSession = maybe id removeSession sessionIds $ sessionIdToSession state
where removeSession = flip HM.difference . HM.fromList . map (flip (,) ()) . S.toList
in ServerSessionAcidState newSessionIdToSession newAuthIdToSessionId
insertSession
:: SS.Storage (AcidStorage sess)
=> SS.Session sess
-> Update (ServerSessionAcidState sess) ()
insertSession session = do
let insertSess sits =
case HM.lookup sid sits of
Nothing -> HM.insert sid session sits
Just old -> throwAS $ SS.SessionAlreadyExists old session
insertAuth = insertSessionForAuthId sid (SS.sessionAuthId session)
sid = SS.sessionKey session
modify $ \state ->
ServerSessionAcidState
(insertSess $ sessionIdToSession state)
(insertAuth $ authIdToSessionId state)
replaceSession
:: SS.Storage (AcidStorage sess)
=> SS.Session sess
-> Update (ServerSessionAcidState sess) ()
replaceSession session = do
ServerSessionAcidState sits aits <- get
let sid = SS.sessionKey session
case HM.lookup sid sits of
Nothing -> throwAS $ SS.SessionDoesNotExist session
Just oldSession -> do
let modAits | oldAuthId == newAuthId = id
| otherwise = insertSessionForAuthId sid newAuthId
. removeSessionFromAuthId sid oldAuthId
where oldAuthId = SS.sessionAuthId oldSession
newAuthId = SS.sessionAuthId session
aits' = modAits aits
sits' = HM.insert sid session sits
put (ServerSessionAcidState sits' aits')
throwAS
:: SS.Storage (AcidStorage sess)
=> SS.StorageException (AcidStorage sess)
-> a
throwAS = E.throw
newtype AcidStorage sess =
AcidStorage
{ acidState :: AcidState (ServerSessionAcidState sess)
} deriving (Typeable)
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 = const id
getSession (AcidStorage s) = query s . GetSession
deleteSession (AcidStorage s) = update s . DeleteSession
deleteAllSessionsOfAuthId (AcidStorage s) = update s . DeleteAllSessionsOfAuthId
insertSession (AcidStorage s) = update s . InsertSession
replaceSession (AcidStorage s) = update s . ReplaceSession
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 SafeCopy (GetSession sess) where
putCopy (GetSession v) = contain $ safePut v
getCopy = contain $ GetSession <$> safeGet
instance SafeCopy (DeleteSession sess) where
putCopy (DeleteSession v) = contain $ safePut v
getCopy = contain $ DeleteSession <$> safeGet
instance SafeCopy (DeleteAllSessionsOfAuthId sess) where
putCopy (DeleteAllSessionsOfAuthId v) = contain $ safePut v
getCopy = contain $ DeleteAllSessionsOfAuthId <$> safeGet
instance SafeCopy (SS.Decomposed sess) => SafeCopy (InsertSession sess) where
putCopy (InsertSession v) = contain $ safePut v
getCopy = contain $ InsertSession <$> safeGet
instance SafeCopy (SS.Decomposed sess) => SafeCopy (ReplaceSession sess) where
putCopy (ReplaceSession v) = contain $ safePut v
getCopy = contain $ ReplaceSession <$> 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 =
[ QueryEvent $ \(GetSession sid) -> getSession sid
, UpdateEvent $ \(DeleteSession sid) -> deleteSession sid
, UpdateEvent $ \(DeleteAllSessionsOfAuthId authId) -> deleteAllSessionsOfAuthId authId
, UpdateEvent $ \(InsertSession session) -> insertSession session
, UpdateEvent $ \(ReplaceSession session) -> replaceSession session ]