------------------------------------------------------------------------------
{-# 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
    { RedisSession -> Text
rsCSRFToken :: Text
    , RedisSession -> Session
rsSession :: 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)


------------------------------------------------------------------------------
--Only serialize the rsCSRFToken to send to the client
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


------------------------------------------------------------------------------
-- | The manager data type to be stuffed into 'SessionManager'
--
data RedisSessionManager = RedisSessionManager {
      RedisSessionManager -> Maybe RedisSession
session               :: Maybe RedisSession
        -- ^ Per request cache for 'CookieSession'
    , RedisSessionManager -> Key
siteKey               :: Key
        -- ^ A long encryption key used for secure cookie transport
    , RedisSessionManager -> ByteString
cookieName            :: ByteString
        -- ^ Cookie name for the session system
    , RedisSessionManager -> Maybe ByteString
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.
    , RedisSessionManager -> Maybe Int
timeOut               :: Maybe Int
        -- ^ Session cookies will be considered "stale" after this many
        -- seconds.
    , RedisSessionManager -> RNG
randomNumberGenerator :: RNG
        -- ^ handle to a random number generator
    , RedisSessionManager -> Connection
_redisConnection :: Connection
        -- ^ Redis connection to store session info
} 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

------------------------------------------------------------------------------
-- | 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 :: 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 grabs the session from redis.
    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 writes to redis and sends the csrf to client and also sets the
    --timeout.
    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')]   --Clear old values
                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


    --------------------------------------------------------------------------
    --clear the session from redis and return a new empty one
    {-reset mgr@(RedisSessionManager _ _ _ _ _ _)  = trace "RedisSessionManager reset" $ do-}
    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 -> []

------------------------------------------------------------------------------
-- | A session payload to be stored in a SecureCookie.
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)


------------------------------------------------------------------------------
-- | Get the current client-side value
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)


------------------------------------------------------------------------------
-- | Set the client-side value
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)