New serversession-backend-acid-state package.

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.

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.

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 <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-sql>
+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

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

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