module Yesod.Session.Redis (
redisSessionBackend
) where
import qualified Web.RedisSession as R
import Yesod.Core
import Yesod.Core.Types
import qualified Network.Wai as W
import Web.Cookie
import Control.Monad.Trans (liftIO)
import Data.Time (UTCTime, addUTCTime, getCurrentTime)
import qualified Data.Text as T
import Data.ByteString (ByteString)
import Database.Redis
import Network.Socket.Internal (PortNumber)
import qualified Data.Map as M
import qualified Data.ByteString.Char8 as BC
import Data.Maybe
sessionName = "yesodSession"
timeout = 10
loadRedisSession :: Connection -> Integer -> W.Request -> IO (SessionMap, SaveSession)
loadRedisSession conn timeout req = do
let val = do
raw <- lookup "Cookie" $ W.requestHeaders req
lookup sessionName $ parseCookies raw
key <- case val of
Nothing -> R.newKey
Just k -> return k
sess <- case val of
Nothing -> return M.empty
Just s -> do
result <- R.getSession conn s
return $ M.fromList $ map (\x -> ((T.pack . BC.unpack . fst) x, snd x)) $ fromJust result
let save = saveRedisSession conn timeout key
return (sess, save)
saveRedisSession :: Connection -> Integer -> ByteString -> SessionMap -> IO [Header]
saveRedisSession conn timeout key sess = do
now <- getCurrentTime
let expires = fromIntegral (timeout * 60) `addUTCTime` now
R.setSessionExpiring conn key (map (\x -> ((BC.pack . T.unpack . fst) x, snd x)) (M.toList sess)) timeout
return [AddCookie def {
setCookieName = sessionName,
setCookieValue = key,
setCookiePath = Just "/",
setCookieExpires = Just expires,
setCookieDomain = Nothing,
setCookieHttpOnly = True
}]
redisSessionBackend :: IO SessionBackend
redisSessionBackend = do
conn <- connect defaultConnectInfo
return SessionBackend {
sbLoadSession = loadRedisSession conn 20
}