snaplet-redis 0.1.4.2 → 0.1.5

raw patch · 7 files changed

+740/−59 lines, 7 filesdep +aesondep +bytestringdep +cerealdep ~basedep ~configuratordep ~hedisnew-component:exe:ExamplePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson, bytestring, cereal, clientsession, heist, monad-control, snap-core, snap-server, snaplet-redis, time, unordered-containers, xmlhtml

Dependency ranges changed: base, configurator, hedis, lens, mtl, network, snap, text, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• ChangeLog +0/−6
• example/Site.hs +97/−0
• snaplet-redis.cabal +70/−36
• src/Snap/Snaplet/Auth/Backends/Redis.hs +296/−0
• src/Snap/Snaplet/RedisDB.hs +13/−17
• src/Snap/Snaplet/Session/Backends/RedisSession.hs +251/−0

@@ -0,0 +1,13 @@+# 0.1.5++- Support using Redis as an authentication and session backend for+  Snap.++  Contributed by Aaron Ash <aaron.ash@gmail.com>+  and Greg Hale <imalsogreg@gmail.com>++# 0.1.4++- Support using a Unix socket++  Contributed by Daniel Patterson <dbp@riseup.net>

@@ -1,6 +0,0 @@--*-org-*---* 0.1.4-** Support using a Unix socket--   Contributed by Daniel Patterson <dbp@riseup.net>

@@ -0,0 +1,97 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE TemplateHaskell     #-}++module Main where++------------------------------------------------------------------------------+import           Control.Applicative+import           Control.Monad.Trans+import           Control.Monad.Reader+import           Control.Monad.State+import           Data.ByteString (ByteString)+import           Control.Lens+import           Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import           Data.Time.Clock+import qualified Database.Redis as R+import           Snap+import           Snap.Snaplet.Auth+import           Snap.Snaplet.Auth.Backends.Redis+import           Snap.Snaplet.Heist+import           Snap.Snaplet.RedisDB+import           Snap.Snaplet.Session+import           Snap.Snaplet.Session.Backends.RedisSession+import           Snap.Util.FileServe+import           Heist+import           Text.XmlHtml hiding (render)+++------------------------------------------------------------------------------+data App = App+    { _sess :: Snaplet SessionManager+    , _db   :: Snaplet RedisDB+    , _auth :: Snaplet (AuthManager App)+    }++makeLenses ''App++------------------------------------------------------------------------------+-- | The application's routes.+routes :: [(ByteString, Handler App App ())]+routes = [ ("/",           writeText "hello")+         , ("foo",         fooHandler)+         , ("add/:uname",  addHandler)+         , ("find/:email", findHandler)+         ]++fooHandler = do+    env <- with auth get+    results <- runRedisDB db $ do+        r <- R.keys "user:*"+        case r of+            Left  _       -> error "redis error"+            Right ulogins -> forM ulogins $ \l ->+                liftIO (lookupByLogin env (T.drop 5 $ T.decodeUtf8 l))+    liftIO $ print (results :: [Maybe AuthUser])++addHandler = do+    mname <- getParam "uname"+    email <- getParam "email"+    let name = maybe "guest" T.decodeUtf8 mname+    u <- with auth $+        createUser name "" >>= \u -> case u of+            Left _   -> return u+            Right u' -> saveUser (u' {userEmail = T.decodeUtf8 <$> email})+    liftIO $ print u++#if MIN_VERSION_snap(1,1,0)+findHandler = do+    email <- getParam "email"+    env <- with auth get+    liftIO $ lookupByEmail env (maybe "" T.decodeUtf8 email) >>= print+#else+findHandler = return ()+#endif++------------------------------------------------------------------------------+-- | The application initializer.+app :: SnapletInit App App+app = makeSnaplet "app" "An snaplet example application." Nothing $ do+    d <- nestSnaplet "db" db redisDBInitConf+    s <- nestSnaplet "" sess $+         initRedisSessionManager "site_key.txt"+                                 "_cookie" Nothing (d ^. snapletValue)+    a <- nestSnaplet "auth" auth $ initRedisAuthManager sess (d ^. snapletValue)+    addRoutes routes+    return $ App s d a+++main :: IO ()+main = serveSnaplet defaultConfig app+

@@ -1,41 +1,75 @@-Name:                snaplet-redis-Version:             0.1.4.2-Synopsis:            Redis support for Snap Framework-Description:         This package provides a snaplet which exposes-                     interface to Redis in-memory key-value storage as-                     implemented by Hedis library. Inline-                     documentation contains usage examples.-Homepage:            https://github.com/dzhus/snaplet-redis/-Bug-reports:         https://github.com/dzhus/snaplet-redis/issues/-License:             BSD3-License-file:        LICENSE-Author:              Dmitry Dzhus-Maintainer:          dima@dzhus.org-Category:            Web, Snap-stability:           stable--Build-type:          Simple-Cabal-version:       >=1.6-Tested-with:         GHC == 7.6.3, GHC == 7.8.3-Extra-source-files:  ChangeLog+name: snaplet-redis+version: 0.1.5+cabal-version: >=1.10+build-type: Simple+license: BSD3+license-file: LICENSE+maintainer: dima@dzhus.org+homepage: https://github.com/dzhus/snaplet-redis#readme+bug-reports: https://github.com/dzhus/snaplet-redis/issues+synopsis: Redis support for Snap Framework+description:+    This package provides a snaplet which exposes interface to Redis in-memory key-value storage as implemented by Hedis library. Inline documentation contains usage examples.+category: Web, Snap+author: Dmitry Dzhus+extra-source-files:+    CHANGELOG.md  source-repository head-  type:     git-  location: git://github.com/dzhus/snaplet-redis.git+    type: git+    location: https://github.com/dzhus/snaplet-redis -Library-  ghc-options: -Wall-  hs-source-dirs: src+flag example+    description:+        Build example+    default: False -  Exposed-modules:   Snap.Snaplet.RedisDB+library+    exposed-modules:+        Snap.Snaplet.Auth.Backends.Redis+        Snap.Snaplet.RedisDB+        Snap.Snaplet.Session.Backends.RedisSession+    build-depends:+        base <5,+        bytestring <0.11,+        cereal <0.6,+        clientsession <0.10,+        configurator <0.4,+        lens <4.16,+        hedis <0.10,+        mtl <2.3,+        network <2.7,+        snap <1.1,+        snap-core <1.1,+        transformers <0.6,+        text <1.3,+        time <1.9,+        unordered-containers <0.3+    default-language: Haskell2010+    hs-source-dirs: src+    ghc-options: -Wall -  Build-depends:-    base                >= 4 && < 5,-    configurator        >= 0.2 && < 0.4,-    lens                >= 3.8 && < 4.8,-    hedis               == 0.6.*,-    mtl                 >= 2 && < 3,-    network             >= 2.4 && < 2.7,-    snap                >= 0.11 && < 0.14,-    transformers        >= 0.3 && < 0.5,-    text                >= 0.9 && < 1.3+executable Example+    +    if !flag(example)+        buildable: False+    main-is: Site.hs+    build-depends:+        base <4.11,+        aeson <1.2,+        bytestring <0.11,+        lens <4.16,+        hedis <0.10,+        heist <1.1,+        monad-control <1.1,+        mtl <2.3,+        snap <1.1,+        snap-core <1.1,+        snap-server <1.1,+        snaplet-redis <0.2,+        text <1.3,+        time <1.9,+        xmlhtml <0.3+    default-language: Haskell2010+    hs-source-dirs: example+

@@ -0,0 +1,296 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++{-|++This module allows you to use the auth snaplet with your user database+stored in a Redis instance.++In your initializer you'll need something like:++@+ a <- nestSnaplet "auth" auth $+          initRedisAuthManager defAuthSettings sess defaultConnectInfo+@+++Redis Key Space++The following keys are used to store the user information in Redis.+Be sure to avoid key collisions within your applications.++* next.userId - Int representing the next spare userId.++* user:[username] (eg. user:bob) - Hash of the user fields for user bob.++* userid:[userId] (eg. userid:2 - bob) - Stores username for userId based lookup.++* useremail:[email] (eg. useremail:bob@example.com - bob) - Stores email for lookup++* usertoken:[usertoken] (eg. usertoken:XXXXXXXX - bob) - Remember Token based user lookup.++-}+++module Snap.Snaplet.Auth.Backends.Redis+  ( initRedisAuthManager+  ) where++import           Control.Monad.State hiding (get)+import qualified Data.ByteString as B+import           Data.HashMap.Strict   (HashMap)+import qualified Data.HashMap.Strict   as HM+import           Data.Maybe (fromMaybe)+import qualified Data.Text as T+import           Data.Text (Text)+import           Data.Text.Encoding as E+import           Data.Time+import           Database.Redis+import           Snap.Snaplet+import           Text.Read (readMaybe)+import           Web.ClientSession++import           Snap.Snaplet.Auth+import           Snap.Snaplet.RedisDB+import           Snap.Snaplet.Session+++------------------------------------------------------------------------------+-- | Initialize a Redis backed 'AuthManager'+initRedisAuthManager :: SnapletLens b SessionManager+                        -- ^ Lens into a 'SessionManager' auth snaplet will use+                        -> RedisDB+                        -- ^ Redis ConnectInfo+                        -> SnapletInit b (AuthManager b)+initRedisAuthManager l d =+    makeSnaplet+        "RedisAuthManager"+        "A snaplet providing user authentication using a Redis backend"+        Nothing $ do+            rng <- liftIO mkRNG+            s <- authSettingsFromConfig+            key <- liftIO $ getKey (asSiteKey s)+            let redisMgr = RedisAuthManager { conn = _connection d }+            return AuthManager {+                         backend               = redisMgr+                       , session               = l+                       , activeUser            = Nothing+                       , minPasswdLen          = asMinPasswdLen s+                       , rememberCookieName    = asRememberCookieName s+#if MIN_VERSION_snap(1,0,0)+                       , rememberCookieDomain  = Nothing+#endif+                       , rememberPeriod        = asRememberPeriod s+                       , siteKey               = key+                       , lockout               = asLockout s+                       , randomNumberGenerator = rng+                       }++userHashKey :: Text -> B.ByteString+{-userHashKey user = B.append (B.fromString "user:") (E.encodeUtf8 user)-}+userHashKey user = B.append "user:" (E.encodeUtf8 user)++userIdKey :: Text -> B.ByteString+userIdKey userid = enc $ T.append (T.pack "userid:") userid++userEmailKey :: Text -> B.ByteString+userEmailKey em = enc $ T.append "useremail:" em++userTokenKey :: Text -> B.ByteString+userTokenKey usertoken = enc $ T.append (T.pack "usertoken:") usertoken++enc :: Text -> B.ByteString+enc = E.encodeUtf8++dec :: B.ByteString -> Text+dec = E.decodeUtf8++encodeInt :: Int -> B.ByteString+encodeInt = enc . T.pack . show++-- AA TODO: return a Maybe Int here instead.+-- Might be able to use ByteString.Char8.readInt depending on if it's ok+-- with unicode input bytes.+decodeInt :: B.ByteString -> Int+decodeInt = read . T.unpack . dec++encMaybeUTCTime :: Maybe UTCTime -> B.ByteString+encMaybeUTCTime (Just u) = enc $ T.pack . show $ u+encMaybeUTCTime _ = ""++decMaybeUTCTime :: B.ByteString -> Maybe UTCTime+decMaybeUTCTime s = case s of+                            "" -> Nothing+                            _ -> readMaybe . T.unpack . dec $ s++encRoles :: [Role] -> B.ByteString+encRoles [] = ""+encRoles roles = enc $ T.intercalate "," $ map (T.pack . show) roles++decodeRoles :: B.ByteString -> [Role]+decodeRoles "" = []+decodeRoles s = map (read . T.unpack) $ T.splitOn "," (dec s)++encPassword :: Maybe Password -> B.ByteString+encPassword (Just (Encrypted p)) = p+encPassword (Just (ClearText _)) = error "encPassword should never encode ClearText password"+encPassword Nothing = ""++decPassword :: B.ByteString -> Maybe Password+decPassword "" = Nothing+decPassword p = Just (Encrypted p)++{- Check if user exists and incr next:userid if not -}+nextUserID :: AuthUser -> Redis (Either Reply T.Text)+nextUserID u = case userId u of+                 Just uid -> return $ Right $ unUid uid+                 Nothing -> do+                   i <- incr "next.userId"+                   case i of+                     Right newUserId -> return $ Right $ T.pack $ show newUserId+                     Left e -> return $ Left e++redisSave :: RedisAuthManager -> AuthUser -> IO (Either AuthFailure AuthUser)+redisSave r u =+    runRedis (conn r) $ do+         nexti <- nextUserID u+         case nexti of+           Right checkedUserId -> do+             res <- multiExec $ do+               res1 <- hmset (userHashKey $ userLogin u)+                  [("userId",                 enc checkedUserId),+                   ("userLogin",              enc $ userLogin u),+                   ("userEmail",              enc $ fromMaybe "" $ userEmail u),+                   ("userPassword",           encPassword (userPassword u)),+                   ("userActivatedAt",        encMaybeUTCTime $ userActivatedAt u),+                   ("userSuspendedAt",        encMaybeUTCTime $ userSuspendedAt u),+                   ("userRememberToken",      enc $ fromMaybe "" $ userRememberToken u),+                   ("userLoginCount",         encodeInt $ userLoginCount u),+                   ("userFailedLoginCount",   encodeInt $ userFailedLoginCount u),+                   ("userLockedOutUntil",     encMaybeUTCTime $ userLockedOutUntil u),+                   ("userCurrentLoginAt",     encMaybeUTCTime $ userCurrentLoginAt u),+                   ("userLastLoginAt",        encMaybeUTCTime $ userLastLoginAt u),+                   ("userCurrentLoginIp",     fromMaybe "" $ userCurrentLoginIp u),+                   ("userLastLoginIp",        fromMaybe "" $ userLastLoginIp u),+                   ("userCreatedAt",          encMaybeUTCTime $ userCreatedAt u),+                   ("userUpdatedAt",          encMaybeUTCTime $ userUpdatedAt u),+                   ("userResetToken",         enc $ fromMaybe "" $ userResetToken u),+                   ("userResetRequestedAt",   encMaybeUTCTime $ userResetRequestedAt u),+                   ("userRoles",              encRoles $ userRoles u),+                   ("userMeta",               enc $ T.pack . show $ HM.toList $ userMeta u)+                  ]+               {- set "userid:1000" = "bob" -}+               res2 <- set (userIdKey checkedUserId) (enc $ userLogin u)+               {- set "useremail:bob@example.com" = "bob" -}+               mapM_ (\em -> set (userEmailKey em) (enc $ userLogin u)) (userEmail u)+               {- set "usertoken:XXXX" = "bob" -}+               mapM_ (\t -> set (userTokenKey t) (enc $ userLogin u)) $ userRememberToken u+               return $ (,) <$> res1 <*> res2+             case res of+               TxSuccess _ -> return $ Right u+               TxAborted -> return $ Left $ AuthError "redis transaction aborted"+               TxError e -> return $ Left $ AuthError e+           Left (Error e) -> return $ Left $ AuthError (show e)+           Left _ -> return $ Left $ AuthError "redisSave unknown error"++redisDestroy :: RedisAuthManager -> AuthUser -> IO ()+redisDestroy r u =+    case userId u of+      Nothing -> return ()+      Just uid ->+        runRedis (conn r) $ do+            _ <- del [userHashKey $ userLogin u,+                      userIdKey $ unUid uid]+            return ()++redisLookupByUserId :: RedisAuthManager -> UserId -> IO (Maybe AuthUser)+redisLookupByUserId r uid =+  runRedis (conn r) $ do+      ul <- get (userIdKey $ unUid uid)+      case ul of+        Right (Just userlogin) -> liftIO $ redisLookupByLogin r (dec userlogin)+        _ -> return Nothing++redisLookupByLogin :: RedisAuthManager -> Text -> IO (Maybe AuthUser)+redisLookupByLogin r ul =+  runRedis (conn r) $ do+      uhash <- hgetall (userHashKey ul)+      case uhash of+        Right [] -> return Nothing+        Left _ -> return Nothing+        Right h -> return $ Just $ authUserFromHash h++#if MIN_VERSION_snap(1,1,0)+redisLookupByEmail :: RedisAuthManager -> Text -> IO (Maybe AuthUser)+redisLookupByEmail r em =+    runRedis (conn r) $ do+        ulogin <- get (userEmailKey em)+        case ulogin of+            Right (Just u) -> do+                uhash <- hgetall (userHashKey $ dec u)+                case uhash of+                    Right [] -> return Nothing+                    Left  _  -> return Nothing+                    Right h  -> return $ Just $ authUserFromHash h+            _ -> return Nothing+#endif++hmlookup :: B.ByteString -> HashMap B.ByteString B.ByteString -> B.ByteString+hmlookup k hm = fromMaybe "" $ HM.lookup k hm++authUserFromHash :: [(B.ByteString, B.ByteString)] -> AuthUser+authUserFromHash [] = error "authUserFromHash error: Empty hashmap"+authUserFromHash l =+    let hm = HM.fromList l+         in AuthUser { userId               = Just $ UserId (dec $ hmlookup "userId" hm)+                     , userLogin            = dec $ hmlookup "userLogin" hm+                     , userEmail            = case hmlookup "userEmail " hm of+                                                "" -> Nothing+                                                email -> Just (T.pack . show $ email)+                     , userPassword         = decPassword (hmlookup "userPassword" hm)+                     , userActivatedAt      = decMaybeUTCTime (hmlookup "userActivatedAt" hm)+                     , userSuspendedAt      = decMaybeUTCTime (hmlookup "userSuspendedAt" hm)+                     , userRememberToken    = case hmlookup "userRememberToken" hm of+                                                "" -> Nothing+                                                token -> Just (dec token)+                     , userLoginCount       = decodeInt (hmlookup "userLoginCount" hm)+                     , userFailedLoginCount = decodeInt (hmlookup "userFailedLoginCount" hm)+                     , userLockedOutUntil   = decMaybeUTCTime (hmlookup "userLockedOutUntil" hm)+                     , userCurrentLoginAt   = decMaybeUTCTime (hmlookup "userCurrentLoginAt" hm)+                     , userLastLoginAt      = decMaybeUTCTime (hmlookup "userLastLoginAt" hm)+                     , userCurrentLoginIp   = Just (hmlookup "userCurrentLoginIp" hm)+                     , userLastLoginIp      = Just (hmlookup "userLastLoginIp" hm)+                     , userCreatedAt        = decMaybeUTCTime (hmlookup "userCreatedAt" hm)+                     , userUpdatedAt        = decMaybeUTCTime (hmlookup "userUpdatedAt" hm)+                     , userResetToken       = Just (dec $ hmlookup "userResetToken" hm)+                     , userResetRequestedAt = decMaybeUTCTime (hmlookup "userResetRequestedAt" hm)+                     , userRoles            = decodeRoles (hmlookup "userRoles" hm)+                     {-AA TODO: use toList and fromList for the HashMap serializing.+                     - the snaplet-postgresql-simple project doesnt handle userMeta either.-}+                     , userMeta             = HM.empty+                   }++redisLookupByRememberToken :: RedisAuthManager -> Text -> IO (Maybe AuthUser)+redisLookupByRememberToken r utkn =+  runRedis (conn r) $ do+      ul <- get (userTokenKey utkn)+      case ul of+        Right (Just userlogin) -> liftIO $ redisLookupByLogin r (dec userlogin)+        _ -> return Nothing++newtype RedisAuthManager = RedisAuthManager {+    conn :: Connection+    }++instance IAuthBackend RedisAuthManager where+  save = redisSave+  destroy = redisDestroy+  lookupByUserId = redisLookupByUserId+  lookupByLogin = redisLookupByLogin+#if MIN_VERSION_snap(1,1,0)+  lookupByEmail = redisLookupByEmail+#endif+  lookupByRememberToken = redisLookupByRememberToken

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE Rank2Types #-} @@ -9,7 +10,7 @@ -}  module Snap.Snaplet.RedisDB-    (RedisDB+    (RedisDB(..)     , runRedisDB     , redisConnection     , redisDBInit@@ -21,8 +22,6 @@ import Control.Monad.State  import Database.Redis hiding (String)-import Network (PortID(..))-import Network.Socket (PortNumber(..)) import Data.Configurator as C import Data.Configurator.Types (Configured(..), Value(..)) import Data.Maybe@@ -31,30 +30,27 @@  import Snap.Snaplet -------------------------------------------------------------------------------- -- | Snaplet's state data type-data RedisDB = RedisDB-    { _connection :: Connection -- ^ DB connection pool.-    }+newtype RedisDB = RedisDB+                  { _connection :: Connection -- ^ DB connection pool.+                  }  makeLenses ''RedisDB -------------------------------------------------------------------------------+newtype ConfiguredPortID = ConfiguredPortID { unConfiguredPortID :: PortID }+ -- | Instance to allow port to be either a path to a unix socket or a -- port number.-instance Configured PortID where-  convert (Number r) | denominator r == 1 = Just $ PortNumber $ PortNum $ fromInteger $ numerator r-  convert (String s) = Just $ UnixSocket $ T.unpack s+instance Configured ConfiguredPortID where+  convert (Number r) | denominator r == 1 = Just $ ConfiguredPortID $ PortNumber $ fromInteger $ numerator r+  convert (String s) = Just $ ConfiguredPortID $ UnixSocket $ T.unpack s   convert _ = Nothing ------------------------------------------------------------------------------- -- | A lens to retrieve the connection to Redis from the 'RedisDB' -- wrapper. redisConnection :: Simple Lens RedisDB Connection redisConnection = connection ------------------------------------------------------------------------------- -- | Perform action using Redis connection from RedisDB snaplet pool -- (wrapper for 'Database.Redis.runRedis'). --@@ -67,7 +63,6 @@   liftIO $ runRedis c action  ------------------------------------------------------------------------------- -- | Make RedisDB snaplet and initialize database connection from -- snaplet config file. Options are read from the "redis" section of -- the application config (e.g. ./devel.cfg) or from the main section@@ -115,12 +110,13 @@          let def = defaultConnectInfo         return $ def { connectHost = fromMaybe (connectHost def) cHost-                     , connectPort = fromMaybe (connectPort def) cPort+                     , connectPort = fromMaybe (connectPort def)+                                     (unConfiguredPortID <$> cPort)                      , connectAuth = cAuth                      , connectMaxConnections =                        fromMaybe (connectMaxConnections def) cCons                      , connectMaxIdleTime =-                       maybe (connectMaxIdleTime def) (fromRational) cIdle+                       maybe (connectMaxIdleTime def) fromRational cIdle                      }      conn <- liftIO $ connect connInfo

@@ -0,0 +1,251 @@+------------------------------------------------------------------------------+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}++module Snap.Snaplet.Session.Backends.RedisSession+    ( initRedisSessionManager+    ) where++------------------------------------------------------------------------------+import           Control.Monad.Reader+import           Data.ByteString                     (ByteString)+import           Data.HashMap.Strict                 (HashMap)+import qualified Data.HashMap.Strict                 as HM+import           Data.Serialize                      (Serialize)+import qualified Data.Serialize                      as S+import           Data.Text                           (Text)+import           Data.Text.Encoding+import           Data.Typeable+-- import           GHC.Generics+import           Snap.Core                           (Snap)+import           Web.ClientSession+import           Database.Redis+------------------------------------------------------------------------------+import           Snap.Snaplet+import           Snap.Snaplet.RedisDB+import           Snap.Snaplet.Session+import           Snap.Snaplet.Session.SessionManager+-------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Session data are kept in a 'HashMap' for this backend+--+type Session = HashMap Text Text+++------------------------------------------------------------------------------+-- | This is what the 'Payload' will be for the RedisSession backend+-- | Only the rsCSRFToken is sent to the client.+-- | The Session hash is stored in Redis.+data RedisSession = RedisSession+    { rsCSRFToken :: Text+    , rsSession :: Session+    }+  deriving (Eq, Show)+++------------------------------------------------------------------------------+--Only serialize the rsCSRFToken to send to the client+instance Serialize RedisSession where+    put (RedisSession a _) =+        S.put $ encodeUtf8 a+    get                     =+        let unpack a = RedisSession (decodeUtf8 a) HM.empty+        in  unpack <$> S.get+++encodeTuple :: (Text, Text) -> (ByteString, ByteString)+encodeTuple (a,b) = (encodeUtf8 a, encodeUtf8 b)+++decodeTuple :: (ByteString, ByteString) -> (Text, Text)+decodeTuple (a,b) = (decodeUtf8 a, decodeUtf8 b)+++------------------------------------------------------------------------------+mkCookieSession :: RNG -> IO RedisSession+mkCookieSession rng = do+    t <- liftIO $ mkCSRFToken rng+    return $ RedisSession t HM.empty+++------------------------------------------------------------------------------+-- | The manager data type to be stuffed into 'SessionManager'+--+data RedisSessionManager = RedisSessionManager {+      session               :: Maybe RedisSession+        -- ^ Per request cache for 'CookieSession'+    , siteKey               :: Key+        -- ^ A long encryption key used for secure cookie transport+    , cookieName            :: ByteString+        -- ^ Cookie name for the session system+    , cookieDomain          :: Maybe ByteString+        -- ^ Cookie domain for session system. You may want to set it to+        -- dot prefixed domain name like ".example.com", so the cookie is+        -- available to sub domains.+    , timeOut               :: Maybe Int+        -- ^ Session cookies will be considered "stale" after this many+        -- seconds.+    , randomNumberGenerator :: RNG+        -- ^ handle to a random number generator+    , _redisConnection :: Connection+        -- ^ Redis connection to store session info+} deriving (Typeable)+++------------------------------------------------------------------------------+loadDefSession :: RedisSessionManager -> IO RedisSessionManager+loadDefSession mgr@(RedisSessionManager ses _ _ _ _ rng _) =+    case ses of+      Nothing -> do ses' <- mkCookieSession rng+                    return $! mgr { session = Just ses' }+      Just _  -> return mgr+++------------------------------------------------------------------------------+modSession :: (Session -> Session) -> RedisSession -> RedisSession+modSession f (RedisSession t ses) = RedisSession t (f ses)++------------------------------------------------------------------------------+sessionKey :: Text -> ByteString+sessionKey t = encodeUtf8 $ mappend "session:" t++------------------------------------------------------------------------------+-- | Initialize a cookie-backed session, returning a 'SessionManager' to be+-- stuffed inside your application's state. This 'SessionManager' will enable+-- the use of all session storage functionality defined in+-- 'Snap.Snaplet.Session'+--+initRedisSessionManager+    :: FilePath             -- ^ Path to site-wide encryption key+    -> ByteString           -- ^ Session cookie name+    -> Maybe ByteString     -- ^ Cookie Domain (has no effect with snap < 1.0)+    -> Maybe Int            -- ^ Session time-out (replay attack protection)+    -> RedisDB              -- ^ Redis connection+    -> SnapletInit b SessionManager+initRedisSessionManager fp cn cd to c =+    makeSnaplet "RedisSession"+                "A snaplet providing sessions via HTTP cookies with a Redis backend."+                Nothing $ liftIO $ do+        key <- getKey fp+        rng <- liftIO mkRNG+        return $! SessionManager+               $  RedisSessionManager Nothing key cn cd to rng (_connection c)+++------------------------------------------------------------------------------+instance ISessionManager RedisSessionManager where++    --------------------------------------------------------------------------+    --load grabs the session from redis.+    load mgr@(RedisSessionManager r _ _ _ _ rng con) =+      case r of+        Just _  -> return mgr+        Nothing -> do+          pl <- getPayload mgr+          case pl of+            Nothing          -> liftIO $ loadDefSession mgr+            Just (Payload x) -> do+              let c = S.decode x+              case c of+                Left _   -> liftIO $ loadDefSession mgr+                Right cs -> liftIO $ do+                  sess <- runRedis con $ do+                    l <- hgetall (sessionKey $ rsCSRFToken cs)+                    case l of+                      Left _   -> liftIO $ mkCookieSession rng+                      Right l' -> do+                        let rs = cs { rsSession = HM.fromList $ map decodeTuple l'}+                        return rs+                  return mgr { session = Just sess }++    --------------------------------------------------------------------------+    --commit writes to redis and sends the csrf to client and also sets the+    --timeout.+    commit mgr@(RedisSessionManager r _ _ _ to rng con) = do+        pl <- case r of+          Just r' -> liftIO $+            runRedis con $ do+              res <- multiExec $ do+                _ <- del [sessionKey (rsCSRFToken r')]   --Clear old values+                let sess = map encodeTuple $ HM.toList (rsSession r')+                res1 <- case sess of+                  [] -> hmset (sessionKey (rsCSRFToken r')) [("","")]+                  _  -> hmset (sessionKey (rsCSRFToken r')) sess+                res2 <- case to of+                  Just i  -> expire (sessionKey (rsCSRFToken r')) $ toInteger i+                  Nothing -> persist (sessionKey (rsCSRFToken r'))+                return $ (,) <$> res1 <*> res2+              case res of+                TxSuccess _ -> return . Payload $ S.encode r'+                TxError e   -> error e+                TxAborted   -> error "transaction aborted"+          Nothing -> liftIO $ Payload . S.encode <$> mkCookieSession rng+        setPayload mgr pl+++    --------------------------------------------------------------------------+    --clear the session from redis and return a new empty one+    {-reset mgr@(RedisSessionManager _ _ _ _ _ _)  = trace "RedisSessionManager reset" $ do-}+    reset mgr@(RedisSessionManager r _ _ _ _ _ con)  = do+        case r of+          Just r' -> liftIO $+            runRedis con $ do+              res1 <- del [sessionKey $ rsCSRFToken r']+              case res1 of+                Left e  -> error $ show e+                _ -> return ()+          _ -> return ()+        cs <- liftIO $ mkCookieSession (randomNumberGenerator mgr)+        return $ mgr { session = Just cs }++    --------------------------------------------------------------------------+    touch = id++    --------------------------------------------------------------------------+    insert k v mgr@(RedisSessionManager r _ _ _ _ _ _) = case r of+        Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' }+        Nothing -> mgr++    --------------------------------------------------------------------------+    lookup k (RedisSessionManager r _ _ _ _ _ _) = r >>= HM.lookup k . rsSession++    --------------------------------------------------------------------------+    delete k mgr@(RedisSessionManager r _ _ _ _ _ _) = case r of+        Just r' -> mgr { session = Just $ modSession (HM.delete k) r' }+        Nothing -> mgr++    --------------------------------------------------------------------------+    csrf (RedisSessionManager r _ _ _ _ _ _) = case r of+        Just r' -> rsCSRFToken r'+        Nothing -> ""++    --------------------------------------------------------------------------+    toList (RedisSessionManager r _ _ _ _ _ _) = case r of+        Just r' -> HM.toList . rsSession $ r'+        Nothing -> []++------------------------------------------------------------------------------+-- | A session payload to be stored in a SecureCookie.+newtype Payload = Payload ByteString+  deriving (Eq, Show, Ord, Serialize)+++------------------------------------------------------------------------------+-- | Get the current client-side value+getPayload :: RedisSessionManager -> Snap (Maybe Payload)+getPayload mgr = getSecureCookie (cookieName mgr) (siteKey mgr) (timeOut mgr)+++------------------------------------------------------------------------------+-- | Set the client-side value+setPayload :: RedisSessionManager -> Payload -> Snap ()+setPayload mgr = setSecureCookie+    (cookieName mgr)+#if MIN_VERSION_snap(1,0,0)+    (cookieDomain mgr)+#endif+    (siteKey mgr) (timeOut mgr)