serversession-backend-acid-state (empty) → 1.0
raw patch · 7 files changed
+470/−0 lines, 7 filesdep +acid-statedep +basedep +containerssetup-changed
Dependencies added: acid-state, base, containers, hspec, mtl, safecopy, serversession, serversession-backend-acid-state, unordered-containers
Files
- LICENSE +20/−0
- README.md +6/−0
- Setup.lhs +7/−0
- serversession-backend-acid-state.cabal +58/−0
- src/Web/ServerSession/Backend/Acid.hs +23/−0
- src/Web/ServerSession/Backend/Acid/Internal.hs +328/−0
- tests/Main.hs +28/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ serversession-backend-acid-state.cabal view
@@ -0,0 +1,58 @@+name: serversession-backend-acid-state+version: 1.0+license: MIT+license-file: LICENSE+author: Felipe Lessa <felipe.lessa@gmail.com>+maintainer: Felipe Lessa <felipe.lessa@gmail.com>+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 <http://www.stackage.org/package/serversession-backend-acid-state>+extra-source-files: README.md++library+ hs-source-dirs: src+ build-depends:+ base == 4.*+ , acid-state == 0.12.*+ , containers+ , mtl+ , safecopy == 0.8.*+ , unordered-containers++ , serversession == 1.0.*+ exposed-modules:+ Web.ServerSession.Backend.Acid+ Web.ServerSession.Backend.Acid.Internal+ extensions:+ ConstraintKinds+ DeriveDataTypeable+ FlexibleContexts+ TemplateHaskell+ TypeFamilies+ UndecidableInstances+ ghc-options: -Wall+++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ build-depends:+ base, acid-state, containers, mtl, safecopy, unordered-containers++ , hspec >= 2.1 && < 3++ , serversession+ , serversession-backend-acid-state+ main-is: Main.hs+ extensions:+ CPP+ ghc-options: -Wall -threaded "-with-rtsopts=-N -s -M1G -c" -rtsopts+++source-repository head+ type: git+ location: https://github.com/yesodweb/serversession
+ src/Web/ServerSession/Backend/Acid.hs view
@@ -0,0 +1,23 @@+-- | Storage backend for @serversession@ using @acid-state@.+--+-- In order to use this backend, just open the 'AcidState'. For+-- example:+--+-- @+-- import Control.Exception (bracket)+-- import Data.Acid.Local (openLocalState, createCheckpointAndClose)+-- import Web.ServerSession.Backend.Acid (AcidStorage(..), emptyState)+--+-- withSessionStorage :: (AcidStorage -> IO a) -> IO a+-- withSessionStorage =+-- bracket+-- ('AcidStorage' \<$\> openLocalState 'emptyState')+-- (createCheckpointAndClose . 'acidState')+-- @+module Web.ServerSession.Backend.Acid+ ( AcidStorage(..)+ , emptyState+ , ServerSessionAcidState+ ) where++import Web.ServerSession.Backend.Acid.Internal
+ src/Web/ServerSession/Backend/Acid/Internal.hs view
@@ -0,0 +1,328 @@+-- | 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 ((<$>), (<*>))+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+ { sessionIdToSession :: !(SessionIdToSession sess)+ , authIdToSessionId :: !(AuthIdToSessionId sess)+ } deriving (Typeable)+++-- | Empty 'ServerSessionAcidState' used to bootstrap the 'AcidState'.+emptyState :: ServerSessionAcidState sess+emptyState = ServerSessionAcidState HM.empty 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 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)+++-- | 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 sid = maybe id (flip (HM.insertWith S.union) (S.singleton 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 = contain . safePut . HM.toList . SS.unSessionMap+ getCopy = contain $ SS.SessionMap . HM.fromList <$> safeGet+++-- | We can't @deriveSafeCopy 0 'base ''SS.SessionId@ as+-- otherwise we'd require an unneeded @SafeCopy sess@.+instance SafeCopy (SS.SessionId sess) where+ putCopy = contain . safePut . SSI.unS+ getCopy = contain $ SSI.S <$> safeGet+++-- | We can't @deriveSafeCopy 0 'base ''SS.Session@ due to the+-- required context.+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+++-- | We can't @deriveSafeCopy 0 'base ''ServerSessionAcidState@ due+-- to the required context.+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)+++----------------------------------------------------------------------+++-- | Get the session for the given session ID.+getSession+ :: SS.Storage (AcidStorage sess)+ => SS.SessionId sess+ -> Query (ServerSessionAcidState sess) (Maybe (SS.Session sess))+getSession sid = HM.lookup sid . sessionIdToSession <$> ask+++-- | Delete the session with given session ID.+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+++-- | Delete all sessions of the given auth ID.+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+++-- | Insert a new session.+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)+++-- | Replace the contents of a session.+replaceSession+ :: SS.Storage (AcidStorage sess)+ => SS.Session sess+ -> Update (ServerSessionAcidState sess) ()+replaceSession session = do+ -- Check that the old session exists while replacing it.+ ServerSessionAcidState sits aits <- get+ let sid = SS.sessionKey session+ case HM.lookup sid sits of+ Nothing -> throwAS $ SS.SessionDoesNotExist session+ Just oldSession -> do+ -- Remove/insert the old auth ID from the map if needed.+ 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 modified state in place+ put (ServerSessionAcidState sits' aits')+++-- | Specialization of 'E.throw' for 'AcidStorage'.+throwAS+ :: SS.Storage (AcidStorage sess)+ => SS.StorageException (AcidStorage sess)+ -> a+throwAS = E.throw+++----------------------------------------------------------------------+++-- | Session storage backend using @acid-state@.+newtype AcidStorage sess =+ AcidStorage+ { 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 = 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+++----------------------------------------------------------------------++-- 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 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 ]
+ tests/Main.hs view
@@ -0,0 +1,28 @@+module Main (main) where++import Control.Applicative ((<$>))+import Data.Acid.Local (openLocalState, createCheckpointAndClose)+import Data.Acid.Memory (openMemoryState)+import Test.Hspec+import Web.ServerSession.Backend.Acid+import Web.ServerSession.Core.StorageTests++import qualified Control.Exception as E++main :: IO ()+main =+ E.bracket+ (AcidStorage <$> openLocalState emptyState)+ (createCheckpointAndClose . acidState) $+ \acidLocal -> hspec $ do+ acidMem <- runIO $ AcidStorage <$> openMemoryState emptyState+ describe "AcidStorage on memory only" $+ allStorageTests acidMem it runIO parallel shouldBe shouldReturn shouldThrow+ describe "AcidStorage on local storage" $+#if MIN_VERSION_base(4,8,0)+ allStorageTests acidLocal it runIO parallel shouldBe shouldReturn shouldThrow+#else+ it "is not tested on GHC < 7.10.1" $ do+ let _ = acidMem `asTypeOf` acidLocal+ pendingWith "<https://github.com/acid-state/acid-state/issues/55>"+#endif