From bac54a5c7044a8cb8573985b74758bb3520cae31 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Mon, 25 May 2015 21:31:47 -0300 Subject: [PATCH] New serversession-backend-acid-state package. --- serversession-backend-acid-state/LICENSE | 20 +++ serversession-backend-acid-state/README.md | 6 + .../serversession-backend-acid-state.cabal | 37 ++++ .../src/Web/ServerSession/Backend/Acid.hs | 20 +++ .../ServerSession/Backend/Acid/Internal.hs | 165 ++++++++++++++++++ 5 files changed, 248 insertions(+) create mode 100644 serversession-backend-acid-state/LICENSE create mode 100644 serversession-backend-acid-state/README.md create mode 100644 serversession-backend-acid-state/serversession-backend-acid-state.cabal create mode 100644 serversession-backend-acid-state/src/Web/ServerSession/Backend/Acid.hs create mode 100644 serversession-backend-acid-state/src/Web/ServerSession/Backend/Acid/Internal.hs diff --git a/serversession-backend-acid-state/LICENSE b/serversession-backend-acid-state/LICENSE new file mode 100644 index 0000000..cdf4661 --- /dev/null +++ b/serversession-backend-acid-state/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Felipe Lessa + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/serversession-backend-acid-state/README.md b/serversession-backend-acid-state/README.md new file mode 100644 index 0000000..d1b49bb --- /dev/null +++ b/serversession-backend-acid-state/README.md @@ -0,0 +1,6 @@ +# serversession-backend-acid-state + +This is the storage backend for `serversession` using +`acid-state`. Please +[read the main README file](https://github.com/yesodweb/serversession/blob/master/README.md) +for general information about the serversession packages. diff --git a/serversession-backend-acid-state/serversession-backend-acid-state.cabal b/serversession-backend-acid-state/serversession-backend-acid-state.cabal new file mode 100644 index 0000000..d2fd050 --- /dev/null +++ b/serversession-backend-acid-state/serversession-backend-acid-state.cabal @@ -0,0 +1,37 @@ +name: serversession-backend-acid-state +version: 1.0 +license: MIT +license-file: LICENSE +author: Felipe Lessa +maintainer: Felipe Lessa +synopsis: Storage backend for serversession using acid-state. +category: Web +stability: Stable +cabal-version: >= 1.8 +build-type: Simple +homepage: https://github.com/yesodweb/serversession +description: API docs and the README are available at +extra-source-files: README.md + +library + hs-source-dirs: src + build-depends: + base == 4.* + , acid-state == 0.12.* + , containers + , mtl + , safecopy == 0.8.* + + , serversession == 1.0.* + exposed-modules: + Web.ServerSession.Backend.Acid + Web.ServerSession.Backend.Acid.Internal + extensions: + DeriveDataTypeable + TemplateHaskell + TypeFamilies + ghc-options: -Wall + +source-repository head + type: git + location: https://github.com/yesodweb/serversession diff --git a/serversession-backend-acid-state/src/Web/ServerSession/Backend/Acid.hs b/serversession-backend-acid-state/src/Web/ServerSession/Backend/Acid.hs new file mode 100644 index 0000000..d722e18 --- /dev/null +++ b/serversession-backend-acid-state/src/Web/ServerSession/Backend/Acid.hs @@ -0,0 +1,20 @@ +-- | Storage backend for @serversession@ using @acid-state@. +-- +-- In order to use this backend, just open the 'AcidState'. For +-- example: +-- +-- @ +-- import Data.Acid +-- import Web.ServerSession.Backend.Acid +-- +-- makeSessionStorage :: IO 'AcidStorage' +-- makeSessionStorage = +-- 'AcidStorage' \<$\> openLocalState 'emptyState' +-- @ +module Web.ServerSession.Backend.Acid + ( AcidStorage(..) + , emptyState + , ServerSessionAcidState + ) where + +import Web.ServerSession.Backend.Acid.Internal diff --git a/serversession-backend-acid-state/src/Web/ServerSession/Backend/Acid/Internal.hs b/serversession-backend-acid-state/src/Web/ServerSession/Backend/Acid/Internal.hs new file mode 100644 index 0000000..b9de44c --- /dev/null +++ b/serversession-backend-acid-state/src/Web/ServerSession/Backend/Acid/Internal.hs @@ -0,0 +1,165 @@ +-- | 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 + , nothingfy + + , getSession + , deleteSession + , deleteAllSessionsOfAuthId + , insertSession + , replaceSession + + , GetSession + , DeleteSession + , DeleteAllSessionsOfAuthId + , InsertSession + , ReplaceSession + + , AcidStorage(..) + ) where + +import Control.Monad (when) +import Control.Monad.Reader (ask) +import Control.Monad.State (get, modify') +import Data.Acid (AcidState, Query, Update, makeAcidic, query, update) +import Data.SafeCopy (deriveSafeCopy, base) +import Data.Typeable (Typeable) + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified Web.ServerSession.Core as SS + + +---------------------------------------------------------------------- + + +-- | Map from session IDs to sessions. The most important map, +-- allowing us efficient access to a session given its ID. +type SessionIdToSession = M.Map SS.SessionId SS.Session + + +-- | 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 = M.Map SS.AuthId (S.Set SS.SessionId) + + +-- | 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 = + ServerSessionAcidState + { sessionIdToSession :: !SessionIdToSession + , authIdToSessionId :: !AuthIdToSessionId + } deriving (Show, Typeable) + +deriveSafeCopy 0 'base ''SS.SessionId -- dangerous! +deriveSafeCopy 0 'base ''SS.Session -- dangerous! +deriveSafeCopy 0 'base ''ServerSessionAcidState + + +-- | Empty 'ServerSessionAcidState' used to bootstrap the 'AcidState'. +emptyState :: ServerSessionAcidState +emptyState = ServerSessionAcidState M.empty M.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 -> Maybe SS.AuthId -> AuthIdToSessionId -> AuthIdToSessionId +removeSessionFromAuthId sid = maybe id (M.update (nothingfy . S.delete sid)) + + +-- | Change a 'S.Set' to 'Nothing' if it's 'S.null'. +nothingfy :: S.Set a -> Maybe (S.Set a) +nothingfy s = if S.null s then Nothing else Just s + + +---------------------------------------------------------------------- + + +-- | Get the session for the given session ID. +getSession :: SS.SessionId -> Query ServerSessionAcidState (Maybe SS.Session) +getSession sid = M.lookup sid . sessionIdToSession <$> ask + + +-- | Delete the session with given session ID. +deleteSession :: SS.SessionId -> Update ServerSessionAcidState () +deleteSession sid = do + let removeSession = M.updateLookupWithKey (\_ _ -> Nothing) sid + modify' $ \state -> + let (oldSession, newSessionIdToSession) = removeSession $ sessionIdToSession state + newAuthIdToSessionId = removeSessionFromAuthId sid mauthId $ authIdToSessionId state + where mauthId = oldSession >>= SS.sessionAuthId + in ServerSessionAcidState newSessionIdToSession newAuthIdToSessionId + + +-- | Delete all sessions of the given auth ID. +deleteAllSessionsOfAuthId :: SS.AuthId -> Update ServerSessionAcidState () +deleteAllSessionsOfAuthId authId = do + let removeSession = maybe id (flip M.difference . M.fromSet (const ())) + removeAuth = M.updateLookupWithKey (\_ _ -> Nothing) authId + modify' $ \state -> + let (sessionIds, newAuthIdToSessionId) = removeAuth $ authIdToSessionId state + newSessionIdToSession = removeSession sessionIds $ sessionIdToSession state + in ServerSessionAcidState newSessionIdToSession newAuthIdToSessionId + + +-- | Insert a new session. +insertSession :: SS.Session -> Update ServerSessionAcidState () +insertSession session = do + let insertSess = M.insert sid session + insertAuth = maybe id (flip (M.insertWith S.union) (S.singleton sid)) (SS.sessionAuthId session) + sid = SS.sessionKey session + modify' $ \state -> + ServerSessionAcidState + (insertSess $ sessionIdToSession state) + (insertAuth $ authIdToSessionId state) + + +-- | Replace the contents of a session. +replaceSession :: SS.Session -> Update ServerSessionAcidState () +replaceSession session = do + -- Remove the old auth ID from the map if it has changed. + let sid = SS.sessionKey session + oldSession <- M.lookup sid . sessionIdToSession <$> get + let oldAuthId = SS.sessionAuthId =<< oldSession + when (oldAuthId /= SS.sessionAuthId session) $ + modify' $ \state -> state + { authIdToSessionId = removeSessionFromAuthId sid oldAuthId $ authIdToSessionId state + } + -- Otherwise the operation is the same as inserting. + insertSession session + + +---------------------------------------------------------------------- + + +makeAcidic ''ServerSessionAcidState ['getSession, 'deleteSession, 'deleteAllSessionsOfAuthId, 'insertSession, 'replaceSession] + + +-- | Session storage backend using @acid-state@. +newtype AcidStorage = + AcidStorage + { acidState :: AcidState ServerSessionAcidState + -- ^ 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.Storage AcidStorage where + type TransactionM AcidStorage = 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