packages feed

serversession-backend-redis (empty) → 1.0

raw patch · 7 files changed

+422/−0 lines, 7 filesdep +basedep +bytestringdep +hedissetup-changed

Dependencies added: base, bytestring, hedis, hspec, path-pieces, serversession, serversession-backend-redis, tagged, text, time, transformers, unordered-containers

Files

+ 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-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.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ serversession-backend-redis.cabal view
@@ -0,0 +1,60 @@+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+    , hedis                     == 0.6.*+    , path-pieces+    , tagged                    >= 0.8+    , text+    , time                      >= 1.5+    , transformers+    , unordered-containers++    , serversession             == 1.0.*+  exposed-modules:+    Web.ServerSession.Backend.Redis+    Web.ServerSession.Backend.Redis.Internal+  extensions:+    DeriveDataTypeable+    FlexibleContexts+    OverloadedStrings+    RecordWildCards+    ScopedTypeVariables+    TypeFamilies+  ghc-options:     -Wall+++test-suite tests+  type: exitcode-stdio-1.0+  hs-source-dirs:  tests+  build-depends:+      base, bytestring, hedis, path-pieces, text,+      time, transformers, unordered-containers++    , hspec                     >= 2.1 && < 3++    , serversession+    , serversession-backend-redis+  main-is:         Main.hs+  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/Redis.hs view
@@ -0,0 +1,8 @@+-- | Storage backend for @serversession@ using Redis via @hedis@.+module Web.ServerSession.Backend.Redis+  ( RedisStorage(..)+  , RedisStorageException(..)+  , RedisSession(..)+  ) where++import Web.ServerSession.Backend.Redis.Internal
+ src/Web/ServerSession/Backend/Redis/Internal.hs view
@@ -0,0 +1,309 @@+-- | 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++  , RedisSession(..)+  , parseSession+  , printSession+  , parseUTCTime+  , printUTCTime+  , timeFormat++  , getSessionImpl+  , deleteSessionImpl+  , removeSessionFromAuthId+  , insertSessionForAuthId+  , deleteAllSessionsOfAuthIdImpl+  , insertSessionImpl+  , replaceSessionImpl+  , throwRS+  ) 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.Proxy (Proxy(..))+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.HashMap.Strict as HM+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 sess =+  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 RedisSession sess => Storage (RedisStorage sess) where+  type SessionData  (RedisStorage sess) = sess+  type TransactionM (RedisStorage sess) = 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 sess -> ByteString+rSessionKey = B.append "ssr:session:" . TE.encodeUtf8 . toPathPiece+++-- | Redis key for the given auth ID.+rAuthKey :: AuthId -> ByteString+rAuthKey = B.append "ssr:authid:"+++----------------------------------------------------------------------+++-- | Class for data types that can be used as session data for+-- the Redis backend.+--+-- It should hold that+--+-- @+-- fromHash p . perm . toHash p  ===  id+-- @+--+-- for all list permutations @perm :: [a] -> [a]@,+-- where @p :: Proxy sess@.+class IsSessionData sess => RedisSession sess where+  -- | Transform a decomposed session into a Redis hash.  Keys+  -- will be prepended with @\"data:\"@ before being stored.+  toHash   :: Proxy sess -> Decomposed sess -> [(ByteString, ByteString)]++  -- | Parse back a Redis hash into session data.+  fromHash :: Proxy sess -> [(ByteString, ByteString)] -> Decomposed sess+++-- | Assumes that keys are UTF-8 encoded when parsing (which is+-- true if keys are always generated via @toHash@).+instance RedisSession SessionMap where+  toHash   _ = map (first TE.encodeUtf8) . HM.toList . unSessionMap+  fromHash _ = SessionMap . HM.fromList . map (first TE.decodeUtf8)+++-- | Parse a 'Session' from a Redis hash.+parseSession+  :: forall sess. RedisSession sess+  => SessionId sess+  -> [(ByteString, ByteString)]+  -> Maybe (Session sess)+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+      data_ = fromHash p $ map (first removePrefix) externalList+        where removePrefix bs = let ("data:", key) = B8.splitAt 5 bs in key+              p = Proxy :: Proxy sess+  in Just Session+       { sessionKey        = sid+       , sessionAuthId     = authId+       , sessionData       = data_+       , sessionCreatedAt  = createdAt+       , sessionAccessedAt = accessedAt+       }+++-- | Convert a 'Session' into a Redis hash.+printSession :: forall sess. RedisSession sess => Session sess -> [(ByteString, ByteString)]+printSession Session {..} =+  maybe id ((:) . (,) "internal:authId") sessionAuthId $+  (:) ("internal:createdAt",  printUTCTime sessionCreatedAt) $+  (:) ("internal:accessedAt", printUTCTime sessionAccessedAt) $+  map (first $ B8.append "data:") $+  toHash (Proxy :: Proxy sess) 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%Q"+++----------------------------------------------------------------------+++-- | Run the given Redis command in batches of @511*1024@ items.+-- This is used for @HMSET@ because there's a hard Redis limit of+-- @1024*1024@ arguments to a command.  The last result is returned.+batched :: Monad m => ([a] -> m b) -> [a] -> m b+batched f xs =+  let (this, rest) = splitAt (511*1024) xs+      continue | null rest = return+               | otherwise = const (batched f rest)+  in f this >>= continue+++-- | Get the session for the given session ID.+getSessionImpl :: RedisSession sess => SessionId sess -> R.Redis (Maybe (Session sess))+getSessionImpl sid = parseSession sid <$> unwrap (R.hgetall $ rSessionKey sid)+++-- | Delete the session with given session ID.+deleteSessionImpl :: RedisSession sess => SessionId sess -> 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, Functor m) => SessionId sess -> Maybe AuthId -> m ()+removeSessionFromAuthId = fooSessionBarAuthId R.srem++-- | Insert the given 'SessionId' into the set of sessions of the+-- given 'AuthId'.  Does not do anything if @Nothing@.+insertSessionForAuthId :: (R.RedisCtx m f, Functor m) => SessionId sess -> Maybe AuthId -> m ()+insertSessionForAuthId = fooSessionBarAuthId R.sadd+++-- | (Internal) Helper for 'removeSessionFromAuthId' and 'insertSessionForAuthId'+fooSessionBarAuthId+  :: (R.RedisCtx m f, Functor m)+  => (ByteString -> [ByteString] -> m (f Integer))+  -> SessionId sess+  -> Maybe AuthId+  -> m ()+fooSessionBarAuthId _   _   Nothing       = return ()+fooSessionBarAuthId fun sid (Just authId) = void $ fun (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 :: RedisSession sess => Session sess -> R.Redis ()+insertSessionImpl session = do+  -- Check that no old session exists.+  let sid = sessionKey session+  moldSession <- getSessionImpl sid+  case moldSession of+    Just oldSession -> throwRS $ SessionAlreadyExists oldSession session+    Nothing -> do+      transaction $ do+        let sk = rSessionKey sid+        r <- batched (R.hmset sk) (printSession session)+        -- TODO: R.expireat+        insertSessionForAuthId (sessionKey session) (sessionAuthId session)+        return (() <$ r)+++-- | Replace the contents of a session.+replaceSessionImpl :: RedisSession sess => Session sess -> R.Redis ()+replaceSessionImpl session = do+  -- Check that the old session exists.+  let sid = sessionKey session+  moldSession <- getSessionImpl sid+  case moldSession of+    Nothing -> throwRS $ SessionDoesNotExist session+    Just oldSession -> do+      transaction $ do+        -- Delete the old session and set the new one.+        let sk = rSessionKey sid+        _ <- R.del [sk]+        r <- batched (R.hmset sk) (printSession session)++        -- Remove the old auth ID from the map if it has changed.+        let oldAuthId = sessionAuthId oldSession+            newAuthId = sessionAuthId session+        when (oldAuthId /= newAuthId) $ do+          removeSessionFromAuthId sid oldAuthId+          insertSessionForAuthId sid newAuthId++        return (() <$ r)+++-- | Specialization of 'E.throwIO' for 'RedisStorage'.+throwRS+  :: Storage (RedisStorage sess)+  => StorageException (RedisStorage sess)+  -> R.Redis a+throwRS = liftIO . E.throwIO
+ tests/Main.hs view
@@ -0,0 +1,12 @@+module Main (main) where++import Database.Redis (connect, defaultConnectInfo)+import Test.Hspec+import Web.ServerSession.Backend.Redis+import Web.ServerSession.Core.StorageTests++main :: IO ()+main = do+  conn <- connect defaultConnectInfo+  hspec $ describe "RedisStorage" $+    allStorageTests (RedisStorage conn) it runIO parallel shouldBe shouldReturn shouldThrow