-- | Internal module exposing the guts of the package.  Use at
-- your own risk.  No API stability guarantees apply.
module Web.ServerSession.Backend.Redis.Internal
  ( RedisStorage(..)
  , RedisStorageException(..)

  , transaction
  , unwrap
  , rSessionKey
  , rAuthKey

  , RedisSession(..)
  , parseSession
  , printSession
  , parseUTCTime
  , printUTCTime
  , timeFormat

  , getSessionImpl
  , deleteSessionImpl
  , removeSessionFromAuthId
  , insertSessionForAuthId
  , deleteAllSessionsOfAuthIdImpl
  , insertSessionImpl
  , replaceSessionImpl
  , throwRS
  ) where

import Control.Applicative as A
import Control.Arrow (first)
import Control.Monad (void, when)
import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString)
import Data.List (partition)
import Data.Maybe (fromMaybe, catMaybes)
import Data.Proxy (Proxy(..))
import Data.Typeable (Typeable)
import Web.PathPieces (toPathPiece)
import Web.ServerSession.Core

import qualified Control.Exception as E
import qualified Database.Redis as R
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.HashMap.Strict as HM
import qualified Data.Text.Encoding as TE
import qualified Data.Time.Clock as TI
import qualified Data.Time.Clock.POSIX as TP
import qualified Data.Time.Format as TI

#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif

----------------------------------------------------------------------


-- | Session storage backend using Redis via the @hedis@ package.
data RedisStorage sess =
  RedisStorage
    { RedisStorage sess -> Connection
connPool :: R.Connection
      -- ^ Connection pool to the Redis server.
    , RedisStorage sess -> Maybe NominalDiffTime
idleTimeout :: Maybe TI.NominalDiffTime
    -- ^ How long should a session live after last access
    , RedisStorage sess -> Maybe NominalDiffTime
absoluteTimeout :: Maybe TI.NominalDiffTime
    -- ^ How long should a session live after creation
    } deriving (Typeable)


-- | We do not provide any ACID guarantees for different actions
-- running inside the same @TransactionM RedisStorage@.
instance RedisSession sess => Storage (RedisStorage sess) where
  type SessionData  (RedisStorage sess) = sess
  type TransactionM (RedisStorage sess) = R.Redis
  runTransactionM :: RedisStorage sess -> TransactionM (RedisStorage sess) a -> IO a
runTransactionM = Connection -> Redis a -> IO a
forall a. Connection -> Redis a -> IO a
R.runRedis (Connection -> Redis a -> IO a)
-> (RedisStorage sess -> Connection)
-> RedisStorage sess
-> Redis a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RedisStorage sess -> Connection
forall sess. RedisStorage sess -> Connection
connPool
  getSession :: RedisStorage sess
-> SessionId (SessionData (RedisStorage sess))
-> TransactionM
     (RedisStorage sess)
     (Maybe (Session (SessionData (RedisStorage sess))))
getSession                RedisStorage sess
_ = SessionId (SessionData (RedisStorage sess))
-> TransactionM
     (RedisStorage sess)
     (Maybe (Session (SessionData (RedisStorage sess))))
forall sess.
RedisSession sess =>
SessionId sess -> Redis (Maybe (Session sess))
getSessionImpl
  deleteSession :: RedisStorage sess
-> SessionId (SessionData (RedisStorage sess))
-> TransactionM (RedisStorage sess) ()
deleteSession             RedisStorage sess
_ = SessionId (SessionData (RedisStorage sess))
-> TransactionM (RedisStorage sess) ()
forall sess. RedisSession sess => SessionId sess -> Redis ()
deleteSessionImpl
  deleteAllSessionsOfAuthId :: RedisStorage sess -> AuthId -> TransactionM (RedisStorage sess) ()
deleteAllSessionsOfAuthId RedisStorage sess
_ = AuthId -> Redis ()
AuthId -> TransactionM (RedisStorage sess) ()
deleteAllSessionsOfAuthIdImpl
  insertSession :: RedisStorage sess
-> Session (SessionData (RedisStorage sess))
-> TransactionM (RedisStorage sess) ()
insertSession               = RedisStorage sess
-> Session (SessionData (RedisStorage sess))
-> TransactionM (RedisStorage sess) ()
forall sess.
RedisSession sess =>
RedisStorage sess -> Session sess -> Redis ()
insertSessionImpl
  replaceSession :: RedisStorage sess
-> Session (SessionData (RedisStorage sess))
-> TransactionM (RedisStorage sess) ()
replaceSession              = RedisStorage sess
-> Session (SessionData (RedisStorage sess))
-> TransactionM (RedisStorage sess) ()
forall sess.
RedisSession sess =>
RedisStorage sess -> Session sess -> Redis ()
replaceSessionImpl


-- | An exception thrown by the @serversession-backend-redis@
-- package.
data RedisStorageException =
    ExpectedTxSuccess (R.TxResult ())
    -- ^ We expected 'TxSuccess' but got something else.
  | ExpectedRight R.Reply
    -- ^ We expected 'Right' from an @Either 'R.Reply' a@ but got
    -- 'Left'.
    deriving (Int -> RedisStorageException -> ShowS
[RedisStorageException] -> ShowS
RedisStorageException -> String
(Int -> RedisStorageException -> ShowS)
-> (RedisStorageException -> String)
-> ([RedisStorageException] -> ShowS)
-> Show RedisStorageException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RedisStorageException] -> ShowS
$cshowList :: [RedisStorageException] -> ShowS
show :: RedisStorageException -> String
$cshow :: RedisStorageException -> String
showsPrec :: Int -> RedisStorageException -> ShowS
$cshowsPrec :: Int -> RedisStorageException -> ShowS
Show, Typeable)

instance E.Exception RedisStorageException


----------------------------------------------------------------------


-- | Run the given Redis transaction and force its result.
-- Throws a 'RedisStorageException' if the result is not
-- 'TxSuccess'.
transaction :: R.RedisTx (R.Queued ()) -> R.Redis ()
transaction :: RedisTx (Queued ()) -> Redis ()
transaction RedisTx (Queued ())
tx = do
  TxResult ()
ret <- RedisTx (Queued ()) -> Redis (TxResult ())
forall a. RedisTx (Queued a) -> Redis (TxResult a)
R.multiExec RedisTx (Queued ())
tx
  case TxResult ()
ret of
   R.TxSuccess () -> () -> Redis ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   TxResult ()
_              -> IO () -> Redis ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Redis ()) -> IO () -> Redis ()
forall a b. (a -> b) -> a -> b
$ RedisStorageException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (RedisStorageException -> IO ()) -> RedisStorageException -> IO ()
forall a b. (a -> b) -> a -> b
$ TxResult () -> RedisStorageException
ExpectedTxSuccess TxResult ()
ret


-- | Unwraps an @Either 'R.Reply' a@ by throwing an exception if
-- not @Right@.
unwrap :: R.Redis (Either R.Reply a) -> R.Redis a
unwrap :: Redis (Either Reply a) -> Redis a
unwrap Redis (Either Reply a)
act = Redis (Either Reply a)
act Redis (Either Reply a) -> (Either Reply a -> Redis a) -> Redis a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Reply -> Redis a) -> (a -> Redis a) -> Either Reply a -> Redis a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO a -> Redis a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Redis a) -> (Reply -> IO a) -> Reply -> Redis a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RedisStorageException -> IO a
forall e a. Exception e => e -> IO a
E.throwIO (RedisStorageException -> IO a)
-> (Reply -> RedisStorageException) -> Reply -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reply -> RedisStorageException
ExpectedRight) a -> Redis a
forall (m :: * -> *) a. Monad m => a -> m a
return


-- | Redis key for the given session ID.
rSessionKey :: SessionId sess -> ByteString
rSessionKey :: SessionId sess -> AuthId
rSessionKey = AuthId -> AuthId -> AuthId
B.append AuthId
"ssr:session:" (AuthId -> AuthId)
-> (SessionId sess -> AuthId) -> SessionId sess -> AuthId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> AuthId
TE.encodeUtf8 (Text -> AuthId)
-> (SessionId sess -> Text) -> SessionId sess -> AuthId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionId sess -> Text
forall s. PathPiece s => s -> Text
toPathPiece


-- | Redis key for the given auth ID.
rAuthKey :: AuthId -> ByteString
rAuthKey :: AuthId -> AuthId
rAuthKey = AuthId -> AuthId -> AuthId
B.append AuthId
"ssr:authid:"


----------------------------------------------------------------------


-- | Class for data types that can be used as session data for
-- the Redis backend.
--
-- It should hold that
--
-- @
-- fromHash p . perm . toHash p  ===  id
-- @
--
-- for all list permutations @perm :: [a] -> [a]@,
-- where @p :: Proxy sess@.
class IsSessionData sess => RedisSession sess where
  -- | Transform a decomposed session into a Redis hash.  Keys
  -- will be prepended with @\"data:\"@ before being stored.
  toHash   :: Proxy sess -> Decomposed sess -> [(ByteString, ByteString)]

  -- | Parse back a Redis hash into session data.
  fromHash :: Proxy sess -> [(ByteString, ByteString)] -> Decomposed sess


-- | Assumes that keys are UTF-8 encoded when parsing (which is
-- true if keys are always generated via @toHash@).
instance RedisSession SessionMap where
  toHash :: Proxy SessionMap -> Decomposed SessionMap -> [(AuthId, AuthId)]
toHash   Proxy SessionMap
_ = ((Text, AuthId) -> (AuthId, AuthId))
-> [(Text, AuthId)] -> [(AuthId, AuthId)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> AuthId) -> (Text, AuthId) -> (AuthId, AuthId)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Text -> AuthId
TE.encodeUtf8) ([(Text, AuthId)] -> [(AuthId, AuthId)])
-> (SessionMap -> [(Text, AuthId)])
-> SessionMap
-> [(AuthId, AuthId)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text AuthId -> [(Text, AuthId)]
forall k v. HashMap k v -> [(k, v)]
HM.toList (HashMap Text AuthId -> [(Text, AuthId)])
-> (SessionMap -> HashMap Text AuthId)
-> SessionMap
-> [(Text, AuthId)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionMap -> HashMap Text AuthId
unSessionMap
  fromHash :: Proxy SessionMap -> [(AuthId, AuthId)] -> Decomposed SessionMap
fromHash Proxy SessionMap
_ = HashMap Text AuthId -> SessionMap
SessionMap (HashMap Text AuthId -> SessionMap)
-> ([(AuthId, AuthId)] -> HashMap Text AuthId)
-> [(AuthId, AuthId)]
-> SessionMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, AuthId)] -> HashMap Text AuthId
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, AuthId)] -> HashMap Text AuthId)
-> ([(AuthId, AuthId)] -> [(Text, AuthId)])
-> [(AuthId, AuthId)]
-> HashMap Text AuthId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AuthId, AuthId) -> (Text, AuthId))
-> [(AuthId, AuthId)] -> [(Text, AuthId)]
forall a b. (a -> b) -> [a] -> [b]
map ((AuthId -> Text) -> (AuthId, AuthId) -> (Text, AuthId)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first AuthId -> Text
TE.decodeUtf8)


-- | Parse a 'Session' from a Redis hash.
parseSession
  :: forall sess. RedisSession sess
  => SessionId sess
  -> [(ByteString, ByteString)]
  -> Maybe (Session sess)
parseSession :: SessionId sess -> [(AuthId, AuthId)] -> Maybe (Session sess)
parseSession SessionId sess
_   []  = Maybe (Session sess)
forall a. Maybe a
Nothing
parseSession SessionId sess
sid [(AuthId, AuthId)]
bss =
  let ([(AuthId, AuthId)]
externalList, [(AuthId, AuthId)]
internalList) = ((AuthId, AuthId) -> Bool)
-> [(AuthId, AuthId)] -> ([(AuthId, AuthId)], [(AuthId, AuthId)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (AuthId -> AuthId -> Bool
B8.isPrefixOf AuthId
"data:" (AuthId -> Bool)
-> ((AuthId, AuthId) -> AuthId) -> (AuthId, AuthId) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AuthId, AuthId) -> AuthId
forall a b. (a, b) -> a
fst) [(AuthId, AuthId)]
bss
      authId :: Maybe AuthId
authId     = AuthId -> [(AuthId, AuthId)] -> Maybe AuthId
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup AuthId
"internal:authId" [(AuthId, AuthId)]
internalList
      createdAt :: UTCTime
createdAt  = AuthId -> UTCTime
parseUTCTime (AuthId -> UTCTime) -> AuthId -> UTCTime
forall a b. (a -> b) -> a -> b
$ AuthId -> AuthId
lookup' AuthId
"internal:createdAt"
      accessedAt :: UTCTime
accessedAt = AuthId -> UTCTime
parseUTCTime (AuthId -> UTCTime) -> AuthId -> UTCTime
forall a b. (a -> b) -> a -> b
$ AuthId -> AuthId
lookup' AuthId
"internal:accessedAt"
      lookup' :: AuthId -> AuthId
lookup' AuthId
k = AuthId -> Maybe AuthId -> AuthId
forall a. a -> Maybe a -> a
fromMaybe (String -> AuthId
forall a. HasCallStack => String -> a
error String
err) (Maybe AuthId -> AuthId) -> Maybe AuthId -> AuthId
forall a b. (a -> b) -> a -> b
$ AuthId -> [(AuthId, AuthId)] -> Maybe AuthId
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup AuthId
k [(AuthId, AuthId)]
internalList
        where err :: String
err = String
"serversession-backend-redis/parseSession: missing key " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AuthId -> String
forall a. Show a => a -> String
show AuthId
k
      data_ :: Decomposed sess
data_ = Proxy sess -> [(AuthId, AuthId)] -> Decomposed sess
forall sess.
RedisSession sess =>
Proxy sess -> [(AuthId, AuthId)] -> Decomposed sess
fromHash Proxy sess
p ([(AuthId, AuthId)] -> Decomposed sess)
-> [(AuthId, AuthId)] -> Decomposed sess
forall a b. (a -> b) -> a -> b
$ ((AuthId, AuthId) -> (AuthId, AuthId))
-> [(AuthId, AuthId)] -> [(AuthId, AuthId)]
forall a b. (a -> b) -> [a] -> [b]
map ((AuthId -> AuthId) -> (AuthId, AuthId) -> (AuthId, AuthId)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first AuthId -> AuthId
removePrefix) [(AuthId, AuthId)]
externalList
        where removePrefix :: AuthId -> AuthId
removePrefix AuthId
bs = let (AuthId
"data:", AuthId
key) = Int -> AuthId -> (AuthId, AuthId)
B8.splitAt Int
5 AuthId
bs in AuthId
key
              p :: Proxy sess
p = Proxy sess
forall k (t :: k). Proxy t
Proxy :: Proxy sess
  in Session sess -> Maybe (Session sess)
forall a. a -> Maybe a
Just Session :: forall sess.
SessionId sess
-> Maybe AuthId
-> Decomposed sess
-> UTCTime
-> UTCTime
-> Session sess
Session
       { sessionKey :: SessionId sess
sessionKey        = SessionId sess
sid
       , sessionAuthId :: Maybe AuthId
sessionAuthId     = Maybe AuthId
authId
       , sessionData :: Decomposed sess
sessionData       = Decomposed sess
data_
       , sessionCreatedAt :: UTCTime
sessionCreatedAt  = UTCTime
createdAt
       , sessionAccessedAt :: UTCTime
sessionAccessedAt = UTCTime
accessedAt
       }


-- | Convert a 'Session' into a Redis hash.
printSession :: forall sess. RedisSession sess => Session sess -> [(ByteString, ByteString)]
printSession :: Session sess -> [(AuthId, AuthId)]
printSession Session {Maybe AuthId
UTCTime
SessionId sess
Decomposed sess
sessionAccessedAt :: UTCTime
sessionCreatedAt :: UTCTime
sessionData :: Decomposed sess
sessionAuthId :: Maybe AuthId
sessionKey :: SessionId sess
sessionAccessedAt :: forall sess. Session sess -> UTCTime
sessionCreatedAt :: forall sess. Session sess -> UTCTime
sessionData :: forall sess. Session sess -> Decomposed sess
sessionAuthId :: forall sess. Session sess -> Maybe AuthId
sessionKey :: forall sess. Session sess -> SessionId sess
..} =
  ([(AuthId, AuthId)] -> [(AuthId, AuthId)])
-> (AuthId -> [(AuthId, AuthId)] -> [(AuthId, AuthId)])
-> Maybe AuthId
-> [(AuthId, AuthId)]
-> [(AuthId, AuthId)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(AuthId, AuthId)] -> [(AuthId, AuthId)]
forall a. a -> a
id ((:) ((AuthId, AuthId) -> [(AuthId, AuthId)] -> [(AuthId, AuthId)])
-> (AuthId -> (AuthId, AuthId))
-> AuthId
-> [(AuthId, AuthId)]
-> [(AuthId, AuthId)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) AuthId
"internal:authId") Maybe AuthId
sessionAuthId ([(AuthId, AuthId)] -> [(AuthId, AuthId)])
-> [(AuthId, AuthId)] -> [(AuthId, AuthId)]
forall a b. (a -> b) -> a -> b
$
  (:) (AuthId
"internal:createdAt",  UTCTime -> AuthId
printUTCTime UTCTime
sessionCreatedAt) ([(AuthId, AuthId)] -> [(AuthId, AuthId)])
-> [(AuthId, AuthId)] -> [(AuthId, AuthId)]
forall a b. (a -> b) -> a -> b
$
  (:) (AuthId
"internal:accessedAt", UTCTime -> AuthId
printUTCTime UTCTime
sessionAccessedAt) ([(AuthId, AuthId)] -> [(AuthId, AuthId)])
-> [(AuthId, AuthId)] -> [(AuthId, AuthId)]
forall a b. (a -> b) -> a -> b
$
  ((AuthId, AuthId) -> (AuthId, AuthId))
-> [(AuthId, AuthId)] -> [(AuthId, AuthId)]
forall a b. (a -> b) -> [a] -> [b]
map ((AuthId -> AuthId) -> (AuthId, AuthId) -> (AuthId, AuthId)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((AuthId -> AuthId) -> (AuthId, AuthId) -> (AuthId, AuthId))
-> (AuthId -> AuthId) -> (AuthId, AuthId) -> (AuthId, AuthId)
forall a b. (a -> b) -> a -> b
$ AuthId -> AuthId -> AuthId
B8.append AuthId
"data:") ([(AuthId, AuthId)] -> [(AuthId, AuthId)])
-> [(AuthId, AuthId)] -> [(AuthId, AuthId)]
forall a b. (a -> b) -> a -> b
$
  Proxy sess -> Decomposed sess -> [(AuthId, AuthId)]
forall sess.
RedisSession sess =>
Proxy sess -> Decomposed sess -> [(AuthId, AuthId)]
toHash (Proxy sess
forall k (t :: k). Proxy t
Proxy :: Proxy sess) Decomposed sess
sessionData


-- | Parse 'UTCTime' from a 'ByteString' stored on Redis.  Uses
-- 'error' on parse error.
parseUTCTime :: ByteString -> TI.UTCTime
#if MIN_VERSION_time(1,5,0)
parseUTCTime :: AuthId -> UTCTime
parseUTCTime = Bool -> TimeLocale -> String -> String -> UTCTime
forall t.
ParseTime t =>
Bool -> TimeLocale -> String -> String -> t
TI.parseTimeOrError Bool
True TimeLocale
defaultTimeLocale String
timeFormat (String -> UTCTime) -> (AuthId -> String) -> AuthId -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthId -> String
B8.unpack
#else
parseUTCTime =
  fromMaybe (error "Web.ServerSession.Backend.Redis.Internal.parseUTCTime") .
  TI.parseTime defaultTimeLocale timeFormat . B8.unpack
#endif


-- | Convert a 'UTCTime' into a 'ByteString' to be stored on
-- Redis.
printUTCTime :: TI.UTCTime -> ByteString
printUTCTime :: UTCTime -> AuthId
printUTCTime = String -> AuthId
B8.pack (String -> AuthId) -> (UTCTime -> String) -> UTCTime -> AuthId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
TI.formatTime TimeLocale
defaultTimeLocale String
timeFormat


-- | Time format used when storing 'UTCTime'.
timeFormat :: String
timeFormat :: String
timeFormat = String
"%Y-%m-%dT%H:%M:%S%Q"


----------------------------------------------------------------------


-- | Run the given Redis command in batches of @511*1024@ items.
-- This is used for @HMSET@ because there's a hard Redis limit of
-- @1024*1024@ arguments to a command.  The last result is returned.
batched :: Monad m => ([a] -> m b) -> [a] -> m b
batched :: ([a] -> m b) -> [a] -> m b
batched [a] -> m b
f [a]
xs =
  let ([a]
this, [a]
rest) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
511Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1024) [a]
xs
      continue :: b -> m b
continue | [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
rest = b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return
               | Bool
otherwise = m b -> b -> m b
forall a b. a -> b -> a
const (([a] -> m b) -> [a] -> m b
forall (m :: * -> *) a b. Monad m => ([a] -> m b) -> [a] -> m b
batched [a] -> m b
f [a]
rest)
  in [a] -> m b
f [a]
this m b -> (b -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> m b
continue


-- | Get the session for the given session ID.
getSessionImpl :: RedisSession sess => SessionId sess -> R.Redis (Maybe (Session sess))
getSessionImpl :: SessionId sess -> Redis (Maybe (Session sess))
getSessionImpl SessionId sess
sid = SessionId sess -> [(AuthId, AuthId)] -> Maybe (Session sess)
forall sess.
RedisSession sess =>
SessionId sess -> [(AuthId, AuthId)] -> Maybe (Session sess)
parseSession SessionId sess
sid ([(AuthId, AuthId)] -> Maybe (Session sess))
-> Redis [(AuthId, AuthId)] -> Redis (Maybe (Session sess))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> Redis (Either Reply [(AuthId, AuthId)]) -> Redis [(AuthId, AuthId)]
forall a. Redis (Either Reply a) -> Redis a
unwrap (AuthId -> Redis (Either Reply [(AuthId, AuthId)])
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
AuthId -> m (f [(AuthId, AuthId)])
R.hgetall (AuthId -> Redis (Either Reply [(AuthId, AuthId)]))
-> AuthId -> Redis (Either Reply [(AuthId, AuthId)])
forall a b. (a -> b) -> a -> b
$ SessionId sess -> AuthId
forall sess. SessionId sess -> AuthId
rSessionKey SessionId sess
sid)


-- | Delete the session with given session ID.
deleteSessionImpl :: RedisSession sess => SessionId sess -> R.Redis ()
deleteSessionImpl :: SessionId sess -> Redis ()
deleteSessionImpl SessionId sess
sid = do
  Maybe (Session sess)
msession <- SessionId sess -> Redis (Maybe (Session sess))
forall sess.
RedisSession sess =>
SessionId sess -> Redis (Maybe (Session sess))
getSessionImpl SessionId sess
sid
  case Maybe (Session sess)
msession of
    Maybe (Session sess)
Nothing -> () -> Redis ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Session sess
session ->
      RedisTx (Queued ()) -> Redis ()
transaction (RedisTx (Queued ()) -> Redis ())
-> RedisTx (Queued ()) -> Redis ()
forall a b. (a -> b) -> a -> b
$ do
        Queued Integer
r <- [AuthId] -> RedisTx (Queued Integer)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
[AuthId] -> m (f Integer)
R.del [SessionId sess -> AuthId
forall sess. SessionId sess -> AuthId
rSessionKey SessionId sess
sid]
        SessionId sess -> Maybe AuthId -> RedisTx ()
forall (m :: * -> *) (f :: * -> *) sess.
(RedisCtx m f, Functor m) =>
SessionId sess -> Maybe AuthId -> m ()
removeSessionFromAuthId SessionId sess
sid (Session sess -> Maybe AuthId
forall sess. Session sess -> Maybe AuthId
sessionAuthId Session sess
session)
        Queued () -> RedisTx (Queued ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() () -> Queued Integer -> Queued ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Queued Integer
r)


-- | Remove the given 'SessionId' from the set of sessions of the
-- given 'AuthId'.  Does not do anything if @Nothing@.
removeSessionFromAuthId :: (R.RedisCtx m f, Functor m) => SessionId sess -> Maybe AuthId -> m ()
removeSessionFromAuthId :: SessionId sess -> Maybe AuthId -> m ()
removeSessionFromAuthId = (AuthId -> [AuthId] -> m (f Integer))
-> SessionId sess -> Maybe AuthId -> m ()
forall (m :: * -> *) (f :: * -> *) sess.
(RedisCtx m f, Functor m) =>
(AuthId -> [AuthId] -> m (f Integer))
-> SessionId sess -> Maybe AuthId -> m ()
fooSessionBarAuthId AuthId -> [AuthId] -> m (f Integer)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
AuthId -> [AuthId] -> m (f Integer)
R.srem

-- | Insert the given 'SessionId' into the set of sessions of the
-- given 'AuthId'.  Does not do anything if @Nothing@.
insertSessionForAuthId :: (R.RedisCtx m f, Functor m) => SessionId sess -> Maybe AuthId -> m ()
insertSessionForAuthId :: SessionId sess -> Maybe AuthId -> m ()
insertSessionForAuthId = (AuthId -> [AuthId] -> m (f Integer))
-> SessionId sess -> Maybe AuthId -> m ()
forall (m :: * -> *) (f :: * -> *) sess.
(RedisCtx m f, Functor m) =>
(AuthId -> [AuthId] -> m (f Integer))
-> SessionId sess -> Maybe AuthId -> m ()
fooSessionBarAuthId AuthId -> [AuthId] -> m (f Integer)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
AuthId -> [AuthId] -> m (f Integer)
R.sadd


-- | (Internal) Helper for 'removeSessionFromAuthId' and 'insertSessionForAuthId'
fooSessionBarAuthId
  :: (R.RedisCtx m f, Functor m)
  => (ByteString -> [ByteString] -> m (f Integer))
  -> SessionId sess
  -> Maybe AuthId
  -> m ()
fooSessionBarAuthId :: (AuthId -> [AuthId] -> m (f Integer))
-> SessionId sess -> Maybe AuthId -> m ()
fooSessionBarAuthId AuthId -> [AuthId] -> m (f Integer)
_   SessionId sess
_   Maybe AuthId
Nothing       = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
fooSessionBarAuthId AuthId -> [AuthId] -> m (f Integer)
fun SessionId sess
sid (Just AuthId
authId) = m (f Integer) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (f Integer) -> m ()) -> m (f Integer) -> m ()
forall a b. (a -> b) -> a -> b
$ AuthId -> [AuthId] -> m (f Integer)
fun (AuthId -> AuthId
rAuthKey AuthId
authId) [SessionId sess -> AuthId
forall sess. SessionId sess -> AuthId
rSessionKey SessionId sess
sid]


-- | Delete all sessions of the given auth ID.
deleteAllSessionsOfAuthIdImpl :: AuthId -> R.Redis ()
deleteAllSessionsOfAuthIdImpl :: AuthId -> Redis ()
deleteAllSessionsOfAuthIdImpl AuthId
authId = do
  [AuthId]
sessionRefs <- Redis (Either Reply [AuthId]) -> Redis [AuthId]
forall a. Redis (Either Reply a) -> Redis a
unwrap (Redis (Either Reply [AuthId]) -> Redis [AuthId])
-> Redis (Either Reply [AuthId]) -> Redis [AuthId]
forall a b. (a -> b) -> a -> b
$ AuthId -> Redis (Either Reply [AuthId])
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
AuthId -> m (f [AuthId])
R.smembers (AuthId -> AuthId
rAuthKey AuthId
authId)
  Redis Integer -> Redis ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Redis Integer -> Redis ()) -> Redis Integer -> Redis ()
forall a b. (a -> b) -> a -> b
$ Redis (Either Reply Integer) -> Redis Integer
forall a. Redis (Either Reply a) -> Redis a
unwrap (Redis (Either Reply Integer) -> Redis Integer)
-> Redis (Either Reply Integer) -> Redis Integer
forall a b. (a -> b) -> a -> b
$ [AuthId] -> Redis (Either Reply Integer)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
[AuthId] -> m (f Integer)
R.del ([AuthId] -> Redis (Either Reply Integer))
-> [AuthId] -> Redis (Either Reply Integer)
forall a b. (a -> b) -> a -> b
$ AuthId -> AuthId
rAuthKey AuthId
authId AuthId -> [AuthId] -> [AuthId]
forall a. a -> [a] -> [a]
: [AuthId]
sessionRefs


-- | Insert a new session.
insertSessionImpl :: RedisSession sess => RedisStorage sess -> Session sess -> R.Redis ()
insertSessionImpl :: RedisStorage sess -> Session sess -> Redis ()
insertSessionImpl RedisStorage sess
sto Session sess
session = do
  -- Check that no old session exists.
  let sid :: SessionId sess
sid = Session sess -> SessionId sess
forall sess. Session sess -> SessionId sess
sessionKey Session sess
session
  Maybe (Session sess)
moldSession <- SessionId sess -> Redis (Maybe (Session sess))
forall sess.
RedisSession sess =>
SessionId sess -> Redis (Maybe (Session sess))
getSessionImpl SessionId sess
sid
  case Maybe (Session sess)
moldSession of
    Just Session sess
oldSession -> StorageException (RedisStorage sess) -> Redis ()
forall sess a.
Storage (RedisStorage sess) =>
StorageException (RedisStorage sess) -> Redis a
throwRS (StorageException (RedisStorage sess) -> Redis ())
-> StorageException (RedisStorage sess) -> Redis ()
forall a b. (a -> b) -> a -> b
$ Session (SessionData (RedisStorage sess))
-> Session (SessionData (RedisStorage sess))
-> StorageException (RedisStorage sess)
forall sto.
Session (SessionData sto)
-> Session (SessionData sto) -> StorageException sto
SessionAlreadyExists Session sess
Session (SessionData (RedisStorage sess))
oldSession Session sess
Session (SessionData (RedisStorage sess))
session
    Maybe (Session sess)
Nothing -> do
      RedisTx (Queued ()) -> Redis ()
transaction (RedisTx (Queued ()) -> Redis ())
-> RedisTx (Queued ()) -> Redis ()
forall a b. (a -> b) -> a -> b
$ do
        let sk :: AuthId
sk = SessionId sess -> AuthId
forall sess. SessionId sess -> AuthId
rSessionKey SessionId sess
sid
        Queued Status
r <- ([(AuthId, AuthId)] -> RedisTx (Queued Status))
-> [(AuthId, AuthId)] -> RedisTx (Queued Status)
forall (m :: * -> *) a b. Monad m => ([a] -> m b) -> [a] -> m b
batched (AuthId -> [(AuthId, AuthId)] -> RedisTx (Queued Status)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
AuthId -> [(AuthId, AuthId)] -> m (f Status)
R.hmset AuthId
sk) (Session sess -> [(AuthId, AuthId)]
forall sess.
RedisSession sess =>
Session sess -> [(AuthId, AuthId)]
printSession Session sess
session)
        Session sess -> RedisStorage sess -> RedisTx ()
forall sess. Session sess -> RedisStorage sess -> RedisTx ()
expireSession Session sess
session RedisStorage sess
sto
        SessionId sess -> Maybe AuthId -> RedisTx ()
forall (m :: * -> *) (f :: * -> *) sess.
(RedisCtx m f, Functor m) =>
SessionId sess -> Maybe AuthId -> m ()
insertSessionForAuthId (Session sess -> SessionId sess
forall sess. Session sess -> SessionId sess
sessionKey Session sess
session) (Session sess -> Maybe AuthId
forall sess. Session sess -> Maybe AuthId
sessionAuthId Session sess
session)
        Queued () -> RedisTx (Queued ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() () -> Queued Status -> Queued ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Queued Status
r)


-- | Replace the contents of a session.
replaceSessionImpl :: RedisSession sess => RedisStorage sess -> Session sess -> R.Redis ()
replaceSessionImpl :: RedisStorage sess -> Session sess -> Redis ()
replaceSessionImpl RedisStorage sess
sto Session sess
session = do
  -- Check that the old session exists.
  let sid :: SessionId sess
sid = Session sess -> SessionId sess
forall sess. Session sess -> SessionId sess
sessionKey Session sess
session
  Maybe (Session sess)
moldSession <- SessionId sess -> Redis (Maybe (Session sess))
forall sess.
RedisSession sess =>
SessionId sess -> Redis (Maybe (Session sess))
getSessionImpl SessionId sess
sid
  case Maybe (Session sess)
moldSession of
    Maybe (Session sess)
Nothing -> StorageException (RedisStorage sess) -> Redis ()
forall sess a.
Storage (RedisStorage sess) =>
StorageException (RedisStorage sess) -> Redis a
throwRS (StorageException (RedisStorage sess) -> Redis ())
-> StorageException (RedisStorage sess) -> Redis ()
forall a b. (a -> b) -> a -> b
$ Session (SessionData (RedisStorage sess))
-> StorageException (RedisStorage sess)
forall sto. Session (SessionData sto) -> StorageException sto
SessionDoesNotExist Session sess
Session (SessionData (RedisStorage sess))
session
    Just Session sess
oldSession -> do
      RedisTx (Queued ()) -> Redis ()
transaction (RedisTx (Queued ()) -> Redis ())
-> RedisTx (Queued ()) -> Redis ()
forall a b. (a -> b) -> a -> b
$ do
        -- Delete the old session and set the new one.
        let sk :: AuthId
sk = SessionId sess -> AuthId
forall sess. SessionId sess -> AuthId
rSessionKey SessionId sess
sid
        Queued Integer
_ <- [AuthId] -> RedisTx (Queued Integer)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
[AuthId] -> m (f Integer)
R.del [AuthId
sk]
        Queued Status
r <- ([(AuthId, AuthId)] -> RedisTx (Queued Status))
-> [(AuthId, AuthId)] -> RedisTx (Queued Status)
forall (m :: * -> *) a b. Monad m => ([a] -> m b) -> [a] -> m b
batched (AuthId -> [(AuthId, AuthId)] -> RedisTx (Queued Status)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
AuthId -> [(AuthId, AuthId)] -> m (f Status)
R.hmset AuthId
sk) (Session sess -> [(AuthId, AuthId)]
forall sess.
RedisSession sess =>
Session sess -> [(AuthId, AuthId)]
printSession Session sess
session)
        Session sess -> RedisStorage sess -> RedisTx ()
forall sess. Session sess -> RedisStorage sess -> RedisTx ()
expireSession Session sess
session RedisStorage sess
sto

        -- Remove the old auth ID from the map if it has changed.
        let oldAuthId :: Maybe AuthId
oldAuthId = Session sess -> Maybe AuthId
forall sess. Session sess -> Maybe AuthId
sessionAuthId Session sess
oldSession
            newAuthId :: Maybe AuthId
newAuthId = Session sess -> Maybe AuthId
forall sess. Session sess -> Maybe AuthId
sessionAuthId Session sess
session
        Bool -> RedisTx () -> RedisTx ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe AuthId
oldAuthId Maybe AuthId -> Maybe AuthId -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe AuthId
newAuthId) (RedisTx () -> RedisTx ()) -> RedisTx () -> RedisTx ()
forall a b. (a -> b) -> a -> b
$ do
          SessionId sess -> Maybe AuthId -> RedisTx ()
forall (m :: * -> *) (f :: * -> *) sess.
(RedisCtx m f, Functor m) =>
SessionId sess -> Maybe AuthId -> m ()
removeSessionFromAuthId SessionId sess
sid Maybe AuthId
oldAuthId
          SessionId sess -> Maybe AuthId -> RedisTx ()
forall (m :: * -> *) (f :: * -> *) sess.
(RedisCtx m f, Functor m) =>
SessionId sess -> Maybe AuthId -> m ()
insertSessionForAuthId SessionId sess
sid Maybe AuthId
newAuthId

        Queued () -> RedisTx (Queued ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() () -> Queued Status -> Queued ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Queued Status
r)


-- | Specialization of 'E.throwIO' for 'RedisStorage'.
throwRS
  :: Storage (RedisStorage sess)
  => StorageException (RedisStorage sess)
  -> R.Redis a
throwRS :: StorageException (RedisStorage sess) -> Redis a
throwRS = IO a -> Redis a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Redis a)
-> (StorageException (RedisStorage sess) -> IO a)
-> StorageException (RedisStorage sess)
-> Redis a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorageException (RedisStorage sess) -> IO a
forall e a. Exception e => e -> IO a
E.throwIO


-- | Given a session, finds the next time the session will time out,
-- either by idle or absolute timeout and schedule the key in redis to
-- expire at that time. This is meant to be used on every write to a
-- session so that it is constantly setting the appropriate timeout.
expireSession :: Session sess -> RedisStorage sess -> R.RedisTx ()
expireSession :: Session sess -> RedisStorage sess -> RedisTx ()
expireSession Session {Maybe AuthId
UTCTime
SessionId sess
Decomposed sess
sessionAccessedAt :: UTCTime
sessionCreatedAt :: UTCTime
sessionData :: Decomposed sess
sessionAuthId :: Maybe AuthId
sessionKey :: SessionId sess
sessionAccessedAt :: forall sess. Session sess -> UTCTime
sessionCreatedAt :: forall sess. Session sess -> UTCTime
sessionData :: forall sess. Session sess -> Decomposed sess
sessionAuthId :: forall sess. Session sess -> Maybe AuthId
sessionKey :: forall sess. Session sess -> SessionId sess
..} RedisStorage {Maybe NominalDiffTime
Connection
absoluteTimeout :: Maybe NominalDiffTime
idleTimeout :: Maybe NominalDiffTime
connPool :: Connection
absoluteTimeout :: forall sess. RedisStorage sess -> Maybe NominalDiffTime
idleTimeout :: forall sess. RedisStorage sess -> Maybe NominalDiffTime
connPool :: forall sess. RedisStorage sess -> Connection
..} =
  case [UTCTime] -> Maybe UTCTime
forall a. Ord a => [a] -> Maybe a
minimum' ([Maybe UTCTime] -> [UTCTime]
forall a. [Maybe a] -> [a]
catMaybes [Maybe UTCTime
viaIdle, Maybe UTCTime
viaAbsolute]) of
    Maybe UTCTime
Nothing -> () -> RedisTx ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just UTCTime
t -> let ts :: Integer
ts = NominalDiffTime -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (UTCTime -> NominalDiffTime
TP.utcTimeToPOSIXSeconds UTCTime
t)
              in RedisTx (Queued Bool) -> RedisTx ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AuthId -> Integer -> RedisTx (Queued Bool)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
AuthId -> Integer -> m (f Bool)
R.expireat AuthId
sk Integer
ts)
  where
    sk :: AuthId
sk = SessionId sess -> AuthId
forall sess. SessionId sess -> AuthId
rSessionKey SessionId sess
sessionKey
    minimum' :: [a] -> Maybe a
minimum' [] = Maybe a
forall a. Maybe a
Nothing
    minimum' [a]
xs = a -> Maybe a
forall a. a -> Maybe a
Just ([a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [a]
xs)
    viaIdle :: Maybe UTCTime
viaIdle = (NominalDiffTime -> UTCTime -> UTCTime)
-> UTCTime -> NominalDiffTime -> UTCTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> UTCTime -> UTCTime
TI.addUTCTime UTCTime
sessionAccessedAt (NominalDiffTime -> UTCTime)
-> Maybe NominalDiffTime -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NominalDiffTime
idleTimeout
    viaAbsolute :: Maybe UTCTime
viaAbsolute = (NominalDiffTime -> UTCTime -> UTCTime)
-> UTCTime -> NominalDiffTime -> UTCTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> UTCTime -> UTCTime
TI.addUTCTime UTCTime
sessionCreatedAt  (NominalDiffTime -> UTCTime)
-> Maybe NominalDiffTime -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NominalDiffTime
absoluteTimeout