{-# 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 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
type Session = HashMap Text Text
data RedisSession = RedisSession
{ RedisSession -> Text
rsCSRFToken :: Text
, :: Session
}
deriving (RedisSession -> RedisSession -> Bool
(RedisSession -> RedisSession -> Bool)
-> (RedisSession -> RedisSession -> Bool) -> Eq RedisSession
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RedisSession -> RedisSession -> Bool
$c/= :: RedisSession -> RedisSession -> Bool
== :: RedisSession -> RedisSession -> Bool
$c== :: RedisSession -> RedisSession -> Bool
Eq, Int -> RedisSession -> ShowS
[RedisSession] -> ShowS
RedisSession -> String
(Int -> RedisSession -> ShowS)
-> (RedisSession -> String)
-> ([RedisSession] -> ShowS)
-> Show RedisSession
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RedisSession] -> ShowS
$cshowList :: [RedisSession] -> ShowS
show :: RedisSession -> String
$cshow :: RedisSession -> String
showsPrec :: Int -> RedisSession -> ShowS
$cshowsPrec :: Int -> RedisSession -> ShowS
Show)
instance Serialize RedisSession where
put :: Putter RedisSession
put (RedisSession Text
a Session
_) =
Putter ByteString
forall t. Serialize t => Putter t
S.put Putter ByteString -> Putter ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
a
get :: Get RedisSession
get =
let unpack :: ByteString -> RedisSession
unpack ByteString
a = Text -> Session -> RedisSession
RedisSession (ByteString -> Text
decodeUtf8 ByteString
a) Session
forall k v. HashMap k v
HM.empty
in ByteString -> RedisSession
unpack (ByteString -> RedisSession) -> Get ByteString -> Get RedisSession
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
forall t. Serialize t => Get t
S.get
encodeTuple :: (Text, Text) -> (ByteString, ByteString)
encodeTuple :: (Text, Text) -> (ByteString, ByteString)
encodeTuple (Text
a,Text
b) = (Text -> ByteString
encodeUtf8 Text
a, Text -> ByteString
encodeUtf8 Text
b)
decodeTuple :: (ByteString, ByteString) -> (Text, Text)
decodeTuple :: (ByteString, ByteString) -> (Text, Text)
decodeTuple (ByteString
a,ByteString
b) = (ByteString -> Text
decodeUtf8 ByteString
a, ByteString -> Text
decodeUtf8 ByteString
b)
mkCookieSession :: RNG -> IO RedisSession
mkCookieSession :: RNG -> IO RedisSession
mkCookieSession RNG
rng = do
Text
t <- IO Text -> IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ RNG -> IO Text
mkCSRFToken RNG
rng
RedisSession -> IO RedisSession
forall (m :: * -> *) a. Monad m => a -> m a
return (RedisSession -> IO RedisSession)
-> RedisSession -> IO RedisSession
forall a b. (a -> b) -> a -> b
$ Text -> Session -> RedisSession
RedisSession Text
t Session
forall k v. HashMap k v
HM.empty
data RedisSessionManager = RedisSessionManager {
RedisSessionManager -> Maybe RedisSession
session :: Maybe RedisSession
, RedisSessionManager -> Key
siteKey :: Key
, RedisSessionManager -> ByteString
cookieName :: ByteString
, RedisSessionManager -> Maybe ByteString
cookieDomain :: Maybe ByteString
, RedisSessionManager -> Maybe Int
timeOut :: Maybe Int
, RedisSessionManager -> RNG
randomNumberGenerator :: RNG
, RedisSessionManager -> Connection
_redisConnection :: Connection
} deriving (Typeable)
loadDefSession :: RedisSessionManager -> IO RedisSessionManager
loadDefSession :: RedisSessionManager -> IO RedisSessionManager
loadDefSession mgr :: RedisSessionManager
mgr@(RedisSessionManager Maybe RedisSession
ses Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
rng Connection
_) =
case Maybe RedisSession
ses of
Maybe RedisSession
Nothing -> do RedisSession
ses' <- RNG -> IO RedisSession
mkCookieSession RNG
rng
RedisSessionManager -> IO RedisSessionManager
forall (m :: * -> *) a. Monad m => a -> m a
return (RedisSessionManager -> IO RedisSessionManager)
-> RedisSessionManager -> IO RedisSessionManager
forall a b. (a -> b) -> a -> b
$! RedisSessionManager
mgr { session :: Maybe RedisSession
session = RedisSession -> Maybe RedisSession
forall a. a -> Maybe a
Just RedisSession
ses' }
Just RedisSession
_ -> RedisSessionManager -> IO RedisSessionManager
forall (m :: * -> *) a. Monad m => a -> m a
return RedisSessionManager
mgr
modSession :: (Session -> Session) -> RedisSession -> RedisSession
modSession :: (Session -> Session) -> RedisSession -> RedisSession
modSession Session -> Session
f (RedisSession Text
t Session
ses) = Text -> Session -> RedisSession
RedisSession Text
t (Session -> Session
f Session
ses)
sessionKey :: Text -> ByteString
sessionKey :: Text -> ByteString
sessionKey Text
t = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend Text
"session:" Text
t
initRedisSessionManager
:: FilePath
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> RedisDB
-> SnapletInit b SessionManager
initRedisSessionManager :: String
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> RedisDB
-> SnapletInit b SessionManager
initRedisSessionManager String
fp ByteString
cn Maybe ByteString
cd Maybe Int
to RedisDB
c =
Text
-> Text
-> Maybe (IO String)
-> Initializer b SessionManager SessionManager
-> SnapletInit b SessionManager
forall b v.
Text
-> Text
-> Maybe (IO String)
-> Initializer b v v
-> SnapletInit b v
makeSnaplet Text
"RedisSession"
Text
"A snaplet providing sessions via HTTP cookies with a Redis backend."
Maybe (IO String)
forall a. Maybe a
Nothing (Initializer b SessionManager SessionManager
-> SnapletInit b SessionManager)
-> Initializer b SessionManager SessionManager
-> SnapletInit b SessionManager
forall a b. (a -> b) -> a -> b
$ IO SessionManager -> Initializer b SessionManager SessionManager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SessionManager -> Initializer b SessionManager SessionManager)
-> IO SessionManager -> Initializer b SessionManager SessionManager
forall a b. (a -> b) -> a -> b
$ do
Key
key <- String -> IO Key
getKey String
fp
RNG
rng <- IO RNG -> IO RNG
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO RNG
mkRNG
SessionManager -> IO SessionManager
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionManager -> IO SessionManager)
-> SessionManager -> IO SessionManager
forall a b. (a -> b) -> a -> b
$! RedisSessionManager -> SessionManager
forall a. ISessionManager a => a -> SessionManager
SessionManager
(RedisSessionManager -> SessionManager)
-> RedisSessionManager -> SessionManager
forall a b. (a -> b) -> a -> b
$ Maybe RedisSession
-> Key
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> RNG
-> Connection
-> RedisSessionManager
RedisSessionManager Maybe RedisSession
forall a. Maybe a
Nothing Key
key ByteString
cn Maybe ByteString
cd Maybe Int
to RNG
rng (RedisDB -> Connection
_connection RedisDB
c)
instance ISessionManager RedisSessionManager where
load :: RedisSessionManager -> Snap RedisSessionManager
load mgr :: RedisSessionManager
mgr@(RedisSessionManager Maybe RedisSession
r Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
rng Connection
con) =
case Maybe RedisSession
r of
Just RedisSession
_ -> RedisSessionManager -> Snap RedisSessionManager
forall (m :: * -> *) a. Monad m => a -> m a
return RedisSessionManager
mgr
Maybe RedisSession
Nothing -> do
Maybe Payload
pl <- RedisSessionManager -> Snap (Maybe Payload)
getPayload RedisSessionManager
mgr
case Maybe Payload
pl of
Maybe Payload
Nothing -> IO RedisSessionManager -> Snap RedisSessionManager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RedisSessionManager -> Snap RedisSessionManager)
-> IO RedisSessionManager -> Snap RedisSessionManager
forall a b. (a -> b) -> a -> b
$ RedisSessionManager -> IO RedisSessionManager
loadDefSession RedisSessionManager
mgr
Just (Payload ByteString
x) -> do
let c :: Either String RedisSession
c = ByteString -> Either String RedisSession
forall a. Serialize a => ByteString -> Either String a
S.decode ByteString
x
case Either String RedisSession
c of
Left String
_ -> IO RedisSessionManager -> Snap RedisSessionManager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RedisSessionManager -> Snap RedisSessionManager)
-> IO RedisSessionManager -> Snap RedisSessionManager
forall a b. (a -> b) -> a -> b
$ RedisSessionManager -> IO RedisSessionManager
loadDefSession RedisSessionManager
mgr
Right RedisSession
cs -> IO RedisSessionManager -> Snap RedisSessionManager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RedisSessionManager -> Snap RedisSessionManager)
-> IO RedisSessionManager -> Snap RedisSessionManager
forall a b. (a -> b) -> a -> b
$ do
RedisSession
sess <- Connection -> Redis RedisSession -> IO RedisSession
forall a. Connection -> Redis a -> IO a
runRedis Connection
con (Redis RedisSession -> IO RedisSession)
-> Redis RedisSession -> IO RedisSession
forall a b. (a -> b) -> a -> b
$ do
Either Reply [(ByteString, ByteString)]
l <- ByteString -> Redis (Either Reply [(ByteString, ByteString)])
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f [(ByteString, ByteString)])
hgetall (Text -> ByteString
sessionKey (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ RedisSession -> Text
rsCSRFToken RedisSession
cs)
case Either Reply [(ByteString, ByteString)]
l of
Left Reply
_ -> IO RedisSession -> Redis RedisSession
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RedisSession -> Redis RedisSession)
-> IO RedisSession -> Redis RedisSession
forall a b. (a -> b) -> a -> b
$ RNG -> IO RedisSession
mkCookieSession RNG
rng
Right [(ByteString, ByteString)]
l' -> do
let rs :: RedisSession
rs = RedisSession
cs { rsSession :: Session
rsSession = [(Text, Text)] -> Session
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, Text)] -> Session) -> [(Text, Text)] -> Session
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> (Text, Text))
-> [(ByteString, ByteString)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, ByteString) -> (Text, Text)
decodeTuple [(ByteString, ByteString)]
l'}
RedisSession -> Redis RedisSession
forall (m :: * -> *) a. Monad m => a -> m a
return RedisSession
rs
RedisSessionManager -> IO RedisSessionManager
forall (m :: * -> *) a. Monad m => a -> m a
return RedisSessionManager
mgr { session :: Maybe RedisSession
session = RedisSession -> Maybe RedisSession
forall a. a -> Maybe a
Just RedisSession
sess }
commit :: RedisSessionManager -> Snap ()
commit mgr :: RedisSessionManager
mgr@(RedisSessionManager Maybe RedisSession
r Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
to RNG
rng Connection
con) = do
Payload
pl <- case Maybe RedisSession
r of
Just RedisSession
r' -> IO Payload -> Snap Payload
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Payload -> Snap Payload) -> IO Payload -> Snap Payload
forall a b. (a -> b) -> a -> b
$
Connection -> Redis Payload -> IO Payload
forall a. Connection -> Redis a -> IO a
runRedis Connection
con (Redis Payload -> IO Payload) -> Redis Payload -> IO Payload
forall a b. (a -> b) -> a -> b
$ do
TxResult (Status, Bool)
res <- RedisTx (Queued (Status, Bool)) -> Redis (TxResult (Status, Bool))
forall a. RedisTx (Queued a) -> Redis (TxResult a)
multiExec (RedisTx (Queued (Status, Bool))
-> Redis (TxResult (Status, Bool)))
-> RedisTx (Queued (Status, Bool))
-> Redis (TxResult (Status, Bool))
forall a b. (a -> b) -> a -> b
$ do
Queued Integer
_ <- [ByteString] -> RedisTx (Queued Integer)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
[ByteString] -> m (f Integer)
del [Text -> ByteString
sessionKey (RedisSession -> Text
rsCSRFToken RedisSession
r')]
let sess :: [(ByteString, ByteString)]
sess = ((Text, Text) -> (ByteString, ByteString))
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> (ByteString, ByteString)
encodeTuple ([(Text, Text)] -> [(ByteString, ByteString)])
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Session -> [(Text, Text)]
forall k v. HashMap k v -> [(k, v)]
HM.toList (RedisSession -> Session
rsSession RedisSession
r')
Queued Status
res1 <- case [(ByteString, ByteString)]
sess of
[] -> ByteString -> [(ByteString, ByteString)] -> RedisTx (Queued Status)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> [(ByteString, ByteString)] -> m (f Status)
hmset (Text -> ByteString
sessionKey (RedisSession -> Text
rsCSRFToken RedisSession
r')) [(ByteString
"",ByteString
"")]
[(ByteString, ByteString)]
_ -> ByteString -> [(ByteString, ByteString)] -> RedisTx (Queued Status)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> [(ByteString, ByteString)] -> m (f Status)
hmset (Text -> ByteString
sessionKey (RedisSession -> Text
rsCSRFToken RedisSession
r')) [(ByteString, ByteString)]
sess
Queued Bool
res2 <- case Maybe Int
to of
Just Int
i -> ByteString -> Integer -> RedisTx (Queued Bool)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> Integer -> m (f Bool)
expire (Text -> ByteString
sessionKey (RedisSession -> Text
rsCSRFToken RedisSession
r')) (Integer -> RedisTx (Queued Bool))
-> Integer -> RedisTx (Queued Bool)
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
i
Maybe Int
Nothing -> ByteString -> RedisTx (Queued Bool)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f Bool)
persist (Text -> ByteString
sessionKey (RedisSession -> Text
rsCSRFToken RedisSession
r'))
Queued (Status, Bool) -> RedisTx (Queued (Status, Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return (Queued (Status, Bool) -> RedisTx (Queued (Status, Bool)))
-> Queued (Status, Bool) -> RedisTx (Queued (Status, Bool))
forall a b. (a -> b) -> a -> b
$ (,) (Status -> Bool -> (Status, Bool))
-> Queued Status -> Queued (Bool -> (Status, Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Queued Status
res1 Queued (Bool -> (Status, Bool))
-> Queued Bool -> Queued (Status, Bool)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Queued Bool
res2
case TxResult (Status, Bool)
res of
TxSuccess (Status, Bool)
_ -> Payload -> Redis Payload
forall (m :: * -> *) a. Monad m => a -> m a
return (Payload -> Redis Payload)
-> (ByteString -> Payload) -> ByteString -> Redis Payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Payload
Payload (ByteString -> Redis Payload) -> ByteString -> Redis Payload
forall a b. (a -> b) -> a -> b
$ RedisSession -> ByteString
forall a. Serialize a => a -> ByteString
S.encode RedisSession
r'
TxError String
e -> String -> Redis Payload
forall a. HasCallStack => String -> a
error String
e
TxResult (Status, Bool)
TxAborted -> String -> Redis Payload
forall a. HasCallStack => String -> a
error String
"transaction aborted"
Maybe RedisSession
Nothing -> IO Payload -> Snap Payload
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Payload -> Snap Payload) -> IO Payload -> Snap Payload
forall a b. (a -> b) -> a -> b
$ ByteString -> Payload
Payload (ByteString -> Payload)
-> (RedisSession -> ByteString) -> RedisSession -> Payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RedisSession -> ByteString
forall a. Serialize a => a -> ByteString
S.encode (RedisSession -> Payload) -> IO RedisSession -> IO Payload
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RNG -> IO RedisSession
mkCookieSession RNG
rng
RedisSessionManager -> Payload -> Snap ()
setPayload RedisSessionManager
mgr Payload
pl
reset :: RedisSessionManager -> Snap RedisSessionManager
reset mgr :: RedisSessionManager
mgr@(RedisSessionManager Maybe RedisSession
r Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
_ Connection
con) = do
case Maybe RedisSession
r of
Just RedisSession
r' -> IO () -> Snap ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Snap ()) -> IO () -> Snap ()
forall a b. (a -> b) -> a -> b
$
Connection -> Redis () -> IO ()
forall a. Connection -> Redis a -> IO a
runRedis Connection
con (Redis () -> IO ()) -> Redis () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Either Reply Integer
res1 <- [ByteString] -> Redis (Either Reply Integer)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
[ByteString] -> m (f Integer)
del [Text -> ByteString
sessionKey (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ RedisSession -> Text
rsCSRFToken RedisSession
r']
case Either Reply Integer
res1 of
Left Reply
e -> String -> Redis ()
forall a. HasCallStack => String -> a
error (String -> Redis ()) -> String -> Redis ()
forall a b. (a -> b) -> a -> b
$ Reply -> String
forall a. Show a => a -> String
show Reply
e
Either Reply Integer
_ -> () -> Redis ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe RedisSession
_ -> () -> Snap ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
RedisSession
cs <- IO RedisSession -> Snap RedisSession
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RedisSession -> Snap RedisSession)
-> IO RedisSession -> Snap RedisSession
forall a b. (a -> b) -> a -> b
$ RNG -> IO RedisSession
mkCookieSession (RedisSessionManager -> RNG
randomNumberGenerator RedisSessionManager
mgr)
RedisSessionManager -> Snap RedisSessionManager
forall (m :: * -> *) a. Monad m => a -> m a
return (RedisSessionManager -> Snap RedisSessionManager)
-> RedisSessionManager -> Snap RedisSessionManager
forall a b. (a -> b) -> a -> b
$ RedisSessionManager
mgr { session :: Maybe RedisSession
session = RedisSession -> Maybe RedisSession
forall a. a -> Maybe a
Just RedisSession
cs }
touch :: RedisSessionManager -> RedisSessionManager
touch = RedisSessionManager -> RedisSessionManager
forall a. a -> a
id
insert :: Text -> Text -> RedisSessionManager -> RedisSessionManager
insert Text
k Text
v mgr :: RedisSessionManager
mgr@(RedisSessionManager Maybe RedisSession
r Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
_ Connection
_) = case Maybe RedisSession
r of
Just RedisSession
r' -> RedisSessionManager
mgr { session :: Maybe RedisSession
session = RedisSession -> Maybe RedisSession
forall a. a -> Maybe a
Just (RedisSession -> Maybe RedisSession)
-> RedisSession -> Maybe RedisSession
forall a b. (a -> b) -> a -> b
$ (Session -> Session) -> RedisSession -> RedisSession
modSession (Text -> Text -> Session -> Session
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
k Text
v) RedisSession
r' }
Maybe RedisSession
Nothing -> RedisSessionManager
mgr
lookup :: Text -> RedisSessionManager -> Maybe Text
lookup Text
k (RedisSessionManager Maybe RedisSession
r Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
_ Connection
_) = Maybe RedisSession
r Maybe RedisSession -> (RedisSession -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Session -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
k (Session -> Maybe Text)
-> (RedisSession -> Session) -> RedisSession -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RedisSession -> Session
rsSession
delete :: Text -> RedisSessionManager -> RedisSessionManager
delete Text
k mgr :: RedisSessionManager
mgr@(RedisSessionManager Maybe RedisSession
r Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
_ Connection
_) = case Maybe RedisSession
r of
Just RedisSession
r' -> RedisSessionManager
mgr { session :: Maybe RedisSession
session = RedisSession -> Maybe RedisSession
forall a. a -> Maybe a
Just (RedisSession -> Maybe RedisSession)
-> RedisSession -> Maybe RedisSession
forall a b. (a -> b) -> a -> b
$ (Session -> Session) -> RedisSession -> RedisSession
modSession (Text -> Session -> Session
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete Text
k) RedisSession
r' }
Maybe RedisSession
Nothing -> RedisSessionManager
mgr
csrf :: RedisSessionManager -> Text
csrf (RedisSessionManager Maybe RedisSession
r Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
_ Connection
_) = Text -> (RedisSession -> Text) -> Maybe RedisSession -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" RedisSession -> Text
rsCSRFToken Maybe RedisSession
r
toList :: RedisSessionManager -> [(Text, Text)]
toList (RedisSessionManager Maybe RedisSession
r Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
_ Connection
_) = case Maybe RedisSession
r of
Just RedisSession
r' -> Session -> [(Text, Text)]
forall k v. HashMap k v -> [(k, v)]
HM.toList (Session -> [(Text, Text)])
-> (RedisSession -> Session) -> RedisSession -> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RedisSession -> Session
rsSession (RedisSession -> [(Text, Text)]) -> RedisSession -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ RedisSession
r'
Maybe RedisSession
Nothing -> []
newtype Payload = Payload ByteString
deriving (Payload -> Payload -> Bool
(Payload -> Payload -> Bool)
-> (Payload -> Payload -> Bool) -> Eq Payload
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Payload -> Payload -> Bool
$c/= :: Payload -> Payload -> Bool
== :: Payload -> Payload -> Bool
$c== :: Payload -> Payload -> Bool
Eq, Int -> Payload -> ShowS
[Payload] -> ShowS
Payload -> String
(Int -> Payload -> ShowS)
-> (Payload -> String) -> ([Payload] -> ShowS) -> Show Payload
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Payload] -> ShowS
$cshowList :: [Payload] -> ShowS
show :: Payload -> String
$cshow :: Payload -> String
showsPrec :: Int -> Payload -> ShowS
$cshowsPrec :: Int -> Payload -> ShowS
Show, Eq Payload
Eq Payload
-> (Payload -> Payload -> Ordering)
-> (Payload -> Payload -> Bool)
-> (Payload -> Payload -> Bool)
-> (Payload -> Payload -> Bool)
-> (Payload -> Payload -> Bool)
-> (Payload -> Payload -> Payload)
-> (Payload -> Payload -> Payload)
-> Ord Payload
Payload -> Payload -> Bool
Payload -> Payload -> Ordering
Payload -> Payload -> Payload
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Payload -> Payload -> Payload
$cmin :: Payload -> Payload -> Payload
max :: Payload -> Payload -> Payload
$cmax :: Payload -> Payload -> Payload
>= :: Payload -> Payload -> Bool
$c>= :: Payload -> Payload -> Bool
> :: Payload -> Payload -> Bool
$c> :: Payload -> Payload -> Bool
<= :: Payload -> Payload -> Bool
$c<= :: Payload -> Payload -> Bool
< :: Payload -> Payload -> Bool
$c< :: Payload -> Payload -> Bool
compare :: Payload -> Payload -> Ordering
$ccompare :: Payload -> Payload -> Ordering
$cp1Ord :: Eq Payload
Ord, Get Payload
Putter Payload
Putter Payload -> Get Payload -> Serialize Payload
forall t. Putter t -> Get t -> Serialize t
get :: Get Payload
$cget :: Get Payload
put :: Putter Payload
$cput :: Putter Payload
Serialize)
getPayload :: RedisSessionManager -> Snap (Maybe Payload)
getPayload :: RedisSessionManager -> Snap (Maybe Payload)
getPayload RedisSessionManager
mgr = ByteString -> Key -> Maybe Int -> Snap (Maybe Payload)
forall (m :: * -> *) t.
(MonadSnap m, Serialize t) =>
ByteString -> Key -> Maybe Int -> m (Maybe t)
getSecureCookie (RedisSessionManager -> ByteString
cookieName RedisSessionManager
mgr) (RedisSessionManager -> Key
siteKey RedisSessionManager
mgr) (RedisSessionManager -> Maybe Int
timeOut RedisSessionManager
mgr)
setPayload :: RedisSessionManager -> Payload -> Snap ()
setPayload :: RedisSessionManager -> Payload -> Snap ()
setPayload RedisSessionManager
mgr = ByteString
-> Maybe ByteString -> Key -> Maybe Int -> Payload -> Snap ()
forall (m :: * -> *) t.
(MonadSnap m, Serialize t) =>
ByteString -> Maybe ByteString -> Key -> Maybe Int -> t -> m ()
setSecureCookie
(RedisSessionManager -> ByteString
cookieName RedisSessionManager
mgr)
#if MIN_VERSION_snap(1,0,0)
(RedisSessionManager -> Maybe ByteString
cookieDomain RedisSessionManager
mgr)
#endif
(RedisSessionManager -> Key
siteKey RedisSessionManager
mgr) (RedisSessionManager -> Maybe Int
timeOut RedisSessionManager
mgr)