{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
module Snap.Snaplet.Auth.Handlers where
import Control.Applicative
import Control.Monad (join, liftM, liftM2)
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 :: forall b.
Text
-> ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
createUser Text
unm 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 a. a -> Handler b (AuthManager b) a
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 a. a -> Handler b (AuthManager b) a
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 -> IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. IO a -> Handler b (AuthManager b) a
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 :: forall b. Text -> Handler b (AuthManager b) Bool
usernameExists 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 -> IO Bool -> Handler b (AuthManager b) Bool
forall a. IO a -> Handler b (AuthManager b) a
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 :: forall b.
Text
-> Password
-> Bool
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername Text
_ (Encrypted ByteString
_) Bool
_ = Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
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 Text
unm Password
pwd 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' :: 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 t
r =
IO (Maybe AuthUser) -> Handler b (AuthManager b) (Maybe AuthUser)
forall a. IO a -> Handler b (AuthManager b) a
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 a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
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 a. a -> Handler b (AuthManager b) a
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 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 a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
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 a. a -> Handler b (AuthManager b) a
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 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 a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
IO ByteString -> Handler b (AuthManager b) ByteString
forall a. IO a -> Handler b (AuthManager b) a
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 Int
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 = Just (decodeUtf8 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 a. a -> Handler b (AuthManager b) a
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 a. a -> Handler b (AuthManager b) a
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 :: forall b. 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
$ \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 a. IO a -> Handler b (AuthManager b) a
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
Maybe AuthUser
Nothing -> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
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
String
"loginByRememberToken: no remember token"
Just 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 a. a -> Handler b (AuthManager b) a
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 :: forall b. 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 b v' a v.
SnapletLens b v' -> Handler b v' a -> Handler b v a
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
$ \AuthManager b
mgr -> AuthManager b
mgr { activeUser = Nothing }
currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
currentUser :: forall b. 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 -> 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 b v' a v.
SnapletLens b v' -> Handler b v' a -> Handler b v a
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
Maybe UserId
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 UserId
uid' -> IO (Maybe AuthUser) -> Handler b (AuthManager b) (Maybe AuthUser)
forall a. IO a -> Handler b (AuthManager b) a
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 :: forall b. 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 :: forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
saveUser 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 a. a -> Handler b (AuthManager b) a
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 -> IO (Either AuthFailure AuthUser)
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. IO a -> Handler b (AuthManager b) a
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 :: forall b. AuthUser -> Handler b (AuthManager b) ()
destroyUser 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 a. IO a -> Handler b (AuthManager b) a
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 :: forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthFail 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 -> 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 a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
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 a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
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 a. IO a -> Handler b (AuthManager b) a
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 AuthUser
u' = AuthUser -> m AuthUser
forall a. a -> m a
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 = userFailedLoginCount u' + 1
}
checkLockout :: Maybe (Int, NominalDiffTime) -> AuthUser -> m AuthUser
checkLockout Maybe (Int, NominalDiffTime)
lo AuthUser
u' =
case Maybe (Int, NominalDiffTime)
lo of
Maybe (Int, NominalDiffTime)
Nothing -> AuthUser -> m AuthUser
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return AuthUser
u'
Just (Int
mx, 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 a. IO a -> m a
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 a. a -> m a
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 = Just reopen }
else AuthUser -> m AuthUser
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return AuthUser
u'
markAuthSuccess :: AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthSuccess :: forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthSuccess 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 ->
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 a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
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 a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
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 a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
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 a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) b
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 a. IO a -> Handler b (AuthManager b) a
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 AuthUser
u' = AuthUser -> m AuthUser
forall a. a -> m a
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 = userLoginCount u' + 1 }
updateIp :: AuthUser -> m AuthUser
updateIp 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 a. a -> m a
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 = userCurrentLoginIp u'
, userCurrentLoginIp = Just ip }
updateLoginTS :: AuthUser -> m AuthUser
updateLoginTS AuthUser
u' = do
UTCTime
now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
AuthUser -> m AuthUser
forall a. a -> m a
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 = Just now
, userLastLoginAt = userCurrentLoginAt u' }
resetFailCtr :: AuthUser -> m AuthUser
resetFailCtr AuthUser
u' = AuthUser -> m AuthUser
forall a. a -> m a
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 = 0
, userLockedOutUntil = Nothing }
checkPasswordAndLogin
:: AuthUser
-> Password
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
checkPasswordAndLogin :: forall b.
AuthUser
-> Password
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
checkPasswordAndLogin AuthUser
u Password
pw =
case AuthUser -> Maybe UTCTime
userLockedOutUntil AuthUser
u of
Just UTCTime
x -> do
UTCTime
now <- IO UTCTime -> Handler b (AuthManager b) UTCTime
forall a. IO a -> Handler b (AuthManager b) a
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 a. a -> Handler b (AuthManager b) a
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
Maybe UTCTime
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 :: forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
auth AuthUser
user =
case AuthUser -> Password -> Maybe AuthFailure
authenticatePassword AuthUser
user Password
pw of
Just 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 a. a -> Handler b (AuthManager b) a
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
Maybe AuthFailure
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 (\AuthManager b
mgr -> AuthManager b
mgr { activeUser = Just 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 :: forall b.
AuthUser -> Handler b (AuthManager b) (Either AuthFailure ())
forceLogin 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 UserId
x -> do
SnapletLens b SessionManager
-> Handler b SessionManager () -> Handler b (AuthManager b) ()
forall b v' a v.
SnapletLens b v' -> Handler b v' a -> Handler b v a
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 a. a -> Handler b (AuthManager b) a
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 ()
Maybe UserId
Nothing -> Either AuthFailure ()
-> Handler b (AuthManager b) (Either AuthFailure ())
forall a. a -> Handler b (AuthManager b) a
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
$ String
"forceLogin: Can't force the login of a user "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"without userId"
getRememberToken :: (Serialize t, MonadSnap m)
=> Key
-> ByteString
-> Maybe Int
-> m (Maybe t)
getRememberToken :: forall t (m :: * -> *).
(Serialize t, MonadSnap m) =>
Key -> ByteString -> Maybe Int -> m (Maybe t)
getRememberToken Key
sk ByteString
rc 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 :: forall t (m :: * -> *).
(Serialize t, MonadSnap m) =>
Key -> ByteString -> Maybe ByteString -> Maybe Int -> t -> m ()
setRememberToken Key
sk ByteString
rc Maybe ByteString
rd Maybe Int
rp 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 :: forall b. UserId -> Handler b SessionManager ()
setSessionUserId (UserId Text
t) = Text -> Text -> Handler b SessionManager ()
forall b. Text -> Text -> Handler b SessionManager ()
setInSession Text
"__user_id" Text
t
removeSessionUserId :: Handler b SessionManager ()
removeSessionUserId :: forall b. Handler b SessionManager ()
removeSessionUserId = Text -> Handler b SessionManager ()
forall b. Text -> Handler b SessionManager ()
deleteFromSession Text
"__user_id"
getSessionUserId :: Handler b SessionManager (Maybe UserId)
getSessionUserId :: forall b. 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 Text
"__user_id"
Maybe UserId -> Handler b SessionManager (Maybe UserId)
forall a. a -> Handler b SessionManager a
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 AuthUser
u Password
pw = Maybe AuthFailure
auth
where
auth :: Maybe AuthFailure
auth = case AuthUser -> Maybe Password
userPassword AuthUser
u of
Maybe Password
Nothing -> AuthFailure -> Maybe AuthFailure
forall a. a -> Maybe a
Just AuthFailure
PasswordMissing
Just 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 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 :: forall b.
Handler b (AuthManager b) (Maybe AuthUser)
-> Handler b (AuthManager b) (Maybe AuthUser)
cacheOrLookup 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 a. a -> Handler b (AuthManager b) a
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 (\AuthManager b
mgr -> AuthManager b
mgr { activeUser = au' })
Maybe AuthUser -> Handler b (AuthManager b) (Maybe AuthUser)
forall a. a -> Handler b (AuthManager b) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
au'
registerUser
:: ByteString
-> ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
registerUser :: forall b.
ByteString
-> ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
registerUser ByteString
lf ByteString
pf = do
Maybe Text
l <- (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
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 AuthFailure
e -> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
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 (Text
lgn, 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 :: forall b.
ByteString
-> ByteString
-> Maybe ByteString
-> (AuthFailure -> Handler b (AuthManager b) ())
-> Handler b (AuthManager b) ()
-> Handler b (AuthManager b) ()
loginUser ByteString
unf ByteString
pwdf Maybe ByteString
remf AuthFailure -> Handler b (AuthManager b) ()
loginFail 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 a b.
Handler b (AuthManager b) a
-> (a -> Handler b (AuthManager b) b)
-> Handler b (AuthManager b) 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' :: forall b.
ByteString
-> ByteString
-> Maybe ByteString
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginUser' ByteString
unf ByteString
pwdf 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 a. a -> Handler b (AuthManager b) a
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 a. a -> MaybeT (Handler b (AuthManager b)) a
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
== ByteString
"1" Bool -> Bool -> Bool
|| ByteString
value ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"on")
case Maybe ByteString
mbUsername of
Maybe ByteString
Nothing -> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
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 ByteString
u -> case Maybe ByteString
mbPassword of
Maybe ByteString
Nothing -> Either AuthFailure AuthUser
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forall a. a -> Handler b (AuthManager b) a
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 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 :: forall b.
Handler b (AuthManager b) () -> Handler b (AuthManager b) ()
logoutUser 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 a b.
Handler b (AuthManager b) a
-> Handler b (AuthManager b) b -> Handler b (AuthManager b) 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 :: forall b v a.
SnapletLens b (AuthManager b)
-> Handler b v a -> Handler b v a -> Handler b v a
requireUser SnapletLens b (AuthManager b)
auth Handler b v a
bad Handler b v a
good = do
Bool
loggedIn <- SnapletLens b (AuthManager b)
-> Handler b (AuthManager b) Bool -> Handler b v Bool
forall b v' a v.
SnapletLens b v' -> Handler b v' a -> Handler b v a
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 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 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 r
backend_ SnapletLens v SessionManager
_ Maybe AuthUser
_ Int
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ Key
_ Maybe (Int, NominalDiffTime)
_ RNG
_) <- 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 a. a -> 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 :: forall b. Text -> Handler b (AuthManager b) (Maybe Text)
setPasswordResetToken Text
login = do
ByteString
tokBS <- IO ByteString -> Handler b (AuthManager b) ByteString
forall a. IO a -> Handler b (AuthManager b) a
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 Int
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 a. IO a -> Handler b (AuthManager b) a
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 a. a -> Handler b (AuthManager b) a
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 :: forall b. Text -> Handler b (AuthManager b) Bool
clearPasswordResetToken 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 :: forall v.
Text
-> Maybe Text -> Maybe UTCTime -> Handler v (AuthManager v) Bool
modPasswordResetToken Text
login Maybe Text
token 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
$ \r
b -> IO (Maybe AuthUser) -> Handler v (AuthManager v) (Maybe AuthUser)
forall a. IO a -> Handler v (AuthManager v) a
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 (m :: * -> *) a. Monad m => m a -> MaybeT m a
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 = token
, userResetRequestedAt = timestamp
}
() -> MaybeT (Handler v (AuthManager v)) ()
forall a. a -> MaybeT (Handler v (AuthManager v)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Bool -> Handler v (AuthManager v) Bool
forall a. a -> Handler v (AuthManager v) a
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