First stab at a Redis backend.

README.md

@@ -22,6 +22,9 @@ to be paired up with two companion packages:
       provides ACID guarantees using a transaction log.  It can
       also be used without durability as a memory-only backend.
 
+    * `serversession-backend-redis`: Storage backend using
+      Redis via the `hedis` package.
+
   * _Frontend_, bindings for your web framework of choice.
     Currently we support:
 

serversession-backend-redis/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-redis/README.md

@@ -0,0 +1,6 @@
+# serversession-backend-redis
+
+This is the storage backend for `serversession` using Redis via
+the `hedis` package.  Please [read the main README
+file](https://github.com/yesodweb/serversession/blob/master/README.md)
+for general information about the serversession packages.

serversession-backend-redis/serversession-backend-redis.cabal

@@ -0,0 +1,41 @@
+name:            serversession-backend-redis
+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 Redis.
+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-redis>
+extra-source-files: README.md
+
+library
+  hs-source-dirs: src
+  build-depends:
+      base                      == 4.*
+    , bytestring
+    , containers
+    , hedis                     == 0.6.*
+    , path-pieces
+    , text
+    , time                      >= 1.5
+    , transformers
+
+    , serversession             == 1.0.*
+  exposed-modules:
+    Web.ServerSession.Backend.Redis
+    Web.ServerSession.Backend.Redis.Internal
+  extensions:
+    DeriveDataTypeable
+    OverloadedStrings
+    RecordWildCards
+    TypeFamilies
+  ghc-options:     -Wall
+
+source-repository head
+  type:     git
+  location: https://github.com/yesodweb/serversession

serversession-backend-redis/src/Web/ServerSession/Backend/Redis.hs

@@ -0,0 +1,7 @@
+-- | Storage backend for @serversession@ using Redis via @hedis@.
+module Web.ServerSession.Backend.Redis
+  ( RedisStorage(..)
+  , RedisStorageException(..)
+  ) where
+
+import Web.ServerSession.Backend.Redis.Internal

serversession-backend-redis/src/Web/ServerSession/Backend/Redis/Internal.hs

@@ -0,0 +1,220 @@
+-- | Internal module exposing the guts of the package.  Use at
+-- your own risk.  No API stability guarantees apply.
+module Web.ServerSession.Backend.Redis.Internal
+  ( RedisStorage(..)
+  , RedisStorageException(..)
+
+  , transaction
+  , unwrap
+  , rSessionKey
+  , rAuthKey
+
+  , parseSession
+  , printSession
+  , parseUTCTime
+  , printUTCTime
+  , timeFormat
+
+  , getSessionImpl
+  , deleteSessionImpl
+  , removeSessionFromAuthId
+  , deleteAllSessionsOfAuthIdImpl
+  , insertSessionImpl
+  , replaceSessionImpl
+  ) where
+
+import Control.Applicative ((<$))
+import Control.Arrow (first)
+import Control.Monad (void, when)
+import Control.Monad.IO.Class (liftIO)
+import Data.ByteString (ByteString)
+import Data.List (partition)
+import Data.Maybe (fromMaybe)
+import Data.Typeable (Typeable)
+import Web.PathPieces (toPathPiece)
+import Web.ServerSession.Core
+
+import qualified Control.Exception as E
+import qualified Database.Redis as R
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.Map.Strict as M
+import qualified Data.Text.Encoding as TE
+import qualified Data.Time.Clock as TI
+import qualified Data.Time.Format as TI
+
+
+----------------------------------------------------------------------
+
+
+-- | Session storage backend using Redis via the @hedis@ package.
+newtype RedisStorage =
+  RedisStorage
+    { connPool :: R.Connection
+      -- ^ Connection pool to the Redis server.
+    } deriving (Typeable)
+
+
+-- | We do not provide any ACID guarantees for different actions
+-- running inside the same @TransactionM RedisStorage@.
+instance Storage RedisStorage where
+  type TransactionM RedisStorage = R.Redis
+  runTransactionM = R.runRedis . connPool
+  getSession                _ = getSessionImpl
+  deleteSession             _ = deleteSessionImpl
+  deleteAllSessionsOfAuthId _ = deleteAllSessionsOfAuthIdImpl
+  insertSession             _ = insertSessionImpl
+  replaceSession            _ = replaceSessionImpl
+
+
+-- | An exception thrown by the @serversession-backend-redis@
+-- package.
+data RedisStorageException =
+    ExpectedTxSuccess (R.TxResult ())
+    -- ^ We expected 'TxSuccess' but got something else.
+  | ExpectedRight R.Reply
+    -- ^ We expected 'Right' from an @Either 'R.Reply' a@ but got
+    -- 'Left'.
+    deriving (Show, Typeable)
+
+instance E.Exception RedisStorageException
+
+
+----------------------------------------------------------------------
+
+
+-- | Run the given Redis transaction and force its result.
+-- Throws a 'RedisStorageException' if the result is not
+-- 'TxSuccess'.
+transaction :: R.RedisTx (R.Queued ()) -> R.Redis ()
+transaction tx = do
+  ret <- R.multiExec tx
+  case ret of
+   R.TxSuccess () -> return ()
+   _              -> liftIO $ E.throwIO $ ExpectedTxSuccess ret
+
+
+-- | Unwraps an @Either 'R.Reply' a@ by throwing an exception if
+-- not @Right@.
+unwrap :: R.Redis (Either R.Reply a) -> R.Redis a
+unwrap act = act >>= either (liftIO . E.throwIO . ExpectedRight) return
+
+
+-- | Redis key for the given session ID.
+rSessionKey :: SessionId -> ByteString
+rSessionKey = B.append "ssr:session:" . TE.encodeUtf8 . toPathPiece
+
+
+-- | Redis key for the given auth ID.
+rAuthKey :: AuthId -> ByteString
+rAuthKey = B.append "ssr:authid:"
+
+
+----------------------------------------------------------------------
+
+
+-- | Parse a 'Session' from a Redis hash.
+parseSession :: SessionId -> [(ByteString, ByteString)] -> Maybe Session
+parseSession _   []  = Nothing
+parseSession sid bss =
+  let (externalList, internalList) = partition (B8.isPrefixOf "data:" . fst) bss
+      authId     = lookup "internal:authId" internalList
+      createdAt  = parseUTCTime $ lookup' "internal:createdAt"
+      accessedAt = parseUTCTime $ lookup' "internal:accessedAt"
+      lookup' k = fromMaybe (error err) $ lookup k internalList
+        where err = "serversession-backend-redis/parseSession: missing key " ++ show k
+      sessionMap = M.fromList $ map (first $ TE.decodeUtf8 . removePrefix) externalList
+        where removePrefix bs = let ("data:", key) = B8.splitAt 5 bs in key
+  in Just Session
+       { sessionKey        = sid
+       , sessionAuthId     = authId
+       , sessionData       = sessionMap
+       , sessionCreatedAt  = createdAt
+       , sessionAccessedAt = accessedAt
+       }
+
+
+-- | Convert a 'Session' into a Redis hash.
+printSession :: Session -> [(ByteString, ByteString)]
+printSession Session {..} =
+  maybe id ((:) . (,) "internal:authId") sessionAuthId $
+  (:) ("internal:createdAt",  printUTCTime sessionCreatedAt) $
+  (:) ("internal:accessedAt", printUTCTime sessionAccessedAt) $
+  map (first $ B8.append "data:" . TE.encodeUtf8) $
+  M.toList sessionData
+
+
+-- | Parse 'UTCTime' from a 'ByteString' stored on Redis.  Uses
+-- 'error' on parse error.
+parseUTCTime :: ByteString -> TI.UTCTime
+parseUTCTime = TI.parseTimeOrError True TI.defaultTimeLocale timeFormat . B8.unpack
+
+
+-- | Convert a 'UTCTime' into a 'ByteString' to be stored on
+-- Redis.
+printUTCTime :: TI.UTCTime -> ByteString
+printUTCTime = B8.pack . TI.formatTime TI.defaultTimeLocale timeFormat
+
+
+-- | Time format used when storing 'UTCTime'.
+timeFormat :: String
+timeFormat = "%Y-%m-%dT%H:%M:%S"
+
+
+----------------------------------------------------------------------
+
+
+-- | Get the session for the given session ID.
+getSessionImpl :: SessionId -> R.Redis (Maybe Session)
+getSessionImpl sid = parseSession sid <$> unwrap (R.hgetall $ rSessionKey sid)
+
+
+-- | Delete the session with given session ID.
+deleteSessionImpl :: SessionId -> R.Redis ()
+deleteSessionImpl sid = do
+  msession <- getSessionImpl sid
+  case msession of
+    Nothing -> return ()
+    Just session ->
+      transaction $ do
+        r <- R.del [rSessionKey sid]
+        removeSessionFromAuthId sid (sessionAuthId session)
+        return (() <$ r)
+
+
+-- | Remove the given 'SessionId' from the set of sessions of the
+-- given 'AuthId'.  Does not do anything if @Nothing@.
+removeSessionFromAuthId :: R.RedisCtx m f => SessionId -> Maybe AuthId -> m ()
+removeSessionFromAuthId _   Nothing       = return ()
+removeSessionFromAuthId sid (Just authId) =
+  void $ R.srem (rAuthKey authId) [rSessionKey sid]
+
+
+-- | Delete all sessions of the given auth ID.
+deleteAllSessionsOfAuthIdImpl :: AuthId -> R.Redis ()
+deleteAllSessionsOfAuthIdImpl authId = do
+  sessionRefs <- unwrap $ R.smembers (rAuthKey authId)
+  void $ unwrap $ R.del $ rAuthKey authId : sessionRefs
+
+
+-- | Insert a new session.
+insertSessionImpl :: Session -> R.Redis ()
+insertSessionImpl session = do
+  transaction $ do
+    let sk = rSessionKey $ sessionKey session
+    r <- R.hmset sk (printSession session)
+    -- TODO: R.expireat
+    maybe (return ()) (\authId -> void $ R.sadd (rAuthKey authId) [sk]) $ sessionAuthId session
+    return (() <$ r)
+
+
+-- | Replace the contents of a session.
+replaceSessionImpl :: Session -> R.Redis ()
+replaceSessionImpl session = do
+  -- Remove the old auth ID from the map if it has changed.
+  oldSession <- getSessionImpl (sessionKey session)
+  let oldAuthId = sessionAuthId =<< oldSession
+  when (oldAuthId /= sessionAuthId session) $
+    removeSessionFromAuthId (sessionKey session) oldAuthId
+  -- Otherwise the operation is the same as inserting.
+  insertSessionImpl session