{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
module Snap.Snaplet.Auth.Handlers where
import Control.Applicative
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Data.ByteString (ByteString)
import Data.Maybe
import Data.Serialize hiding (get)
import Data.Time
import Data.Text.Encoding (decodeUtf8)
import Data.Text (Text, null, strip)
import Prelude hiding (null)
import Web.ClientSession
import Snap.Core
import Snap.Snaplet
import Snap.Snaplet.Auth.AuthManager
import Snap.Snaplet.Auth.Types
import Snap.Snaplet.Session
createUser :: Text
-> ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
createUser :: Text
-> ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
createUser unm :: Text
unm pwd :: ByteString
pwd
| Text -> Bool
null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Text
strip Text
unm = Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
UsernameMissing
| Bool
otherwise = do
Bool
uExists <- Text -> Handler b (AuthManager b) Bool
forall b. Text -> Handler b (AuthManager b) Bool
usernameExists Text
unm
if Bool
uExists then Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
DuplicateLogin
else (forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend ((forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ \r :: r
r -> IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ r -> Text -> ByteString -> IO (Either AuthFailure AuthUser)
forall r.
IAuthBackend r =>
r -> Text -> ByteString -> IO (Either AuthFailure AuthUser)
buildAuthUser r
r Text
unm ByteString
pwd
usernameExists :: Text
-> Handler b (AuthManager b) Bool
usernameExists :: Text -> Handler b (AuthManager b) Bool
usernameExists username :: Text
username =
(forall r. IAuthBackend r => r -> Handler b (AuthManager b) Bool)
-> Handler b (AuthManager b) Bool
forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend ((forall r. IAuthBackend r => r -> Handler b (AuthManager b) Bool)
-> Handler b (AuthManager b) Bool)
-> (forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) Bool)
-> Handler b (AuthManager b) Bool
forall a b. (a -> b) -> a -> b
$ \r :: r
r -> IO Bool -> Handler b (AuthManager b) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Handler b (AuthManager b) Bool)
-> IO Bool -> Handler b (AuthManager b) Bool
forall a b. (a -> b) -> a -> b
$ Maybe AuthUser -> Bool
forall a. Maybe a -> Bool
isJust (Maybe AuthUser -> Bool) -> IO (Maybe AuthUser) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r -> Text -> IO (Maybe AuthUser)
forall r. IAuthBackend r => r -> Text -> IO (Maybe AuthUser)
lookupByLogin r
r Text
username
loginByUsername :: Text
-> Password
-> Bool
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername :: Text
-> Password
-> Bool
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername _ (Encrypted _) _ = Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
EncryptedPassword
loginByUsername unm :: Text
unm pwd :: Password
pwd shouldRemember :: Bool
shouldRemember = do
Key
sk <- (AuthManager b -> Key) -> Handler b (AuthManager b) Key
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Key
forall b. AuthManager b -> Key
siteKey
ByteString
cn <- (AuthManager b -> ByteString)
-> Handler b (AuthManager b) ByteString
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> ByteString
forall b. AuthManager b -> ByteString
rememberCookieName
Maybe ByteString
cd <- (AuthManager b -> Maybe ByteString)
-> Handler b (AuthManager b) (Maybe ByteString)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Maybe ByteString
forall b. AuthManager b -> Maybe ByteString
rememberCookieDomain
Maybe Int
rp <- (AuthManager b -> Maybe Int)
-> Handler b (AuthManager b) (Maybe Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Maybe Int
forall b. AuthManager b -> Maybe Int
rememberPeriod
(forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend ((forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ Key
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> r
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall t b.
IAuthBackend t =>
Key
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> t
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername' Key
sk ByteString
cn Maybe ByteString
cd Maybe Int
rp
where
loginByUsername' :: (IAuthBackend t) =>
Key
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> t
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername' :: Key
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> t
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername' sk :: Key
sk cn :: ByteString
cn cd :: Maybe ByteString
cd rp :: Maybe Int
rp r :: t
r =
IO (Maybe AuthUser) -> Handler b (AuthManager b) (Maybe AuthUser)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (t -> Text -> IO (Maybe AuthUser)
forall r. IAuthBackend r => r -> Text -> IO (Maybe AuthUser)
lookupByLogin t
r Text
unm) Handler b (AuthManager b) (Maybe AuthUser)
-> (Maybe AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Handler b (AuthManager b) (Either AuthFailure AuthUser)
-> (AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Maybe AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$! AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
UserNotFound) AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
found
where
found :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
found user :: AuthUser
user = AuthUser
-> Password
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b.
AuthUser
-> Password
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
checkPasswordAndLogin AuthUser
user Password
pwd Handler b (AuthManager b) (Either AuthFailure AuthUser)
-> (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(AuthFailure
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (AuthFailure -> Either AuthFailure AuthUser)
-> AuthFailure
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left) AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
matched
matched :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
matched user :: AuthUser
user
| Bool
shouldRemember = do
ByteString
token <- (AuthManager b -> RNG) -> Handler b (AuthManager b) RNG
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> RNG
forall b. AuthManager b -> RNG
randomNumberGenerator Handler b (AuthManager b) RNG
-> (RNG -> Handler b (AuthManager b) ByteString)
-> Handler b (AuthManager b) ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
IO ByteString -> Handler b (AuthManager b) ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Handler b (AuthManager b) ByteString)
-> (RNG -> IO ByteString)
-> RNG
-> Handler b (AuthManager b) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> RNG -> IO ByteString
randomToken 64
Key
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> ByteString
-> Handler b (AuthManager b) ()
forall t (m :: * -> *).
(Serialize t, MonadSnap m) =>
Key -> ByteString -> Maybe ByteString -> Maybe Int -> t -> m ()
setRememberToken Key
sk ByteString
cn Maybe ByteString
cd Maybe Int
rp ByteString
token
let user' :: AuthUser
user' = AuthUser
user {
userRememberToken :: Maybe Text
userRememberToken = Text -> Maybe Text
forall a. a -> Maybe a
Just (ByteString -> Text
decodeUtf8 ByteString
token)
}
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
saveUser AuthUser
user'
Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$! AuthUser -> Either AuthFailure AuthUser
forall a b. b -> Either a b
Right AuthUser
user'
| Bool
otherwise = Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthUser -> Either AuthFailure AuthUser
forall a b. b -> Either a b
Right AuthUser
user
loginByRememberToken :: Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByRememberToken :: Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByRememberToken = (forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend ((forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ \impl :: r
impl -> do
Key
key <- (AuthManager b -> Key) -> Handler b (AuthManager b) Key
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Key
forall b. AuthManager b -> Key
siteKey
ByteString
cookieName_ <- (AuthManager b -> ByteString)
-> Handler b (AuthManager b) ByteString
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> ByteString
forall b. AuthManager b -> ByteString
rememberCookieName
Maybe Int
period <- (AuthManager b -> Maybe Int)
-> Handler b (AuthManager b) (Maybe Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Maybe Int
forall b. AuthManager b -> Maybe Int
rememberPeriod
Maybe AuthUser
res <- MaybeT (Handler b (AuthManager b)) AuthUser
-> Handler b (AuthManager b) (Maybe AuthUser)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (Handler b (AuthManager b)) AuthUser
-> Handler b (AuthManager b) (Maybe AuthUser))
-> MaybeT (Handler b (AuthManager b)) AuthUser
-> Handler b (AuthManager b) (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ do
ByteString
token <- Handler b (AuthManager b) (Maybe ByteString)
-> MaybeT (Handler b (AuthManager b)) ByteString
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Handler b (AuthManager b) (Maybe ByteString)
-> MaybeT (Handler b (AuthManager b)) ByteString)
-> Handler b (AuthManager b) (Maybe ByteString)
-> MaybeT (Handler b (AuthManager b)) ByteString
forall a b. (a -> b) -> a -> b
$ Key
-> ByteString
-> Maybe Int
-> Handler b (AuthManager b) (Maybe ByteString)
forall t (m :: * -> *).
(Serialize t, MonadSnap m) =>
Key -> ByteString -> Maybe Int -> m (Maybe t)
getRememberToken Key
key ByteString
cookieName_ Maybe Int
period
Handler b (AuthManager b) (Maybe AuthUser)
-> MaybeT (Handler b (AuthManager b)) AuthUser
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Handler b (AuthManager b) (Maybe AuthUser)
-> MaybeT (Handler b (AuthManager b)) AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
-> MaybeT (Handler b (AuthManager b)) AuthUser
forall a b. (a -> b) -> a -> b
$ IO (Maybe AuthUser) -> Handler b (AuthManager b) (Maybe AuthUser)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe AuthUser) -> Handler b (AuthManager b) (Maybe AuthUser))
-> IO (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ r -> Text -> IO (Maybe AuthUser)
forall r. IAuthBackend r => r -> Text -> IO (Maybe AuthUser)
lookupByRememberToken r
impl (Text -> IO (Maybe AuthUser)) -> Text -> IO (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
token
case Maybe AuthUser
res of
Nothing -> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (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
$ String -> AuthFailure
AuthError
"loginByRememberToken: no remember token"
Just user :: AuthUser
user -> do
AuthUser -> Handler b (AuthManager b) (Either AuthFailure ())
forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure ())
forceLogin AuthUser
user
Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthUser -> Either AuthFailure AuthUser
forall a b. b -> Either a b
Right AuthUser
user
logout :: Handler b (AuthManager b) ()
logout :: Handler b (AuthManager b) ()
logout = do
SnapletLens b SessionManager
s <- (AuthManager b -> SnapletLens b SessionManager)
-> Handler b (AuthManager b) (SnapletLens b SessionManager)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> SnapletLens b SessionManager
forall b. AuthManager b -> SnapletLens b SessionManager
session
SnapletLens b SessionManager
-> Handler b SessionManager () -> Handler b (AuthManager b) ()
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens b v' -> m b v' a -> m b v a
withTop SnapletLens b SessionManager
s (Handler b SessionManager () -> Handler b (AuthManager b) ())
-> Handler b SessionManager () -> Handler b (AuthManager b) ()
forall a b. (a -> b) -> a -> b
$ SnapletLens b SessionManager
-> Handler b SessionManager () -> Handler b SessionManager ()
forall b v a.
SnapletLens b SessionManager -> Handler b v a -> Handler b v a
withSession SnapletLens b SessionManager
s Handler b SessionManager ()
forall b. Handler b SessionManager ()
removeSessionUserId
ByteString
rc <- (AuthManager b -> ByteString)
-> Handler b (AuthManager b) ByteString
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> ByteString
forall b. AuthManager b -> ByteString
rememberCookieName
Maybe ByteString
rd <- (AuthManager b -> Maybe ByteString)
-> Handler b (AuthManager b) (Maybe ByteString)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Maybe ByteString
forall b. AuthManager b -> Maybe ByteString
rememberCookieDomain
ByteString -> Maybe ByteString -> Handler b (AuthManager b) ()
forall (m :: * -> *).
MonadSnap m =>
ByteString -> Maybe ByteString -> m ()
expireSecureCookie ByteString
rc Maybe ByteString
rd
(AuthManager b -> AuthManager b) -> Handler b (AuthManager b) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((AuthManager b -> AuthManager b) -> Handler b (AuthManager b) ())
-> (AuthManager b -> AuthManager b) -> Handler b (AuthManager b) ()
forall a b. (a -> b) -> a -> b
$ \mgr :: AuthManager b
mgr -> AuthManager b
mgr { activeUser :: Maybe AuthUser
activeUser = Maybe AuthUser
forall a. Maybe a
Nothing }
currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
currentUser = Handler b (AuthManager b) (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
forall b.
Handler b (AuthManager b) (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
cacheOrLookup (Handler b (AuthManager b) (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser))
-> Handler b (AuthManager b) (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ (forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Maybe AuthUser))
-> Handler b (AuthManager b) (Maybe AuthUser)
forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend ((forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Maybe AuthUser))
-> Handler b (AuthManager b) (Maybe AuthUser))
-> (forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Maybe AuthUser))
-> Handler b (AuthManager b) (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ \r :: r
r -> do
SnapletLens b SessionManager
s <- (AuthManager b -> SnapletLens b SessionManager)
-> Handler b (AuthManager b) (SnapletLens b SessionManager)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> SnapletLens b SessionManager
forall b. AuthManager b -> SnapletLens b SessionManager
session
Maybe UserId
uid <- SnapletLens b SessionManager
-> Handler b SessionManager (Maybe UserId)
-> Handler b (AuthManager b) (Maybe UserId)
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens b v' -> m b v' a -> m b v a
withTop SnapletLens b SessionManager
s Handler b SessionManager (Maybe UserId)
forall b. Handler b SessionManager (Maybe UserId)
getSessionUserId
case Maybe UserId
uid of
Nothing -> (AuthFailure -> Maybe AuthUser)
-> (AuthUser -> Maybe AuthUser)
-> Either AuthFailure AuthUser
-> Maybe AuthUser
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe AuthUser -> AuthFailure -> Maybe AuthUser
forall a b. a -> b -> a
const Maybe AuthUser
forall a. Maybe a
Nothing) AuthUser -> Maybe AuthUser
forall a. a -> Maybe a
Just (Either AuthFailure AuthUser -> Maybe AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b. Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByRememberToken
Just uid' :: UserId
uid' -> IO (Maybe AuthUser) -> Handler b (AuthManager b) (Maybe AuthUser)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe AuthUser) -> Handler b (AuthManager b) (Maybe AuthUser))
-> IO (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ r -> UserId -> IO (Maybe AuthUser)
forall r. IAuthBackend r => r -> UserId -> IO (Maybe AuthUser)
lookupByUserId r
r UserId
uid'
isLoggedIn :: Handler b (AuthManager b) Bool
isLoggedIn :: Handler b (AuthManager b) Bool
isLoggedIn = Maybe AuthUser -> Bool
forall a. Maybe a -> Bool
isJust (Maybe AuthUser -> Bool)
-> Handler b (AuthManager b) (Maybe AuthUser)
-> Handler b (AuthManager b) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handler b (AuthManager b) (Maybe AuthUser)
forall b. Handler b (AuthManager b) (Maybe AuthUser)
currentUser
saveUser :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
saveUser :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
saveUser u :: AuthUser
u
| Text -> Bool
null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ AuthUser -> Text
userLogin AuthUser
u = Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
UsernameMissing
| Bool
otherwise = (forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend ((forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ \r :: r
r -> IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ r -> AuthUser -> IO (Either AuthFailure AuthUser)
forall r.
IAuthBackend r =>
r -> AuthUser -> IO (Either AuthFailure AuthUser)
save r
r AuthUser
u
destroyUser :: AuthUser -> Handler b (AuthManager b) ()
destroyUser :: AuthUser -> Handler b (AuthManager b) ()
destroyUser u :: AuthUser
u = (forall r. IAuthBackend r => r -> Handler b (AuthManager b) ())
-> Handler b (AuthManager b) ()
forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend ((forall r. IAuthBackend r => r -> Handler b (AuthManager b) ())
-> Handler b (AuthManager b) ())
-> (forall r. IAuthBackend r => r -> Handler b (AuthManager b) ())
-> Handler b (AuthManager b) ()
forall a b. (a -> b) -> a -> b
$ IO () -> Handler b (AuthManager b) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler b (AuthManager b) ())
-> (r -> IO ()) -> r -> Handler b (AuthManager b) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> AuthUser -> IO ()) -> AuthUser -> r -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip r -> AuthUser -> IO ()
forall r. IAuthBackend r => r -> AuthUser -> IO ()
destroy AuthUser
u
markAuthFail :: AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthFail :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthFail u :: AuthUser
u = (forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend ((forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ \r :: r
r -> do
Maybe (Int, NominalDiffTime)
lo <- (AuthManager b -> Maybe (Int, NominalDiffTime))
-> Handler b (AuthManager b) (Maybe (Int, NominalDiffTime))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Maybe (Int, NominalDiffTime)
forall b. AuthManager b -> Maybe (Int, NominalDiffTime)
lockout
AuthUser -> Handler b (AuthManager b) AuthUser
forall (m :: * -> *). Monad m => AuthUser -> m AuthUser
incFailCtr AuthUser
u Handler b (AuthManager b) AuthUser
-> (AuthUser -> Handler b (AuthManager b) AuthUser)
-> Handler b (AuthManager b) AuthUser
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Int, NominalDiffTime)
-> AuthUser -> Handler b (AuthManager b) AuthUser
forall (m :: * -> *).
MonadIO m =>
Maybe (Int, NominalDiffTime) -> AuthUser -> m AuthUser
checkLockout Maybe (Int, NominalDiffTime)
lo Handler b (AuthManager b) AuthUser
-> (AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (AuthUser -> IO (Either AuthFailure AuthUser))
-> AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> AuthUser -> IO (Either AuthFailure AuthUser)
forall r.
IAuthBackend r =>
r -> AuthUser -> IO (Either AuthFailure AuthUser)
save r
r
where
incFailCtr :: AuthUser -> m AuthUser
incFailCtr u' :: AuthUser
u' = AuthUser -> m AuthUser
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthUser -> m AuthUser) -> AuthUser -> m AuthUser
forall a b. (a -> b) -> a -> b
$ AuthUser
u' {
userFailedLoginCount :: Int
userFailedLoginCount = AuthUser -> Int
userFailedLoginCount AuthUser
u' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
}
checkLockout :: Maybe (Int, NominalDiffTime) -> AuthUser -> m AuthUser
checkLockout lo :: Maybe (Int, NominalDiffTime)
lo u' :: AuthUser
u' =
case Maybe (Int, NominalDiffTime)
lo of
Nothing -> AuthUser -> m AuthUser
forall (m :: * -> *) a. Monad m => a -> m a
return AuthUser
u'
Just (mx :: Int
mx, wait :: NominalDiffTime
wait) ->
if AuthUser -> Int
userFailedLoginCount AuthUser
u' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
mx
then do
UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
let reopen :: UTCTime
reopen = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
wait UTCTime
now
AuthUser -> m AuthUser
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthUser -> m AuthUser) -> AuthUser -> m AuthUser
forall a b. (a -> b) -> a -> b
$! AuthUser
u' { userLockedOutUntil :: Maybe UTCTime
userLockedOutUntil = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
reopen }
else AuthUser -> m AuthUser
forall (m :: * -> *) a. Monad m => a -> m a
return AuthUser
u'
markAuthSuccess :: AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthSuccess :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthSuccess u :: AuthUser
u = (forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend ((forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (forall r.
IAuthBackend r =>
r -> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ \r :: r
r ->
AuthUser -> Handler b (AuthManager b) AuthUser
forall (m :: * -> *). Monad m => AuthUser -> m AuthUser
incLoginCtr AuthUser
u Handler b (AuthManager b) AuthUser
-> (AuthUser -> Handler b (AuthManager b) AuthUser)
-> Handler b (AuthManager b) AuthUser
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
AuthUser -> Handler b (AuthManager b) AuthUser
forall (m :: * -> *). MonadSnap m => AuthUser -> m AuthUser
updateIp Handler b (AuthManager b) AuthUser
-> (AuthUser -> Handler b (AuthManager b) AuthUser)
-> Handler b (AuthManager b) AuthUser
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
AuthUser -> Handler b (AuthManager b) AuthUser
forall (m :: * -> *). MonadIO m => AuthUser -> m AuthUser
updateLoginTS Handler b (AuthManager b) AuthUser
-> (AuthUser -> Handler b (AuthManager b) AuthUser)
-> Handler b (AuthManager b) AuthUser
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
AuthUser -> Handler b (AuthManager b) AuthUser
forall (m :: * -> *). Monad m => AuthUser -> m AuthUser
resetFailCtr Handler b (AuthManager b) AuthUser
-> (AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (AuthUser -> IO (Either AuthFailure AuthUser))
-> AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> AuthUser -> IO (Either AuthFailure AuthUser)
forall r.
IAuthBackend r =>
r -> AuthUser -> IO (Either AuthFailure AuthUser)
save r
r
where
incLoginCtr :: AuthUser -> m AuthUser
incLoginCtr u' :: AuthUser
u' = AuthUser -> m AuthUser
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthUser -> m AuthUser) -> AuthUser -> m AuthUser
forall a b. (a -> b) -> a -> b
$ AuthUser
u' { userLoginCount :: Int
userLoginCount = AuthUser -> Int
userLoginCount AuthUser
u' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 }
updateIp :: AuthUser -> m AuthUser
updateIp u' :: AuthUser
u' = do
ByteString
ip <- Request -> ByteString
rqClientAddr (Request -> ByteString) -> m Request -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
AuthUser -> m AuthUser
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthUser -> m AuthUser) -> AuthUser -> m AuthUser
forall a b. (a -> b) -> a -> b
$ AuthUser
u' { userLastLoginIp :: Maybe ByteString
userLastLoginIp = AuthUser -> Maybe ByteString
userCurrentLoginIp AuthUser
u'
, userCurrentLoginIp :: Maybe ByteString
userCurrentLoginIp = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
ip }
updateLoginTS :: AuthUser -> m AuthUser
updateLoginTS u' :: AuthUser
u' = do
UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
AuthUser -> m AuthUser
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthUser -> m AuthUser) -> AuthUser -> m AuthUser
forall a b. (a -> b) -> a -> b
$
AuthUser
u' { userCurrentLoginAt :: Maybe UTCTime
userCurrentLoginAt = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
now
, userLastLoginAt :: Maybe UTCTime
userLastLoginAt = AuthUser -> Maybe UTCTime
userCurrentLoginAt AuthUser
u' }
resetFailCtr :: AuthUser -> m AuthUser
resetFailCtr u' :: AuthUser
u' = AuthUser -> m AuthUser
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthUser -> m AuthUser) -> AuthUser -> m AuthUser
forall a b. (a -> b) -> a -> b
$ AuthUser
u' { userFailedLoginCount :: Int
userFailedLoginCount = 0
, userLockedOutUntil :: Maybe UTCTime
userLockedOutUntil = Maybe UTCTime
forall a. Maybe a
Nothing }
checkPasswordAndLogin
:: AuthUser
-> Password
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
checkPasswordAndLogin :: AuthUser
-> Password
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
checkPasswordAndLogin u :: AuthUser
u pw :: Password
pw =
case AuthUser -> Maybe UTCTime
userLockedOutUntil AuthUser
u of
Just x :: UTCTime
x -> do
UTCTime
now <- IO UTCTime -> Handler b (AuthManager b) UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
if UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
x
then AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
auth AuthUser
u
else Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> (AuthFailure -> Either AuthFailure AuthUser)
-> AuthFailure
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left (AuthFailure
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> AuthFailure
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ UTCTime -> AuthFailure
LockedOut UTCTime
x
Nothing -> AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
auth AuthUser
u
where
auth :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
auth :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
auth user :: AuthUser
user =
case AuthUser -> Password -> Maybe AuthFailure
authenticatePassword AuthUser
user Password
pw of
Just e :: AuthFailure
e -> do
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthFail AuthUser
user
Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
e
Nothing -> do
AuthUser -> Handler b (AuthManager b) (Either AuthFailure ())
forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure ())
forceLogin AuthUser
user
(AuthManager b -> AuthManager b) -> Handler b (AuthManager b) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\mgr :: AuthManager b
mgr -> AuthManager b
mgr { activeUser :: Maybe AuthUser
activeUser = AuthUser -> Maybe AuthUser
forall a. a -> Maybe a
Just AuthUser
user })
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthSuccess AuthUser
user
forceLogin :: AuthUser
-> Handler b (AuthManager b) (Either AuthFailure ())
forceLogin :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure ())
forceLogin u :: AuthUser
u = do
SnapletLens b SessionManager
s <- (AuthManager b -> SnapletLens b SessionManager)
-> Handler b (AuthManager b) (SnapletLens b SessionManager)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> SnapletLens b SessionManager
forall b. AuthManager b -> SnapletLens b SessionManager
session
SnapletLens b SessionManager
-> Handler b (AuthManager b) (Either AuthFailure ())
-> Handler b (AuthManager b) (Either AuthFailure ())
forall b v a.
SnapletLens b SessionManager -> Handler b v a -> Handler b v a
withSession SnapletLens b SessionManager
s (Handler b (AuthManager b) (Either AuthFailure ())
-> Handler b (AuthManager b) (Either AuthFailure ()))
-> Handler b (AuthManager b) (Either AuthFailure ())
-> Handler b (AuthManager b) (Either AuthFailure ())
forall a b. (a -> b) -> a -> b
$
case AuthUser -> Maybe UserId
userId AuthUser
u of
Just x :: UserId
x -> do
SnapletLens b SessionManager
-> Handler b SessionManager () -> Handler b (AuthManager b) ()
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens b v' -> m b v' a -> m b v a
withTop SnapletLens b SessionManager
s (UserId -> Handler b SessionManager ()
forall b. UserId -> Handler b SessionManager ()
setSessionUserId UserId
x)
Either AuthFailure ()
-> Handler b (AuthManager b) (Either AuthFailure ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure ()
-> Handler b (AuthManager b) (Either AuthFailure ()))
-> Either AuthFailure ()
-> Handler b (AuthManager b) (Either AuthFailure ())
forall a b. (a -> b) -> a -> b
$ () -> Either AuthFailure ()
forall a b. b -> Either a b
Right ()
Nothing -> Either AuthFailure ()
-> Handler b (AuthManager b) (Either AuthFailure ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure ()
-> Handler b (AuthManager b) (Either AuthFailure ()))
-> (AuthFailure -> Either AuthFailure ())
-> AuthFailure
-> Handler b (AuthManager b) (Either AuthFailure ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthFailure -> Either AuthFailure ()
forall a b. a -> Either a b
Left (AuthFailure -> Handler b (AuthManager b) (Either AuthFailure ()))
-> AuthFailure -> Handler b (AuthManager b) (Either AuthFailure ())
forall a b. (a -> b) -> a -> b
$
String -> AuthFailure
AuthError (String -> AuthFailure) -> String -> AuthFailure
forall a b. (a -> b) -> a -> b
$ "forceLogin: Can't force the login of a user "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "without userId"
getRememberToken :: (Serialize t, MonadSnap m)
=> Key
-> ByteString
-> Maybe Int
-> m (Maybe t)
getRememberToken :: Key -> ByteString -> Maybe Int -> m (Maybe t)
getRememberToken sk :: Key
sk rc :: ByteString
rc rp :: Maybe Int
rp = ByteString -> Key -> Maybe Int -> m (Maybe t)
forall (m :: * -> *) t.
(MonadSnap m, Serialize t) =>
ByteString -> Key -> Maybe Int -> m (Maybe t)
getSecureCookie ByteString
rc Key
sk Maybe Int
rp
setRememberToken :: (Serialize t, MonadSnap m)
=> Key
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> t
-> m ()
setRememberToken :: Key -> ByteString -> Maybe ByteString -> Maybe Int -> t -> m ()
setRememberToken sk :: Key
sk rc :: ByteString
rc rd :: Maybe ByteString
rd rp :: Maybe Int
rp token :: t
token = ByteString -> Maybe ByteString -> Key -> Maybe Int -> t -> m ()
forall (m :: * -> *) t.
(MonadSnap m, Serialize t) =>
ByteString -> Maybe ByteString -> Key -> Maybe Int -> t -> m ()
setSecureCookie ByteString
rc Maybe ByteString
rd Key
sk Maybe Int
rp t
token
setSessionUserId :: UserId -> Handler b SessionManager ()
setSessionUserId :: UserId -> Handler b SessionManager ()
setSessionUserId (UserId t :: Text
t) = Text -> Text -> Handler b SessionManager ()
forall b. Text -> Text -> Handler b SessionManager ()
setInSession "__user_id" Text
t
removeSessionUserId :: Handler b SessionManager ()
removeSessionUserId :: Handler b SessionManager ()
removeSessionUserId = Text -> Handler b SessionManager ()
forall b. Text -> Handler b SessionManager ()
deleteFromSession "__user_id"
getSessionUserId :: Handler b SessionManager (Maybe UserId)
getSessionUserId :: Handler b SessionManager (Maybe UserId)
getSessionUserId = do
Maybe Text
uid <- Text -> Handler b SessionManager (Maybe Text)
forall b. Text -> Handler b SessionManager (Maybe Text)
getFromSession "__user_id"
Maybe UserId -> Handler b SessionManager (Maybe UserId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UserId -> Handler b SessionManager (Maybe UserId))
-> Maybe UserId -> Handler b SessionManager (Maybe UserId)
forall a b. (a -> b) -> a -> b
$ (Text -> UserId) -> Maybe Text -> Maybe UserId
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Text -> UserId
UserId Maybe Text
uid
authenticatePassword :: AuthUser
-> Password
-> Maybe AuthFailure
authenticatePassword :: AuthUser -> Password -> Maybe AuthFailure
authenticatePassword u :: AuthUser
u pw :: Password
pw = Maybe AuthFailure
auth
where
auth :: Maybe AuthFailure
auth = case AuthUser -> Maybe Password
userPassword AuthUser
u of
Nothing -> AuthFailure -> Maybe AuthFailure
forall a. a -> Maybe a
Just AuthFailure
PasswordMissing
Just upw :: Password
upw -> Bool -> Maybe AuthFailure
check (Bool -> Maybe AuthFailure) -> Bool -> Maybe AuthFailure
forall a b. (a -> b) -> a -> b
$ Password -> Password -> Bool
checkPassword Password
pw Password
upw
check :: Bool -> Maybe AuthFailure
check b :: Bool
b = if Bool
b then Maybe AuthFailure
forall a. Maybe a
Nothing else AuthFailure -> Maybe AuthFailure
forall a. a -> Maybe a
Just AuthFailure
IncorrectPassword
cacheOrLookup
:: Handler b (AuthManager b) (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
cacheOrLookup :: Handler b (AuthManager b) (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
cacheOrLookup f :: Handler b (AuthManager b) (Maybe AuthUser)
f = do
Maybe AuthUser
au <- (AuthManager b -> Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> Maybe AuthUser
forall b. AuthManager b -> Maybe AuthUser
activeUser
if Maybe AuthUser -> Bool
forall a. Maybe a -> Bool
isJust Maybe AuthUser
au
then Maybe AuthUser -> Handler b (AuthManager b) (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
au
else do
Maybe AuthUser
au' <- Handler b (AuthManager b) (Maybe AuthUser)
f
(AuthManager b -> AuthManager b) -> Handler b (AuthManager b) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\mgr :: AuthManager b
mgr -> AuthManager b
mgr { activeUser :: Maybe AuthUser
activeUser = Maybe AuthUser
au' })
Maybe AuthUser -> Handler b (AuthManager b) (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
au'
registerUser
:: ByteString
-> ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
registerUser :: ByteString
-> ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
registerUser lf :: ByteString
lf pf :: ByteString
pf = do
Maybe Text
l <- (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 (Maybe ByteString -> Maybe Text)
-> Handler b (AuthManager b) (Maybe ByteString)
-> Handler b (AuthManager b) (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Handler b (AuthManager b) (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
lf
Maybe ByteString
p <- ByteString -> Handler b (AuthManager b) (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
pf
let l' :: Either AuthFailure Text
l' = Either AuthFailure Text
-> (Text -> Either AuthFailure Text)
-> Maybe Text
-> Either AuthFailure Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AuthFailure -> Either AuthFailure Text
forall a b. a -> Either a b
Left AuthFailure
UsernameMissing) Text -> Either AuthFailure Text
forall a b. b -> Either a b
Right Maybe Text
l
let p' :: Either AuthFailure ByteString
p' = Either AuthFailure ByteString
-> (ByteString -> Either AuthFailure ByteString)
-> Maybe ByteString
-> Either AuthFailure ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AuthFailure -> Either AuthFailure ByteString
forall a b. a -> Either a b
Left AuthFailure
PasswordMissing) ByteString -> Either AuthFailure ByteString
forall a b. b -> Either a b
Right Maybe ByteString
p
case (Text -> ByteString -> (Text, ByteString))
-> Either AuthFailure Text
-> Either AuthFailure ByteString
-> Either AuthFailure (Text, ByteString)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Either AuthFailure Text
l' Either AuthFailure ByteString
p' of
Left e :: AuthFailure
e -> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
e
Right (lgn :: Text
lgn, pwd :: ByteString
pwd) -> Text
-> ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b.
Text
-> ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
createUser Text
lgn ByteString
pwd
loginUser
:: ByteString
-> ByteString
-> Maybe ByteString
-> (AuthFailure -> Handler b (AuthManager b) ())
-> Handler b (AuthManager b) ()
-> Handler b (AuthManager b) ()
loginUser :: ByteString
-> ByteString
-> Maybe ByteString
-> (AuthFailure -> Handler b (AuthManager b) ())
-> Handler b (AuthManager b) ()
-> Handler b (AuthManager b) ()
loginUser unf :: ByteString
unf pwdf :: ByteString
pwdf remf :: Maybe ByteString
remf loginFail :: AuthFailure -> Handler b (AuthManager b) ()
loginFail loginSucc :: Handler b (AuthManager b) ()
loginSucc =
ByteString
-> ByteString
-> Maybe ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b.
ByteString
-> ByteString
-> Maybe ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginUser' ByteString
unf ByteString
pwdf Maybe ByteString
remf Handler b (AuthManager b) (Either AuthFailure AuthUser)
-> (Either AuthFailure AuthUser -> Handler b (AuthManager b) ())
-> Handler b (AuthManager b) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (AuthFailure -> Handler b (AuthManager b) ())
-> (AuthUser -> Handler b (AuthManager b) ())
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either AuthFailure -> Handler b (AuthManager b) ()
loginFail (Handler b (AuthManager b) ()
-> AuthUser -> Handler b (AuthManager b) ()
forall a b. a -> b -> a
const Handler b (AuthManager b) ()
loginSucc)
loginUser' :: ByteString
-> ByteString
-> Maybe ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginUser' :: ByteString
-> ByteString
-> Maybe ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginUser' unf :: ByteString
unf pwdf :: ByteString
pwdf remf :: Maybe ByteString
remf = do
Maybe ByteString
mbUsername <- ByteString -> Handler b (AuthManager b) (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
unf
Maybe ByteString
mbPassword <- ByteString -> Handler b (AuthManager b) (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
pwdf
Bool
remember <- (Maybe Bool -> Bool)
-> Handler b (AuthManager b) (Maybe Bool)
-> Handler b (AuthManager b) Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False)
(MaybeT (Handler b (AuthManager b)) Bool
-> Handler b (AuthManager b) (Maybe Bool)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (Handler b (AuthManager b)) Bool
-> Handler b (AuthManager b) (Maybe Bool))
-> MaybeT (Handler b (AuthManager b)) Bool
-> Handler b (AuthManager b) (Maybe Bool)
forall a b. (a -> b) -> a -> b
$
do ByteString
field <- Handler b (AuthManager b) (Maybe ByteString)
-> MaybeT (Handler b (AuthManager b)) ByteString
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Handler b (AuthManager b) (Maybe ByteString)
-> MaybeT (Handler b (AuthManager b)) ByteString)
-> Handler b (AuthManager b) (Maybe ByteString)
-> MaybeT (Handler b (AuthManager b)) ByteString
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> Handler b (AuthManager b) (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
remf
ByteString
value <- Handler b (AuthManager b) (Maybe ByteString)
-> MaybeT (Handler b (AuthManager b)) ByteString
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Handler b (AuthManager b) (Maybe ByteString)
-> MaybeT (Handler b (AuthManager b)) ByteString)
-> Handler b (AuthManager b) (Maybe ByteString)
-> MaybeT (Handler b (AuthManager b)) ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Handler b (AuthManager b) (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
field
Bool -> MaybeT (Handler b (AuthManager b)) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> MaybeT (Handler b (AuthManager b)) Bool)
-> Bool -> MaybeT (Handler b (AuthManager b)) Bool
forall a b. (a -> b) -> a -> b
$ ByteString
value ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "1" Bool -> Bool -> Bool
|| ByteString
value ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "on")
case Maybe ByteString
mbUsername of
Nothing -> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
UsernameMissing
Just u :: ByteString
u -> case Maybe ByteString
mbPassword of
Nothing -> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthFailure -> Either AuthFailure AuthUser
forall a b. a -> Either a b
Left AuthFailure
PasswordMissing
Just p :: ByteString
p -> Text
-> Password
-> Bool
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall b.
Text
-> Password
-> Bool
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername (ByteString -> Text
decodeUtf8 ByteString
u) (ByteString -> Password
ClearText ByteString
p) Bool
remember
logoutUser :: Handler b (AuthManager b) ()
-> Handler b (AuthManager b) ()
logoutUser :: Handler b (AuthManager b) () -> Handler b (AuthManager b) ()
logoutUser target :: Handler b (AuthManager b) ()
target = Handler b (AuthManager b) ()
forall b. Handler b (AuthManager b) ()
logout Handler b (AuthManager b) ()
-> Handler b (AuthManager b) () -> Handler b (AuthManager b) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handler b (AuthManager b) ()
target
requireUser :: SnapletLens b (AuthManager b)
-> Handler b v a
-> Handler b v a
-> Handler b v a
requireUser :: SnapletLens b (AuthManager b)
-> Handler b v a -> Handler b v a -> Handler b v a
requireUser auth :: SnapletLens b (AuthManager b)
auth bad :: Handler b v a
bad good :: Handler b v a
good = do
Bool
loggedIn <- SnapletLens b (AuthManager b)
-> Handler b (AuthManager b) Bool -> Handler b v Bool
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens b v' -> m b v' a -> m b v a
withTop SnapletLens b (AuthManager b)
auth Handler b (AuthManager b) Bool
forall b. Handler b (AuthManager b) Bool
isLoggedIn
if Bool
loggedIn then Handler b v a
good else Handler b v a
bad
withBackend ::
(forall r. (IAuthBackend r) => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend :: (forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend f :: forall r. IAuthBackend r => r -> Handler b (AuthManager v) a
f = Handler b (AuthManager v) (Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Handler b (AuthManager v) (Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) (Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
forall a b. (a -> b) -> a -> b
$ do
(AuthManager backend_ :: r
backend_ _ _ _ _ _ _ _ _ _) <- Handler b (AuthManager v) (AuthManager v)
forall s (m :: * -> *). MonadState s m => m s
get
Handler b (AuthManager v) a
-> Handler b (AuthManager v) (Handler b (AuthManager v) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handler b (AuthManager v) a
-> Handler b (AuthManager v) (Handler b (AuthManager v) a))
-> Handler b (AuthManager v) a
-> Handler b (AuthManager v) (Handler b (AuthManager v) a)
forall a b. (a -> b) -> a -> b
$ r -> Handler b (AuthManager v) a
forall r. IAuthBackend r => r -> Handler b (AuthManager v) a
f r
backend_
setPasswordResetToken :: Text -> Handler b (AuthManager b) (Maybe Text)
setPasswordResetToken :: Text -> Handler b (AuthManager b) (Maybe Text)
setPasswordResetToken login :: Text
login = do
ByteString
tokBS <- IO ByteString -> Handler b (AuthManager b) ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Handler b (AuthManager b) ByteString)
-> (RNG -> IO ByteString)
-> RNG
-> Handler b (AuthManager b) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> RNG -> IO ByteString
randomToken 40 (RNG -> Handler b (AuthManager b) ByteString)
-> Handler b (AuthManager b) RNG
-> Handler b (AuthManager b) ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (AuthManager b -> RNG) -> Handler b (AuthManager b) RNG
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AuthManager b -> RNG
forall b. AuthManager b -> RNG
randomNumberGenerator
let token :: Text
token = ByteString -> Text
decodeUtf8 ByteString
tokBS
UTCTime
now <- IO UTCTime -> Handler b (AuthManager b) UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
Bool
success <- Text
-> Maybe Text -> Maybe UTCTime -> Handler b (AuthManager b) Bool
forall v.
Text
-> Maybe Text -> Maybe UTCTime -> Handler v (AuthManager v) Bool
modPasswordResetToken Text
login (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
token) (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
now)
Maybe Text -> Handler b (AuthManager b) (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> Handler b (AuthManager b) (Maybe Text))
-> Maybe Text -> Handler b (AuthManager b) (Maybe Text)
forall a b. (a -> b) -> a -> b
$ if Bool
success then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
token else Maybe Text
forall a. Maybe a
Nothing
clearPasswordResetToken :: Text -> Handler b (AuthManager b) Bool
clearPasswordResetToken :: Text -> Handler b (AuthManager b) Bool
clearPasswordResetToken login :: Text
login = Text
-> Maybe Text -> Maybe UTCTime -> Handler b (AuthManager b) Bool
forall v.
Text
-> Maybe Text -> Maybe UTCTime -> Handler v (AuthManager v) Bool
modPasswordResetToken Text
login Maybe Text
forall a. Maybe a
Nothing Maybe UTCTime
forall a. Maybe a
Nothing
modPasswordResetToken :: Text
-> Maybe Text
-> Maybe UTCTime
-> Handler v (AuthManager v) Bool
modPasswordResetToken :: Text
-> Maybe Text -> Maybe UTCTime -> Handler v (AuthManager v) Bool
modPasswordResetToken login :: Text
login token :: Maybe Text
token timestamp :: Maybe UTCTime
timestamp = do
Maybe ()
res <- MaybeT (Handler v (AuthManager v)) ()
-> Handler v (AuthManager v) (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (Handler v (AuthManager v)) ()
-> Handler v (AuthManager v) (Maybe ()))
-> MaybeT (Handler v (AuthManager v)) ()
-> Handler v (AuthManager v) (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
AuthUser
u <- Handler v (AuthManager v) (Maybe AuthUser)
-> MaybeT (Handler v (AuthManager v)) AuthUser
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Handler v (AuthManager v) (Maybe AuthUser)
-> MaybeT (Handler v (AuthManager v)) AuthUser)
-> Handler v (AuthManager v) (Maybe AuthUser)
-> MaybeT (Handler v (AuthManager v)) AuthUser
forall a b. (a -> b) -> a -> b
$ (forall r.
IAuthBackend r =>
r -> Handler v (AuthManager v) (Maybe AuthUser))
-> Handler v (AuthManager v) (Maybe AuthUser)
forall b v a.
(forall r. IAuthBackend r => r -> Handler b (AuthManager v) a)
-> Handler b (AuthManager v) a
withBackend ((forall r.
IAuthBackend r =>
r -> Handler v (AuthManager v) (Maybe AuthUser))
-> Handler v (AuthManager v) (Maybe AuthUser))
-> (forall r.
IAuthBackend r =>
r -> Handler v (AuthManager v) (Maybe AuthUser))
-> Handler v (AuthManager v) (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ \b :: r
b -> IO (Maybe AuthUser) -> Handler v (AuthManager v) (Maybe AuthUser)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe AuthUser) -> Handler v (AuthManager v) (Maybe AuthUser))
-> IO (Maybe AuthUser)
-> Handler v (AuthManager v) (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ r -> Text -> IO (Maybe AuthUser)
forall r. IAuthBackend r => r -> Text -> IO (Maybe AuthUser)
lookupByLogin r
b Text
login
Handler v (AuthManager v) (Either AuthFailure AuthUser)
-> MaybeT (Handler v (AuthManager v)) (Either AuthFailure AuthUser)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler v (AuthManager v) (Either AuthFailure AuthUser)
-> MaybeT
(Handler v (AuthManager v)) (Either AuthFailure AuthUser))
-> Handler v (AuthManager v) (Either AuthFailure AuthUser)
-> MaybeT (Handler v (AuthManager v)) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthUser -> Handler v (AuthManager v) (Either AuthFailure AuthUser)
forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
saveUser (AuthUser
-> Handler v (AuthManager v) (Either AuthFailure AuthUser))
-> AuthUser
-> Handler v (AuthManager v) (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthUser
u
{ userResetToken :: Maybe Text
userResetToken = Maybe Text
token
, userResetRequestedAt :: Maybe UTCTime
userResetRequestedAt = Maybe UTCTime
timestamp
}
() -> MaybeT (Handler v (AuthManager v)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Bool -> Handler v (AuthManager v) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Handler v (AuthManager v) Bool)
-> Bool -> Handler v (AuthManager v) Bool
forall a b. (a -> b) -> a -> b
$ Bool -> (() -> Bool) -> Maybe () -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\_ -> Bool
True) Maybe ()
res