{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
module Snap.Snaplet.Auth.Backends.Redis
( initRedisAuthManager
) where
import Control.Monad.State hiding (get)
import qualified Data.ByteString as B
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.Text (Text)
import Data.Text.Encoding as E
import Data.Time
import Database.Redis
import Snap.Snaplet
import Text.Read (readMaybe)
import Web.ClientSession
import Snap.Snaplet.Auth
import Snap.Snaplet.RedisDB
import Snap.Snaplet.Session
initRedisAuthManager :: SnapletLens b SessionManager
-> RedisDB
-> SnapletInit b (AuthManager b)
initRedisAuthManager :: SnapletLens b SessionManager
-> RedisDB -> SnapletInit b (AuthManager b)
initRedisAuthManager SnapletLens b SessionManager
l RedisDB
d =
Text
-> Text
-> Maybe (IO FilePath)
-> Initializer b (AuthManager b) (AuthManager b)
-> SnapletInit b (AuthManager b)
forall b v.
Text
-> Text
-> Maybe (IO FilePath)
-> Initializer b v v
-> SnapletInit b v
makeSnaplet
Text
"RedisAuthManager"
Text
"A snaplet providing user authentication using a Redis backend"
Maybe (IO FilePath)
forall a. Maybe a
Nothing (Initializer b (AuthManager b) (AuthManager b)
-> SnapletInit b (AuthManager b))
-> Initializer b (AuthManager b) (AuthManager b)
-> SnapletInit b (AuthManager b)
forall a b. (a -> b) -> a -> b
$ do
RNG
rng <- IO RNG -> Initializer b (AuthManager b) RNG
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO RNG
mkRNG
AuthSettings
s <- Initializer b (AuthManager b) AuthSettings
forall b v. Initializer b v AuthSettings
authSettingsFromConfig
Key
key <- IO Key -> Initializer b (AuthManager b) Key
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Key -> Initializer b (AuthManager b) Key)
-> IO Key -> Initializer b (AuthManager b) Key
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Key
getKey (AuthSettings -> FilePath
asSiteKey AuthSettings
s)
let redisMgr :: RedisAuthManager
redisMgr = RedisAuthManager :: Connection -> RedisAuthManager
RedisAuthManager { conn :: Connection
conn = RedisDB -> Connection
_connection RedisDB
d }
AuthManager b -> Initializer b (AuthManager b) (AuthManager b)
forall (m :: * -> *) a. Monad m => a -> m a
return AuthManager :: forall b r.
IAuthBackend r =>
r
-> SnapletLens b SessionManager
-> Maybe AuthUser
-> Int
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> Key
-> Maybe (Int, NominalDiffTime)
-> RNG
-> AuthManager b
AuthManager {
backend :: RedisAuthManager
backend = RedisAuthManager
redisMgr
, session :: SnapletLens b SessionManager
session = SnapletLens b SessionManager
l
, activeUser :: Maybe AuthUser
activeUser = Maybe AuthUser
forall a. Maybe a
Nothing
, minPasswdLen :: Int
minPasswdLen = AuthSettings -> Int
asMinPasswdLen AuthSettings
s
, rememberCookieName :: ByteString
rememberCookieName = AuthSettings -> ByteString
asRememberCookieName AuthSettings
s
#if MIN_VERSION_snap(1,0,0)
, rememberCookieDomain :: Maybe ByteString
rememberCookieDomain = Maybe ByteString
forall a. Maybe a
Nothing
#endif
, rememberPeriod :: Maybe Int
rememberPeriod = AuthSettings -> Maybe Int
asRememberPeriod AuthSettings
s
, siteKey :: Key
siteKey = Key
key
, lockout :: Maybe (Int, NominalDiffTime)
lockout = AuthSettings -> Maybe (Int, NominalDiffTime)
asLockout AuthSettings
s
, randomNumberGenerator :: RNG
randomNumberGenerator = RNG
rng
}
userHashKey :: Text -> B.ByteString
userHashKey :: Text -> ByteString
userHashKey Text
user = ByteString -> ByteString -> ByteString
B.append ByteString
"user:" (Text -> ByteString
E.encodeUtf8 Text
user)
userIdKey :: Text -> B.ByteString
userIdKey :: Text -> ByteString
userIdKey Text
userid = Text -> ByteString
enc (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append (FilePath -> Text
T.pack FilePath
"userid:") Text
userid
userEmailKey :: Text -> B.ByteString
userEmailKey :: Text -> ByteString
userEmailKey Text
em = Text -> ByteString
enc (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"useremail:" Text
em
userTokenKey :: Text -> B.ByteString
userTokenKey :: Text -> ByteString
userTokenKey Text
usertoken = Text -> ByteString
enc (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append (FilePath -> Text
T.pack FilePath
"usertoken:") Text
usertoken
enc :: Text -> B.ByteString
enc :: Text -> ByteString
enc = Text -> ByteString
E.encodeUtf8
dec :: B.ByteString -> Text
dec :: ByteString -> Text
dec = ByteString -> Text
E.decodeUtf8
encodeInt :: Int -> B.ByteString
encodeInt :: Int -> ByteString
encodeInt = Text -> ByteString
enc (Text -> ByteString) -> (Int -> Text) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text) -> (Int -> FilePath) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath
forall a. Show a => a -> FilePath
show
decodeInt :: B.ByteString -> Int
decodeInt :: ByteString -> Int
decodeInt = FilePath -> Int
forall a. Read a => FilePath -> a
read (FilePath -> Int) -> (ByteString -> FilePath) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> FilePath)
-> (ByteString -> Text) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
dec
encMaybeUTCTime :: Maybe UTCTime -> B.ByteString
encMaybeUTCTime :: Maybe UTCTime -> ByteString
encMaybeUTCTime (Just UTCTime
u) = Text -> ByteString
enc (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> (UTCTime -> FilePath) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> FilePath
forall a. Show a => a -> FilePath
show (UTCTime -> Text) -> UTCTime -> Text
forall a b. (a -> b) -> a -> b
$ UTCTime
u
encMaybeUTCTime Maybe UTCTime
_ = ByteString
""
decMaybeUTCTime :: B.ByteString -> Maybe UTCTime
decMaybeUTCTime :: ByteString -> Maybe UTCTime
decMaybeUTCTime ByteString
s = case ByteString
s of
ByteString
"" -> Maybe UTCTime
forall a. Maybe a
Nothing
ByteString
_ -> FilePath -> Maybe UTCTime
forall a. Read a => FilePath -> Maybe a
readMaybe (FilePath -> Maybe UTCTime)
-> (ByteString -> FilePath) -> ByteString -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> FilePath)
-> (ByteString -> Text) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
dec (ByteString -> Maybe UTCTime) -> ByteString -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ ByteString
s
encRoles :: [Role] -> B.ByteString
encRoles :: [Role] -> ByteString
encRoles [] = ByteString
""
encRoles [Role]
roles = Text -> ByteString
enc (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Role -> Text) -> [Role] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Text
T.pack (FilePath -> Text) -> (Role -> FilePath) -> Role -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Role -> FilePath
forall a. Show a => a -> FilePath
show) [Role]
roles
decodeRoles :: B.ByteString -> [Role]
decodeRoles :: ByteString -> [Role]
decodeRoles ByteString
"" = []
decodeRoles ByteString
s = (Text -> Role) -> [Text] -> [Role]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Role
forall a. Read a => FilePath -> a
read (FilePath -> Role) -> (Text -> FilePath) -> Text -> Role
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack) ([Text] -> [Role]) -> [Text] -> [Role]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"," (ByteString -> Text
dec ByteString
s)
encPassword :: Maybe Password -> B.ByteString
encPassword :: Maybe Password -> ByteString
encPassword (Just (Encrypted ByteString
p)) = ByteString
p
encPassword (Just (ClearText ByteString
_)) = FilePath -> ByteString
forall a. HasCallStack => FilePath -> a
error FilePath
"encPassword should never encode ClearText password"
encPassword Maybe Password
Nothing = ByteString
""
decPassword :: B.ByteString -> Maybe Password
decPassword :: ByteString -> Maybe Password
decPassword ByteString
"" = Maybe Password
forall a. Maybe a
Nothing
decPassword ByteString
p = Password -> Maybe Password
forall a. a -> Maybe a
Just (ByteString -> Password
Encrypted ByteString
p)
nextUserID :: AuthUser -> Redis (Either Reply T.Text)
nextUserID :: AuthUser -> Redis (Either Reply Text)
nextUserID AuthUser
u = case AuthUser -> Maybe UserId
userId AuthUser
u of
Just UserId
uid -> Either Reply Text -> Redis (Either Reply Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Reply Text -> Redis (Either Reply Text))
-> Either Reply Text -> Redis (Either Reply Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either Reply Text
forall a b. b -> Either a b
Right (Text -> Either Reply Text) -> Text -> Either Reply Text
forall a b. (a -> b) -> a -> b
$ UserId -> Text
unUid UserId
uid
Maybe UserId
Nothing -> do
Either Reply Integer
i <- ByteString -> Redis (Either Reply Integer)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f Integer)
incr ByteString
"next.userId"
case Either Reply Integer
i of
Right Integer
newUserId -> Either Reply Text -> Redis (Either Reply Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Reply Text -> Redis (Either Reply Text))
-> Either Reply Text -> Redis (Either Reply Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either Reply Text
forall a b. b -> Either a b
Right (Text -> Either Reply Text) -> Text -> Either Reply Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
newUserId
Left Reply
e -> Either Reply Text -> Redis (Either Reply Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Reply Text -> Redis (Either Reply Text))
-> Either Reply Text -> Redis (Either Reply Text)
forall a b. (a -> b) -> a -> b
$ Reply -> Either Reply Text
forall a b. a -> Either a b
Left Reply
e
redisSave :: RedisAuthManager -> AuthUser -> IO (Either AuthFailure AuthUser)
redisSave :: RedisAuthManager -> AuthUser -> IO (Either AuthFailure AuthUser)
redisSave RedisAuthManager
r AuthUser
u =
Connection
-> Redis (Either AuthFailure AuthUser)
-> IO (Either AuthFailure AuthUser)
forall a. Connection -> Redis a -> IO a
runRedis (RedisAuthManager -> Connection
conn RedisAuthManager
r) (Redis (Either AuthFailure AuthUser)
-> IO (Either AuthFailure AuthUser))
-> Redis (Either AuthFailure AuthUser)
-> IO (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ do
Either Reply Text
nexti <- AuthUser -> Redis (Either Reply Text)
nextUserID AuthUser
u
case Either Reply Text
nexti of
Right Text
checkedUserId -> do
TxResult (Status, Status)
res <- RedisTx (Queued (Status, Status))
-> Redis (TxResult (Status, Status))
forall a. RedisTx (Queued a) -> Redis (TxResult a)
multiExec (RedisTx (Queued (Status, Status))
-> Redis (TxResult (Status, Status)))
-> RedisTx (Queued (Status, Status))
-> Redis (TxResult (Status, Status))
forall a b. (a -> b) -> a -> b
$ do
Queued Status
res1 <- ByteString -> [(ByteString, ByteString)] -> RedisTx (Queued Status)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> [(ByteString, ByteString)] -> m (f Status)
hmset (Text -> ByteString
userHashKey (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Text
userLogin AuthUser
u)
[(ByteString
"userId", Text -> ByteString
enc Text
checkedUserId),
(ByteString
"userLogin", Text -> ByteString
enc (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Text
userLogin AuthUser
u),
(ByteString
"userEmail", Text -> ByteString
enc (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe Text
userEmail AuthUser
u),
(ByteString
"userPassword", Maybe Password -> ByteString
encPassword (AuthUser -> Maybe Password
userPassword AuthUser
u)),
(ByteString
"userActivatedAt", Maybe UTCTime -> ByteString
encMaybeUTCTime (Maybe UTCTime -> ByteString) -> Maybe UTCTime -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe UTCTime
userActivatedAt AuthUser
u),
(ByteString
"userSuspendedAt", Maybe UTCTime -> ByteString
encMaybeUTCTime (Maybe UTCTime -> ByteString) -> Maybe UTCTime -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe UTCTime
userSuspendedAt AuthUser
u),
(ByteString
"userRememberToken", Text -> ByteString
enc (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe Text
userRememberToken AuthUser
u),
(ByteString
"userLoginCount", Int -> ByteString
encodeInt (Int -> ByteString) -> Int -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Int
userLoginCount AuthUser
u),
(ByteString
"userFailedLoginCount", Int -> ByteString
encodeInt (Int -> ByteString) -> Int -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Int
userFailedLoginCount AuthUser
u),
(ByteString
"userLockedOutUntil", Maybe UTCTime -> ByteString
encMaybeUTCTime (Maybe UTCTime -> ByteString) -> Maybe UTCTime -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe UTCTime
userLockedOutUntil AuthUser
u),
(ByteString
"userCurrentLoginAt", Maybe UTCTime -> ByteString
encMaybeUTCTime (Maybe UTCTime -> ByteString) -> Maybe UTCTime -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe UTCTime
userCurrentLoginAt AuthUser
u),
(ByteString
"userLastLoginAt", Maybe UTCTime -> ByteString
encMaybeUTCTime (Maybe UTCTime -> ByteString) -> Maybe UTCTime -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe UTCTime
userLastLoginAt AuthUser
u),
(ByteString
"userCurrentLoginIp", ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe ByteString
userCurrentLoginIp AuthUser
u),
(ByteString
"userLastLoginIp", ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe ByteString
userLastLoginIp AuthUser
u),
(ByteString
"userCreatedAt", Maybe UTCTime -> ByteString
encMaybeUTCTime (Maybe UTCTime -> ByteString) -> Maybe UTCTime -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe UTCTime
userCreatedAt AuthUser
u),
(ByteString
"userUpdatedAt", Maybe UTCTime -> ByteString
encMaybeUTCTime (Maybe UTCTime -> ByteString) -> Maybe UTCTime -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe UTCTime
userUpdatedAt AuthUser
u),
(ByteString
"userResetToken", Text -> ByteString
enc (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe Text
userResetToken AuthUser
u),
(ByteString
"userResetRequestedAt", Maybe UTCTime -> ByteString
encMaybeUTCTime (Maybe UTCTime -> ByteString) -> Maybe UTCTime -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe UTCTime
userResetRequestedAt AuthUser
u),
(ByteString
"userRoles", [Role] -> ByteString
encRoles ([Role] -> ByteString) -> [Role] -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> [Role]
userRoles AuthUser
u),
(ByteString
"userMeta", Text -> ByteString
enc (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text)
-> ([(Text, Value)] -> FilePath) -> [(Text, Value)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value)] -> FilePath
forall a. Show a => a -> FilePath
show ([(Text, Value)] -> Text) -> [(Text, Value)] -> Text
forall a b. (a -> b) -> a -> b
$ HashMap Text Value -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList (HashMap Text Value -> [(Text, Value)])
-> HashMap Text Value -> [(Text, Value)]
forall a b. (a -> b) -> a -> b
$ AuthUser -> HashMap Text Value
userMeta AuthUser
u)
]
Queued Status
res2 <- ByteString -> ByteString -> RedisTx (Queued Status)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> ByteString -> m (f Status)
set (Text -> ByteString
userIdKey Text
checkedUserId) (Text -> ByteString
enc (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Text
userLogin AuthUser
u)
(Text -> RedisTx (Queued Status)) -> Maybe Text -> RedisTx ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Text
em -> ByteString -> ByteString -> RedisTx (Queued Status)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> ByteString -> m (f Status)
set (Text -> ByteString
userEmailKey Text
em) (Text -> ByteString
enc (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Text
userLogin AuthUser
u)) (AuthUser -> Maybe Text
userEmail AuthUser
u)
(Text -> RedisTx (Queued Status)) -> Maybe Text -> RedisTx ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Text
t -> ByteString -> ByteString -> RedisTx (Queued Status)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> ByteString -> m (f Status)
set (Text -> ByteString
userTokenKey Text
t) (Text -> ByteString
enc (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Text
userLogin AuthUser
u)) (Maybe Text -> RedisTx ()) -> Maybe Text -> RedisTx ()
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe Text
userRememberToken AuthUser
u
Queued (Status, Status) -> RedisTx (Queued (Status, Status))
forall (m :: * -> *) a. Monad m => a -> m a
return (Queued (Status, Status) -> RedisTx (Queued (Status, Status)))
-> Queued (Status, Status) -> RedisTx (Queued (Status, Status))
forall a b. (a -> b) -> a -> b
$ (,) (Status -> Status -> (Status, Status))
-> Queued Status -> Queued (Status -> (Status, Status))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Queued Status
res1 Queued (Status -> (Status, Status))
-> Queued Status -> Queued (Status, Status)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Queued Status
res2
case TxResult (Status, Status)
res of
TxSuccess (Status, Status)
_ -> Either AuthFailure AuthUser -> Redis (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Redis (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Redis (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthUser -> Either AuthFailure AuthUser
forall a b. b -> Either a b
Right AuthUser
u
TxResult (Status, Status)
TxAborted -> Either AuthFailure AuthUser -> Redis (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Redis (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Redis (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left (AuthFailure -> Either AuthFailure AuthUser)
-> AuthFailure -> Either AuthFailure AuthUser
forall a b. (a -> b) -> a -> b
$ FilePath -> AuthFailure
AuthError FilePath
"redis transaction aborted"
TxError FilePath
e -> Either AuthFailure AuthUser -> Redis (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Redis (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Redis (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left (AuthFailure -> Either AuthFailure AuthUser)
-> AuthFailure -> Either AuthFailure AuthUser
forall a b. (a -> b) -> a -> b
$ FilePath -> AuthFailure
AuthError FilePath
e
Left (Error ByteString
e) -> Either AuthFailure AuthUser -> Redis (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Redis (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Redis (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left (AuthFailure -> Either AuthFailure AuthUser)
-> AuthFailure -> Either AuthFailure AuthUser
forall a b. (a -> b) -> a -> b
$ FilePath -> AuthFailure
AuthError (ByteString -> FilePath
forall a. Show a => a -> FilePath
show ByteString
e)
Left Reply
_ -> Either AuthFailure AuthUser -> Redis (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Redis (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Redis (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left (AuthFailure -> Either AuthFailure AuthUser)
-> AuthFailure -> Either AuthFailure AuthUser
forall a b. (a -> b) -> a -> b
$ FilePath -> AuthFailure
AuthError FilePath
"redisSave unknown error"
redisDestroy :: RedisAuthManager -> AuthUser -> IO ()
redisDestroy :: RedisAuthManager -> AuthUser -> IO ()
redisDestroy RedisAuthManager
r AuthUser
u =
case AuthUser -> Maybe UserId
userId AuthUser
u of
Maybe UserId
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just UserId
uid ->
Connection -> Redis () -> IO ()
forall a. Connection -> Redis a -> IO a
runRedis (RedisAuthManager -> Connection
conn RedisAuthManager
r) (Redis () -> IO ()) -> Redis () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Either Reply Integer
_ <- [ByteString] -> Redis (Either Reply Integer)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
[ByteString] -> m (f Integer)
del [Text -> ByteString
userHashKey (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthUser -> Text
userLogin AuthUser
u,
Text -> ByteString
userIdKey (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ UserId -> Text
unUid UserId
uid]
() -> Redis ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
redisLookupByUserId :: RedisAuthManager -> UserId -> IO (Maybe AuthUser)
redisLookupByUserId :: RedisAuthManager -> UserId -> IO (Maybe AuthUser)
redisLookupByUserId RedisAuthManager
r UserId
uid =
Connection -> Redis (Maybe AuthUser) -> IO (Maybe AuthUser)
forall a. Connection -> Redis a -> IO a
runRedis (RedisAuthManager -> Connection
conn RedisAuthManager
r) (Redis (Maybe AuthUser) -> IO (Maybe AuthUser))
-> Redis (Maybe AuthUser) -> IO (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ do
Either Reply (Maybe ByteString)
ul <- ByteString -> Redis (Either Reply (Maybe ByteString))
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f (Maybe ByteString))
get (Text -> ByteString
userIdKey (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ UserId -> Text
unUid UserId
uid)
case Either Reply (Maybe ByteString)
ul of
Right (Just ByteString
userlogin) -> IO (Maybe AuthUser) -> Redis (Maybe AuthUser)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe AuthUser) -> Redis (Maybe AuthUser))
-> IO (Maybe AuthUser) -> Redis (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ RedisAuthManager -> Text -> IO (Maybe AuthUser)
redisLookupByLogin RedisAuthManager
r (ByteString -> Text
dec ByteString
userlogin)
Either Reply (Maybe ByteString)
_ -> Maybe AuthUser -> Redis (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
forall a. Maybe a
Nothing
redisLookupByLogin :: RedisAuthManager -> Text -> IO (Maybe AuthUser)
redisLookupByLogin :: RedisAuthManager -> Text -> IO (Maybe AuthUser)
redisLookupByLogin RedisAuthManager
r Text
ul =
Connection -> Redis (Maybe AuthUser) -> IO (Maybe AuthUser)
forall a. Connection -> Redis a -> IO a
runRedis (RedisAuthManager -> Connection
conn RedisAuthManager
r) (Redis (Maybe AuthUser) -> IO (Maybe AuthUser))
-> Redis (Maybe AuthUser) -> IO (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ do
Either Reply [(ByteString, ByteString)]
uhash <- ByteString -> Redis (Either Reply [(ByteString, ByteString)])
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f [(ByteString, ByteString)])
hgetall (Text -> ByteString
userHashKey Text
ul)
case Either Reply [(ByteString, ByteString)]
uhash of
Right [] -> Maybe AuthUser -> Redis (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
forall a. Maybe a
Nothing
Left Reply
_ -> Maybe AuthUser -> Redis (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
forall a. Maybe a
Nothing
Right [(ByteString, ByteString)]
h -> Maybe AuthUser -> Redis (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe AuthUser -> Redis (Maybe AuthUser))
-> Maybe AuthUser -> Redis (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe AuthUser
forall a. a -> Maybe a
Just (AuthUser -> Maybe AuthUser) -> AuthUser -> Maybe AuthUser
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> AuthUser
authUserFromHash [(ByteString, ByteString)]
h
#if MIN_VERSION_snap(1,1,0)
redisLookupByEmail :: RedisAuthManager -> Text -> IO (Maybe AuthUser)
redisLookupByEmail :: RedisAuthManager -> Text -> IO (Maybe AuthUser)
redisLookupByEmail RedisAuthManager
r Text
em =
Connection -> Redis (Maybe AuthUser) -> IO (Maybe AuthUser)
forall a. Connection -> Redis a -> IO a
runRedis (RedisAuthManager -> Connection
conn RedisAuthManager
r) (Redis (Maybe AuthUser) -> IO (Maybe AuthUser))
-> Redis (Maybe AuthUser) -> IO (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ do
Either Reply (Maybe ByteString)
ulogin <- ByteString -> Redis (Either Reply (Maybe ByteString))
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f (Maybe ByteString))
get (Text -> ByteString
userEmailKey Text
em)
case Either Reply (Maybe ByteString)
ulogin of
Right (Just ByteString
u) -> do
Either Reply [(ByteString, ByteString)]
uhash <- ByteString -> Redis (Either Reply [(ByteString, ByteString)])
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f [(ByteString, ByteString)])
hgetall (Text -> ByteString
userHashKey (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
dec ByteString
u)
case Either Reply [(ByteString, ByteString)]
uhash of
Right [] -> Maybe AuthUser -> Redis (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
forall a. Maybe a
Nothing
Left Reply
_ -> Maybe AuthUser -> Redis (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
forall a. Maybe a
Nothing
Right [(ByteString, ByteString)]
h -> Maybe AuthUser -> Redis (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe AuthUser -> Redis (Maybe AuthUser))
-> Maybe AuthUser -> Redis (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthUser -> Maybe AuthUser
forall a. a -> Maybe a
Just (AuthUser -> Maybe AuthUser) -> AuthUser -> Maybe AuthUser
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> AuthUser
authUserFromHash [(ByteString, ByteString)]
h
Either Reply (Maybe ByteString)
_ -> Maybe AuthUser -> Redis (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
forall a. Maybe a
Nothing
#endif
hmlookup :: B.ByteString -> HashMap B.ByteString B.ByteString -> B.ByteString
hmlookup :: ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
k HashMap ByteString ByteString
hm = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> HashMap ByteString ByteString -> Maybe ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup ByteString
k HashMap ByteString ByteString
hm
authUserFromHash :: [(B.ByteString, B.ByteString)] -> AuthUser
authUserFromHash :: [(ByteString, ByteString)] -> AuthUser
authUserFromHash [] = FilePath -> AuthUser
forall a. HasCallStack => FilePath -> a
error FilePath
"authUserFromHash error: Empty hashmap"
authUserFromHash [(ByteString, ByteString)]
l =
let hm :: HashMap ByteString ByteString
hm = [(ByteString, ByteString)] -> HashMap ByteString ByteString
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(ByteString, ByteString)]
l
in AuthUser :: Maybe UserId
-> Text
-> Maybe Text
-> Maybe Password
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Int
-> Int
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe ByteString
-> Maybe ByteString
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser
AuthUser { userId :: Maybe UserId
userId = UserId -> Maybe UserId
forall a. a -> Maybe a
Just (UserId -> Maybe UserId) -> UserId -> Maybe UserId
forall a b. (a -> b) -> a -> b
$ Text -> UserId
UserId (ByteString -> Text
dec (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userId" HashMap ByteString ByteString
hm)
, userLogin :: Text
userLogin = ByteString -> Text
dec (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userLogin" HashMap ByteString ByteString
hm
, userEmail :: Maybe Text
userEmail = case ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userEmail " HashMap ByteString ByteString
hm of
ByteString
"" -> Maybe Text
forall a. Maybe a
Nothing
ByteString
email -> Text -> Maybe Text
forall a. a -> Maybe a
Just (FilePath -> Text
T.pack (FilePath -> Text)
-> (ByteString -> FilePath) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
forall a. Show a => a -> FilePath
show (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString
email)
, userPassword :: Maybe Password
userPassword = ByteString -> Maybe Password
decPassword (ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userPassword" HashMap ByteString ByteString
hm)
, userActivatedAt :: Maybe UTCTime
userActivatedAt = ByteString -> Maybe UTCTime
decMaybeUTCTime (ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userActivatedAt" HashMap ByteString ByteString
hm)
, userSuspendedAt :: Maybe UTCTime
userSuspendedAt = ByteString -> Maybe UTCTime
decMaybeUTCTime (ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userSuspendedAt" HashMap ByteString ByteString
hm)
, userRememberToken :: Maybe Text
userRememberToken = case ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userRememberToken" HashMap ByteString ByteString
hm of
ByteString
"" -> Maybe Text
forall a. Maybe a
Nothing
ByteString
token -> Text -> Maybe Text
forall a. a -> Maybe a
Just (ByteString -> Text
dec ByteString
token)
, userLoginCount :: Int
userLoginCount = ByteString -> Int
decodeInt (ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userLoginCount" HashMap ByteString ByteString
hm)
, userFailedLoginCount :: Int
userFailedLoginCount = ByteString -> Int
decodeInt (ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userFailedLoginCount" HashMap ByteString ByteString
hm)
, userLockedOutUntil :: Maybe UTCTime
userLockedOutUntil = ByteString -> Maybe UTCTime
decMaybeUTCTime (ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userLockedOutUntil" HashMap ByteString ByteString
hm)
, userCurrentLoginAt :: Maybe UTCTime
userCurrentLoginAt = ByteString -> Maybe UTCTime
decMaybeUTCTime (ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userCurrentLoginAt" HashMap ByteString ByteString
hm)
, userLastLoginAt :: Maybe UTCTime
userLastLoginAt = ByteString -> Maybe UTCTime
decMaybeUTCTime (ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userLastLoginAt" HashMap ByteString ByteString
hm)
, userCurrentLoginIp :: Maybe ByteString
userCurrentLoginIp = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userCurrentLoginIp" HashMap ByteString ByteString
hm)
, userLastLoginIp :: Maybe ByteString
userLastLoginIp = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userLastLoginIp" HashMap ByteString ByteString
hm)
, userCreatedAt :: Maybe UTCTime
userCreatedAt = ByteString -> Maybe UTCTime
decMaybeUTCTime (ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userCreatedAt" HashMap ByteString ByteString
hm)
, userUpdatedAt :: Maybe UTCTime
userUpdatedAt = ByteString -> Maybe UTCTime
decMaybeUTCTime (ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userUpdatedAt" HashMap ByteString ByteString
hm)
, userResetToken :: Maybe Text
userResetToken = Text -> Maybe Text
forall a. a -> Maybe a
Just (ByteString -> Text
dec (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userResetToken" HashMap ByteString ByteString
hm)
, userResetRequestedAt :: Maybe UTCTime
userResetRequestedAt = ByteString -> Maybe UTCTime
decMaybeUTCTime (ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userResetRequestedAt" HashMap ByteString ByteString
hm)
, userRoles :: [Role]
userRoles = ByteString -> [Role]
decodeRoles (ByteString -> HashMap ByteString ByteString -> ByteString
hmlookup ByteString
"userRoles" HashMap ByteString ByteString
hm)
, userMeta :: HashMap Text Value
userMeta = HashMap Text Value
forall k v. HashMap k v
HM.empty
}
redisLookupByRememberToken :: RedisAuthManager -> Text -> IO (Maybe AuthUser)
redisLookupByRememberToken :: RedisAuthManager -> Text -> IO (Maybe AuthUser)
redisLookupByRememberToken RedisAuthManager
r Text
utkn =
Connection -> Redis (Maybe AuthUser) -> IO (Maybe AuthUser)
forall a. Connection -> Redis a -> IO a
runRedis (RedisAuthManager -> Connection
conn RedisAuthManager
r) (Redis (Maybe AuthUser) -> IO (Maybe AuthUser))
-> Redis (Maybe AuthUser) -> IO (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ do
Either Reply (Maybe ByteString)
ul <- ByteString -> Redis (Either Reply (Maybe ByteString))
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f (Maybe ByteString))
get (Text -> ByteString
userTokenKey Text
utkn)
case Either Reply (Maybe ByteString)
ul of
Right (Just ByteString
userlogin) -> IO (Maybe AuthUser) -> Redis (Maybe AuthUser)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe AuthUser) -> Redis (Maybe AuthUser))
-> IO (Maybe AuthUser) -> Redis (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ RedisAuthManager -> Text -> IO (Maybe AuthUser)
redisLookupByLogin RedisAuthManager
r (ByteString -> Text
dec ByteString
userlogin)
Either Reply (Maybe ByteString)
_ -> Maybe AuthUser -> Redis (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
forall a. Maybe a
Nothing
newtype RedisAuthManager = RedisAuthManager {
RedisAuthManager -> Connection
conn :: Connection
}
instance IAuthBackend RedisAuthManager where
save :: RedisAuthManager -> AuthUser -> IO (Either AuthFailure AuthUser)
save = RedisAuthManager -> AuthUser -> IO (Either AuthFailure AuthUser)
redisSave
destroy :: RedisAuthManager -> AuthUser -> IO ()
destroy = RedisAuthManager -> AuthUser -> IO ()
redisDestroy
lookupByUserId :: RedisAuthManager -> UserId -> IO (Maybe AuthUser)
lookupByUserId = RedisAuthManager -> UserId -> IO (Maybe AuthUser)
redisLookupByUserId
lookupByLogin :: RedisAuthManager -> Text -> IO (Maybe AuthUser)
lookupByLogin = RedisAuthManager -> Text -> IO (Maybe AuthUser)
redisLookupByLogin
#if MIN_VERSION_snap(1,1,0)
lookupByEmail :: RedisAuthManager -> Text -> IO (Maybe AuthUser)
lookupByEmail = RedisAuthManager -> Text -> IO (Maybe AuthUser)
redisLookupByEmail
#endif
lookupByRememberToken :: RedisAuthManager -> Text -> IO (Maybe AuthUser)
lookupByRememberToken = RedisAuthManager -> Text -> IO (Maybe AuthUser)
redisLookupByRememberToken