diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/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/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/serversession-backend-acid-state.cabal b/serversession-backend-acid-state.cabal new file mode 100644 --- /dev/null +++ b/serversession-backend-acid-state.cabal @@ -0,0 +1,58 @@ +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.* + , 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 diff --git a/src/Web/ServerSession/Backend/Acid.hs b/src/Web/ServerSession/Backend/Acid.hs new file mode 100644 --- /dev/null +++ b/src/Web/ServerSession/Backend/Acid.hs @@ -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 diff --git a/src/Web/ServerSession/Backend/Acid/Internal.hs b/src/Web/ServerSession/Backend/Acid/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Web/ServerSession/Backend/Acid/Internal.hs @@ -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 ] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 "" +#endif