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
data RedisStorage sess =
RedisStorage
{ RedisStorage sess -> Connection
connPool :: R.Connection
, RedisStorage sess -> Maybe NominalDiffTime
idleTimeout :: Maybe TI.NominalDiffTime
, RedisStorage sess -> Maybe NominalDiffTime
absoluteTimeout :: Maybe TI.NominalDiffTime
} deriving (Typeable)
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
data RedisStorageException =
ExpectedTxSuccess (R.TxResult ())
| ExpectedRight R.Reply
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
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
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
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
rAuthKey :: AuthId -> ByteString
rAuthKey :: AuthId -> AuthId
rAuthKey = AuthId -> AuthId -> AuthId
B.append AuthId
"ssr:authid:"
class IsSessionData sess => RedisSession sess where
toHash :: Proxy sess -> Decomposed sess -> [(ByteString, ByteString)]
fromHash :: Proxy sess -> [(ByteString, ByteString)] -> Decomposed sess
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)
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
}
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
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
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
timeFormat :: String
timeFormat :: String
timeFormat = String
"%Y-%m-%dT%H:%M:%S%Q"
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
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)
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)
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
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
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]
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
insertSessionImpl :: RedisSession sess => RedisStorage sess -> Session sess -> R.Redis ()
insertSessionImpl :: RedisStorage sess -> Session sess -> Redis ()
insertSessionImpl RedisStorage sess
sto Session sess
session = do
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)
replaceSessionImpl :: RedisSession sess => RedisStorage sess -> Session sess -> R.Redis ()
replaceSessionImpl :: RedisStorage sess -> Session sess -> Redis ()
replaceSessionImpl RedisStorage sess
sto Session sess
session = do
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
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
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)
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
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