diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,13 @@ +# 0.1.5 + +- Support using Redis as an authentication and session backend for + Snap. + + Contributed by Aaron Ash + and Greg Hale + +# 0.1.4 + +- Support using a Unix socket + + Contributed by Daniel Patterson diff --git a/ChangeLog b/ChangeLog deleted file mode 100644 --- a/ChangeLog +++ /dev/null @@ -1,6 +0,0 @@ --*-org-*- - -* 0.1.4 -** Support using a Unix socket - - Contributed by Daniel Patterson diff --git a/example/Site.hs b/example/Site.hs new file mode 100644 --- /dev/null +++ b/example/Site.hs @@ -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 + diff --git a/snaplet-redis.cabal b/snaplet-redis.cabal --- a/snaplet-redis.cabal +++ b/snaplet-redis.cabal @@ -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 + diff --git a/src/Snap/Snaplet/Auth/Backends/Redis.hs b/src/Snap/Snaplet/Auth/Backends/Redis.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/Backends/Redis.hs @@ -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 diff --git a/src/Snap/Snaplet/RedisDB.hs b/src/Snap/Snaplet/RedisDB.hs --- a/src/Snap/Snaplet/RedisDB.hs +++ b/src/Snap/Snaplet/RedisDB.hs @@ -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 diff --git a/src/Snap/Snaplet/Session/Backends/RedisSession.hs b/src/Snap/Snaplet/Session/Backends/RedisSession.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Session/Backends/RedisSession.hs @@ -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)