{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Yesod.Auth.Simple
(
YesodAuthSimple(..)
, authSimple
, loginR
, registerR
, resetPasswordR
, resetPasswordEmailSentR
, setPasswordTokenR
, confirmTokenR
, confirmR
, userExistsR
, registerSuccessR
, confirmationEmailSentR
, passwordStrengthR
, loginTemplateDef
, setPasswordTemplateDef
, invalidTokenTemplateDef
, userExistsTemplateDef
, registerSuccessTemplateDef
, resetPasswordEmailSentTemplateDef
, confirmationEmailSentTemplateDef
, confirmTemplateDef
, resetPasswordTemplateDef
, registerTemplateDef
, passwordFieldTemplateBasic
, passwordFieldTemplateZxcvbn
, honeypotFieldTemplate
, genToken
, encodeToken
, hashAndEncodeToken
, decodeToken
, getError
, setError
, clearError
, maxPasswordLength
, Email(..)
, Password(..)
, PW.Strength(..)
, PasswordCheck(..)
, PasswordStrength(..)
, EncryptedPass(..)
, Pass(..)
, encryptPassIO'
) where
import ClassyPrelude
import Crypto.Hash (Digest, SHA256)
import qualified Crypto.Hash as C
import Crypto.Random (getRandomBytes)
import Crypto.Scrypt (EncryptedPass(..), Pass(..), encryptPassIO', verifyPass')
import Data.Aeson
import qualified Data.ByteArray as ByteArray
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Base64.URL as B64Url
import Data.Function ((&))
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8', decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Vector as Vec
import Network.HTTP.Types (badRequest400, tooManyRequests429)
import Network.Wai (responseBuilder)
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
import Text.Email.Validate (canonicalizeEmail)
import Text.Hamlet (hamletFile)
import Text.Julius (juliusFile)
import Text.Lucius (luciusFile)
import qualified Text.Password.Strength as PW
import qualified Text.Password.Strength.Config as PW
import Yesod.Auth
import Yesod.Auth.Simple.Types
import Yesod.Core
import Yesod.Core.Json as J
import Yesod.Form (iopt, ireq, runInputPost, textField)
minPasswordLength :: Int
minPasswordLength :: Int
minPasswordLength = Int
8
maxPasswordLength :: Int
maxPasswordLength :: Int
maxPasswordLength = Int
150
confirmTokenR :: Text -> AuthRoute
confirmTokenR :: Text -> AuthRoute
confirmTokenR Text
token = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"confirm", Text
token]
confirmR :: AuthRoute
confirmR :: AuthRoute
confirmR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"confirm"]
confirmationEmailSentR :: AuthRoute
confirmationEmailSentR :: AuthRoute
confirmationEmailSentR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"confirmation-email-sent"]
confirmationEmailResentR :: AuthRoute
confirmationEmailResentR :: AuthRoute
confirmationEmailResentR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"confirmation-email-resent"]
loginR :: AuthRoute
loginR :: AuthRoute
loginR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"login"]
registerR :: AuthRoute
registerR :: AuthRoute
registerR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"register"]
registerSuccessR :: AuthRoute
registerSuccessR :: AuthRoute
registerSuccessR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"register-success"]
resetPasswordEmailSentR :: AuthRoute
resetPasswordEmailSentR :: AuthRoute
resetPasswordEmailSentR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"reset-password-email-sent"]
resetPasswordR :: AuthRoute
resetPasswordR :: AuthRoute
resetPasswordR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"reset-password"]
setPasswordR :: AuthRoute
setPasswordR :: AuthRoute
setPasswordR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"set-password"]
setPasswordTokenR :: Text -> AuthRoute
setPasswordTokenR :: Text -> AuthRoute
setPasswordTokenR Text
token = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"set-password", Text
token]
userExistsR :: AuthRoute
userExistsR :: AuthRoute
userExistsR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"user-exists"]
passwordStrengthR :: AuthRoute
passwordStrengthR :: AuthRoute
passwordStrengthR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"password-strength"]
class (YesodAuth a, PathPiece (AuthSimpleId a)) => YesodAuthSimple a where
type AuthSimpleId a
afterPasswordRoute :: a -> Route a
getUserId :: MonadAuthHandler a m => Email -> m (Maybe (AuthSimpleId a))
getUserPassword :: MonadAuthHandler a m => AuthSimpleId a -> m EncryptedPass
onRegisterSuccess :: MonadAuthHandler a m => m TypedContent
insertUser :: MonadAuthHandler a m => Email -> EncryptedPass -> m (Maybe (AuthSimpleId a))
updateUserPassword :: MonadAuthHandler a m => AuthSimpleId a -> EncryptedPass -> m ()
shouldPreventLoginAttempt :: MonadAuthHandler a m =>
Maybe (AuthSimpleId a) -> m (Maybe UTCTime)
shouldPreventLoginAttempt Maybe (AuthSimpleId a)
_ = Maybe UTCTime -> m (Maybe UTCTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UTCTime
forall a. Maybe a
Nothing
onLoginAttempt :: MonadAuthHandler a m => Maybe (AuthSimpleId a)
-> Bool
-> m ()
onLoginAttempt Maybe (AuthSimpleId a)
_ Bool
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
sendVerifyEmail :: MonadAuthHandler a m => Email
-> VerUrl
-> Text
-> m ()
sendVerifyEmail Email
_ Text
url Text
_ = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> IO ()
forall a (m :: * -> *). (Show a, MonadIO m) => a -> m ()
print (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
url
sendResetPasswordEmail :: MonadAuthHandler a m => Email -> VerUrl -> Text -> m ()
sendResetPasswordEmail Email
_ Text
url Text
_ = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> IO ()
forall a (m :: * -> *). (Show a, MonadIO m) => a -> m ()
print (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
url
matchRegistrationToken :: MonadAuthHandler a m => Text -> m (Maybe Email)
isConfirmationPending :: MonadAuthHandler a m => Email -> m Bool
isConfirmationPending Email
_ = Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
matchPasswordToken :: MonadAuthHandler a m => Text -> m (Maybe (AuthSimpleId a))
onRegistrationTokenUsed :: MonadAuthHandler a m => Email -> m ()
onRegistrationTokenUsed Email
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
onEmailAlreadyExist :: MonadAuthHandler a m => m TypedContent
onEmailAlreadyExist = do
let msg :: Text
msg = Text
"This email address is already in use. Please login to your existing account."
AuthRoute -> Text -> AuthHandler a TypedContent
forall a. AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError AuthRoute
registerR Text
msg
passwordFieldTemplate :: (AuthRoute -> Route a) -> WidgetFor a ()
passwordFieldTemplate AuthRoute -> Route a
tp =
case YesodAuthSimple a => PasswordCheck
forall a. YesodAuthSimple a => PasswordCheck
passwordCheck @a of
Zxcvbn Strength
minStren Vector Text
extraWords' ->
(AuthRoute -> Route a) -> Strength -> Vector Text -> WidgetFor a ()
forall a.
(AuthRoute -> Route a) -> Strength -> Vector Text -> WidgetFor a ()
passwordFieldTemplateZxcvbn AuthRoute -> Route a
tp Strength
minStren Vector Text
extraWords'
RuleBased Int
_ -> WidgetFor a ()
forall a. WidgetFor a ()
passwordFieldTemplateBasic
loginTemplate :: (AuthRoute -> Route a)
-> Maybe Text
-> Maybe Text
-> WidgetFor a ()
loginTemplate = (AuthRoute -> Route a)
-> Maybe Text -> Maybe Text -> WidgetFor a ()
forall a.
(AuthRoute -> Route a)
-> Maybe Text -> Maybe Text -> WidgetFor a ()
loginTemplateDef
registerTemplate :: (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
registerTemplate = (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
forall a. (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
registerTemplateDef
resetPasswordTemplate ::
(AuthRoute -> Route a)
-> Maybe Text
-> WidgetFor a ()
resetPasswordTemplate = (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
forall a. (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
resetPasswordTemplateDef
confirmTemplate ::
(AuthRoute -> Route a)
-> Route a
-> Email
-> Maybe Text
-> WidgetFor a ()
confirmTemplate = (AuthRoute -> Route a)
-> Route a -> Email -> Maybe Text -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a)
-> Route a -> Email -> Maybe Text -> WidgetFor a ()
confirmTemplateDef
confirmationEmailSentTemplate :: WidgetFor a ()
confirmationEmailSentTemplate = WidgetFor a ()
forall a. WidgetFor a ()
confirmationEmailSentTemplateDef
confirmationEmailResentTemplate :: WidgetFor a ()
confirmationEmailResentTemplate = WidgetFor a ()
forall a. YesodAuthSimple a => WidgetFor a ()
confirmationEmailSentTemplate
resetPasswordEmailSentTemplate :: WidgetFor a ()
resetPasswordEmailSentTemplate = WidgetFor a ()
forall a. WidgetFor a ()
resetPasswordEmailSentTemplateDef
registerSuccessTemplate :: WidgetFor a ()
registerSuccessTemplate = WidgetFor a ()
forall a. WidgetFor a ()
registerSuccessTemplateDef
userExistsTemplate :: WidgetFor a ()
userExistsTemplate = WidgetFor a ()
forall a. WidgetFor a ()
userExistsTemplateDef
invalidPasswordTokenTemplate :: Text -> WidgetFor a ()
invalidPasswordTokenTemplate = Text -> WidgetFor a ()
forall a. Text -> WidgetFor a ()
invalidTokenTemplateDef
invalidRegistrationTokenTemplate :: Text -> WidgetFor a ()
invalidRegistrationTokenTemplate = Text -> WidgetFor a ()
forall a. Text -> WidgetFor a ()
invalidTokenTemplateDef
tooManyLoginAttemptsTemplate :: UTCTime -> WidgetFor a ()
tooManyLoginAttemptsTemplate = UTCTime -> WidgetFor a ()
forall a. UTCTime -> WidgetFor a ()
tooManyLoginAttemptsTemplateDef
setPasswordTemplate ::
(AuthRoute -> Route a)
-> Route a
-> Maybe Text
-> WidgetFor a ()
setPasswordTemplate = (AuthRoute -> Route a) -> Route a -> Maybe Text -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a) -> Route a -> Maybe Text -> WidgetFor a ()
setPasswordTemplateDef
onPasswordUpdated :: MonadAuthHandler a m => AuthSimpleId a -> m ()
onPasswordUpdated AuthSimpleId a
_ = Html -> m ()
forall (m :: * -> *). MonadHandler m => Html -> m ()
setMessage Html
"Password has been updated"
onBotPost :: MonadAuthHandler a m => m ()
onBotPost = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
passwordCheck :: PasswordCheck
passwordCheck = Strength -> Vector Text -> PasswordCheck
Zxcvbn Strength
PW.Safe Vector Text
forall a. Vector a
Vec.empty
authSimple :: YesodAuthSimple m => AuthPlugin m
authSimple :: AuthPlugin m
authSimple = Text
-> (Text -> Texts -> AuthHandler m TypedContent)
-> ((AuthRoute -> Route m) -> WidgetFor m ())
-> AuthPlugin m
forall master.
Text
-> (Text -> Texts -> AuthHandler master TypedContent)
-> ((AuthRoute -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
"simple" Text -> Texts -> AuthHandler m TypedContent
forall a.
YesodAuthSimple a =>
Text -> Texts -> AuthHandler a TypedContent
dispatch (AuthRoute -> Route m) -> WidgetFor m ()
forall a. (AuthRoute -> Route a) -> WidgetFor a ()
loginHandlerRedirect
loginHandlerRedirect :: (Route Auth -> Route a) -> WidgetFor a ()
loginHandlerRedirect :: (AuthRoute -> Route a) -> WidgetFor a ()
loginHandlerRedirect AuthRoute -> Route a
tm = Route a -> WidgetFor a ()
forall a. Route a -> WidgetFor a ()
redirectTemplate (Route a -> WidgetFor a ()) -> Route a -> WidgetFor a ()
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tm AuthRoute
loginR
dispatch :: YesodAuthSimple a => Text -> [Text] -> AuthHandler a TypedContent
dispatch :: Text -> Texts -> AuthHandler a TypedContent
dispatch Text
method Texts
path = case (Text
method, Texts
path) of
(Text
"GET", [Text
"register"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getRegisterR
(Text
"POST", [Text
"register"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
postRegisterR
(Text
"GET", [Text
"confirm", Text
token]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr (m TypedContent -> m TypedContent)
-> m TypedContent -> m TypedContent
forall a b. (a -> b) -> a -> b
$ Text -> AuthHandler a TypedContent
forall a. Text -> AuthHandler a TypedContent
getConfirmTokenR Text
token
(Text
"GET", [Text
"confirm"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getConfirmR
(Text
"POST", [Text
"confirm"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
postConfirmR
(Text
"GET", [Text
"confirmation-email-sent"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getConfirmationEmailSentR
(Text
"GET", [Text
"confirmation-email-resent"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getConfirmationEmailResentR
(Text
"GET", [Text
"register-success"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. AuthHandler a TypedContent
getRegisterSuccessR
(Text
"GET", [Text
"user-exists"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getUserExistsR
(Text
"GET", [Text
"login"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getLoginR
(Text
"POST", [Text
"login"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
postLoginR
(Text
"GET", [Text
"set-password", Text
token]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr (m TypedContent -> m TypedContent)
-> m TypedContent -> m TypedContent
forall a b. (a -> b) -> a -> b
$ Text -> AuthHandler a TypedContent
forall a. Text -> AuthHandler a TypedContent
getSetPasswordTokenR Text
token
(Text
"GET", [Text
"set-password"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getSetPasswordR
(Text
"POST", [Text
"set-password"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
postSetPasswordR
(Text
"GET", [Text
"reset-password"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getResetPasswordR
(Text
"POST", [Text
"reset-password"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
postResetPasswordR
(Text
"GET", [Text
"reset-password-email-sent"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getResetPasswordEmailSentR
(Text
"POST", [Text
"password-strength"]) -> m Value -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m Value
forall a. YesodAuthSimple a => AuthHandler a Value
postPasswordStrengthR
(Text, Texts)
_ -> m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
notFound
where sr :: m c -> m b
sr m c
r = m c
r m c -> (c -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= c -> m b
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
getRegisterR :: YesodAuthSimple a => AuthHandler a TypedContent
getRegisterR :: AuthHandler a TypedContent
getRegisterR = do
Maybe Text
mErr <- m (Maybe Text)
forall a. AuthHandler a (Maybe Text)
getError
Maybe (AuthId a)
muid <- m (Maybe (AuthId a))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
maybeAuthId
AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
case Maybe (AuthId a)
muid of
Maybe (AuthId a)
Nothing -> Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Register a new account"
(AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
registerTemplate AuthRoute -> Route a
tp Maybe Text
mErr
Just AuthId a
_ -> Text -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Text -> m TypedContent) -> Text -> m TypedContent
forall a b. (a -> b) -> a -> b
$ String -> Text
forall s. PathPiece s => s -> Text
toPathPiece (String
"/" :: String)
getResetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent
getResetPasswordR :: AuthHandler a TypedContent
getResetPasswordR = do
Maybe Text
mErr <- m (Maybe Text)
forall a. AuthHandler a (Maybe Text)
getError
AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Reset password"
(AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
resetPasswordTemplate AuthRoute -> Route a
tp Maybe Text
mErr
getLoginR :: YesodAuthSimple a => AuthHandler a TypedContent
getLoginR :: AuthHandler a TypedContent
getLoginR = do
Maybe Text
mErr <- m (Maybe Text)
forall a. AuthHandler a (Maybe Text)
getError
Maybe Text
mEmail <- m (Maybe Text)
forall a. AuthHandler a (Maybe Text)
getEmail
Maybe (AuthId a)
muid <- m (Maybe (AuthId a))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
maybeAuthId
AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
case Maybe (AuthId a)
muid of
Maybe (AuthId a)
Nothing -> Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Login"
(AuthRoute -> Route a)
-> Maybe Text -> Maybe Text -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a)
-> Maybe Text -> Maybe Text -> WidgetFor a ()
loginTemplate AuthRoute -> Route a
tp Maybe Text
mErr Maybe Text
mEmail
Just AuthId a
_ -> Text -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Text -> m TypedContent) -> Text -> m TypedContent
forall a b. (a -> b) -> a -> b
$ String -> Text
forall s. PathPiece s => s -> Text
toPathPiece (String
"/" :: String)
passwordTokenSessionKey :: Text
passwordTokenSessionKey :: Text
passwordTokenSessionKey = Text
"yas-set-password-token"
registrationTokenSessionKey :: Text
registrationTokenSessionKey :: Text
registrationTokenSessionKey = Text
"yas-registration-token"
genToken :: IO ByteString
genToken :: IO ByteString
genToken = Int -> IO ByteString
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
24
hashAndEncodeToken :: ByteString -> Text
hashAndEncodeToken :: ByteString -> Text
hashAndEncodeToken ByteString
bs = ByteString -> Text
forall textual binary. Utf8 textual binary => binary -> textual
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
B64.encode
(ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (ByteString -> Digest SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
C.hash ByteString
bs :: Digest SHA256)
encodeToken :: ByteString -> Text
encodeToken :: ByteString -> Text
encodeToken = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
B64Url.encode
decodeToken :: Text -> ByteString
decodeToken :: Text -> ByteString
decodeToken = ByteString -> ByteString
B64Url.decodeLenient (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8
verifyRegisterTokenFromSession :: YesodAuthSimple a
=> AuthHandler a (Maybe Email)
verifyRegisterTokenFromSession :: AuthHandler a (Maybe Email)
verifyRegisterTokenFromSession =
m (Maybe Email)
-> (Text -> m (Maybe Email)) -> Maybe Text -> m (Maybe Email)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Email -> m (Maybe Email)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Email
forall a. Maybe a
Nothing) Text -> m (Maybe Email)
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Text -> m (Maybe Email)
matchRegistrationToken
(Maybe Text -> m (Maybe Email))
-> m (Maybe Text) -> m (Maybe Email)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
registrationTokenSessionKey
verifyPasswordTokenFromSession :: YesodAuthSimple a
=> AuthHandler a (Maybe (AuthSimpleId a))
verifyPasswordTokenFromSession :: AuthHandler a (Maybe (AuthSimpleId a))
verifyPasswordTokenFromSession =
m (Maybe (AuthSimpleId a))
-> (Text -> m (Maybe (AuthSimpleId a)))
-> Maybe Text
-> m (Maybe (AuthSimpleId a))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (AuthSimpleId a) -> m (Maybe (AuthSimpleId a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (AuthSimpleId a)
forall a. Maybe a
Nothing) Text -> m (Maybe (AuthSimpleId a))
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Text -> m (Maybe (AuthSimpleId a))
matchPasswordToken
(Maybe Text -> m (Maybe (AuthSimpleId a)))
-> m (Maybe Text) -> m (Maybe (AuthSimpleId a))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
passwordTokenSessionKey
markRegisterTokenAsUsed :: YesodAuthSimple a => Maybe Email -> AuthHandler a ()
markRegisterTokenAsUsed :: Maybe Email -> AuthHandler a ()
markRegisterTokenAsUsed Maybe Email
mEmail = do
Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
registrationTokenSessionKey
case Maybe Email
mEmail of
Just Email
email -> Email -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> m ()
onRegistrationTokenUsed Email
email
Maybe Email
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
postRegisterR :: YesodAuthSimple a => AuthHandler a TypedContent
postRegisterR :: AuthHandler a TypedContent
postRegisterR = do
m ()
forall a. AuthHandler a ()
clearError
(Maybe Text
honeypot, Text
email) <- FormInput m (Maybe Text, Text) -> m (Maybe Text, Text)
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost (FormInput m (Maybe Text, Text) -> m (Maybe Text, Text))
-> FormInput m (Maybe Text, Text) -> m (Maybe Text, Text)
forall a b. (a -> b) -> a -> b
$ (,)
(Maybe Text -> Text -> (Maybe Text, Text))
-> FormInput m (Maybe Text)
-> FormInput m (Text -> (Maybe Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Field m Text -> Text -> FormInput m (Maybe Text)
forall (m :: * -> *) a.
Monad m =>
Field m a -> Text -> FormInput m (Maybe a)
iopt Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
honeypotName
FormInput m (Text -> (Maybe Text, Text))
-> FormInput m Text -> FormInput m (Maybe Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"email"
Maybe Email
mEmail <- (Text -> Email) -> Maybe Text -> Maybe Email
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Email
Email (Maybe Text -> Maybe Email) -> m (Maybe Text) -> m (Maybe Email)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> AuthHandler a (Maybe Text)
forall a. Text -> AuthHandler a (Maybe Text)
validateAndNormalizeEmail Text
email
case Maybe Email
mEmail of
Maybe Email
_ | Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
honeypot -> do
m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
m ()
onBotPost
let msg :: Text
msg = Text
"An unexpected error occurred.\
\ Please try again or contact support\
\ if the problem persists."
AuthRoute -> Text -> AuthHandler a TypedContent
forall a. AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError AuthRoute
registerR Text
msg
Just Email
email' -> do
Email -> m (Maybe (AuthSimpleId a))
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> m (Maybe (AuthSimpleId a))
getUserId Email
email' m (Maybe (AuthSimpleId a))
-> (Maybe (AuthSimpleId a) -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just AuthSimpleId a
_ -> m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
onEmailAlreadyExist
Maybe (AuthSimpleId a)
Nothing -> do
AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
Route a -> Text
renderUrl <- m (Route a -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
ByteString
rawToken <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
genToken
let url :: Text
url = Route a -> Text
renderUrl (Route a -> Text) -> (Text -> Route a) -> Text -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. AuthRoute -> Route a
tp (AuthRoute -> Route a) -> (Text -> AuthRoute) -> Text -> Route a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> AuthRoute
confirmTokenR (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
encodeToken ByteString
rawToken
hashed :: Text
hashed = ByteString -> Text
hashAndEncodeToken ByteString
rawToken
AuthRoute
route <- AuthRoute -> AuthRoute -> Bool -> AuthRoute
forall a. a -> a -> Bool -> a
bool AuthRoute
confirmationEmailSentR AuthRoute
confirmationEmailResentR
(Bool -> AuthRoute) -> m Bool -> m AuthRoute
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Email -> m Bool
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> m Bool
isConfirmationPending Email
email'
Email -> Text -> Text -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> Text -> Text -> m ()
sendVerifyEmail Email
email' Text
url Text
hashed
Route a -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route a -> m TypedContent) -> Route a -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tp AuthRoute
route
Maybe Email
Nothing -> do
Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
setError Text
"Invalid email address"
AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
Route a -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route a -> m TypedContent) -> Route a -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tp AuthRoute
registerR
postResetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent
postResetPasswordR :: AuthHandler a TypedContent
postResetPasswordR = do
m ()
forall a. AuthHandler a ()
clearError
Route a -> Text
ur <- m (Route a -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
ByteString
token <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
genToken
Text
email <- FormInput m Text -> m Text
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost (FormInput m Text -> m Text) -> FormInput m Text -> m Text
forall a b. (a -> b) -> a -> b
$ Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"email"
AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
let url :: Text
url = Route a -> Text
ur (Route a -> Text) -> (Text -> Route a) -> Text -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. AuthRoute -> Route a
tp (AuthRoute -> Route a) -> (Text -> AuthRoute) -> Text -> Route a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> AuthRoute
setPasswordTokenR (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
encodeToken ByteString
token
hashed :: Text
hashed = ByteString -> Text
hashAndEncodeToken ByteString
token
Email -> Text -> Text -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> Text -> Text -> m ()
sendResetPasswordEmail (Text -> Email
Email Text
email) Text
url Text
hashed
Route a -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route a -> m TypedContent) -> Route a -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tp AuthRoute
resetPasswordEmailSentR
getConfirmTokenR :: Text -> AuthHandler a TypedContent
getConfirmTokenR :: Text -> AuthHandler a TypedContent
getConfirmTokenR Text
token = do
Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
registrationTokenSessionKey (Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Text
hashAndEncodeToken (ByteString -> Text) -> (Text -> ByteString) -> Text -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
decodeToken (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
token
AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
Route a -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route a -> m TypedContent) -> Route a -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tp AuthRoute
confirmR
getConfirmR :: YesodAuthSimple a => AuthHandler a TypedContent
getConfirmR :: AuthHandler a TypedContent
getConfirmR = do
Maybe Email
mEmail <- m (Maybe Email)
forall a. YesodAuthSimple a => AuthHandler a (Maybe Email)
verifyRegisterTokenFromSession
case Maybe Email
mEmail of
Maybe Email
Nothing -> do
Maybe Email -> AuthHandler a ()
forall a. YesodAuthSimple a => Maybe Email -> AuthHandler a ()
markRegisterTokenAsUsed Maybe Email
forall a. Maybe a
Nothing
m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
invalidRegistrationTokenHandler
Just Email
email ->
Email -> m (Maybe (AuthSimpleId a))
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> m (Maybe (AuthSimpleId a))
getUserId Email
email m (Maybe (AuthSimpleId a))
-> (Maybe (AuthSimpleId a) -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m TypedContent
-> (AuthSimpleId a -> m TypedContent)
-> Maybe (AuthSimpleId a)
-> m TypedContent
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Email -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuthSimple (HandlerSite m), MonadUnliftIO m,
SubHandlerSite m ~ Auth) =>
Email -> m TypedContent
doConfirm Email
email) (Email -> AuthSimpleId a -> m TypedContent
forall (m :: * -> *) s.
(YesodAuthSimple (HandlerSite m), MonadHandler m, MonadUnliftIO m,
PathPiece s, SubHandlerSite m ~ Auth) =>
Email -> s -> m TypedContent
redirectToHome Email
email)
where
redirectToHome :: Email -> s -> m TypedContent
redirectToHome Email
email s
uid = do
Maybe Email -> AuthHandler (HandlerSite m) ()
forall a. YesodAuthSimple a => Maybe Email -> AuthHandler a ()
markRegisterTokenAsUsed (Maybe Email -> AuthHandler (HandlerSite m) ())
-> Maybe Email -> AuthHandler (HandlerSite m) ()
forall a b. (a -> b) -> a -> b
$ Email -> Maybe Email
forall a. a -> Maybe a
Just Email
email
Creds (HandlerSite m) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect (Creds (HandlerSite m) -> m TypedContent)
-> Creds (HandlerSite m) -> m TypedContent
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [(Text, Text)] -> Creds (HandlerSite m)
forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"simple" (s -> Text
forall s. PathPiece s => s -> Text
toPathPiece s
uid) []
doConfirm :: Email -> m TypedContent
doConfirm Email
email = do AuthRoute -> Route (HandlerSite m)
tp <- m (AuthRoute -> Route (HandlerSite m))
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
Route (HandlerSite m)
-> Email -> AuthHandler (HandlerSite m) TypedContent
forall a.
YesodAuthSimple a =>
Route a -> Email -> AuthHandler a TypedContent
confirmHandler (AuthRoute -> Route (HandlerSite m)
tp AuthRoute
confirmR) Email
email
invalidPasswordTokenHandler :: YesodAuthSimple a => AuthHandler a TypedContent
invalidPasswordTokenHandler :: AuthHandler a TypedContent
invalidPasswordTokenHandler = do
Html
html <- WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m Html) -> WidgetFor a () -> m Html
forall a b. (a -> b) -> a -> b
$ do
Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Invalid token"
Text -> WidgetFor a ()
forall a. YesodAuthSimple a => Text -> WidgetFor a ()
invalidPasswordTokenTemplate Text
invalidPasswordTokenMessage
let contentType :: [(HeaderName, ByteString)]
contentType = [(HeaderName
"Content-Type", ByteString
"text/html")]
Html -> Builder
renderHtmlBuilder Html
html
Builder -> (Builder -> Response) -> Response
forall a b. a -> (a -> b) -> b
& Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
badRequest400 [(HeaderName, ByteString)]
contentType
Response -> (Response -> m TypedContent) -> m TypedContent
forall a b. a -> (a -> b) -> b
& Response -> m TypedContent
forall (m :: * -> *) b. MonadHandler m => Response -> m b
sendWaiResponse
invalidRegistrationTokenHandler :: YesodAuthSimple a => AuthHandler a TypedContent
invalidRegistrationTokenHandler :: AuthHandler a TypedContent
invalidRegistrationTokenHandler = do
Html
html <- WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m Html) -> WidgetFor a () -> m Html
forall a b. (a -> b) -> a -> b
$ do
Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Invalid token"
Text -> WidgetFor a ()
forall a. YesodAuthSimple a => Text -> WidgetFor a ()
invalidRegistrationTokenTemplate Text
invalidRegistrationMessage
let contentType :: [(HeaderName, ByteString)]
contentType = [(HeaderName
"Content-Type", ByteString
"text/html")]
Html -> Builder
renderHtmlBuilder Html
html
Builder -> (Builder -> Response) -> Response
forall a b. a -> (a -> b) -> b
& Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
badRequest400 [(HeaderName, ByteString)]
contentType
Response -> (Response -> m TypedContent) -> m TypedContent
forall a b. a -> (a -> b) -> b
& Response -> m TypedContent
forall (m :: * -> *) b. MonadHandler m => Response -> m b
sendWaiResponse
confirmHandler ::
YesodAuthSimple a
=> Route a
-> Email
-> AuthHandler a TypedContent
confirmHandler :: Route a -> Email -> AuthHandler a TypedContent
confirmHandler Route a
registerUrl Email
email = do
Maybe Text
mErr <- m (Maybe Text)
forall a. AuthHandler a (Maybe Text)
getError
AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Confirm account"
(AuthRoute -> Route a)
-> Route a -> Email -> Maybe Text -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a)
-> Route a -> Email -> Maybe Text -> WidgetFor a ()
confirmTemplate AuthRoute -> Route a
tp Route a
registerUrl Email
email Maybe Text
mErr
postConfirmR :: YesodAuthSimple a => AuthHandler a TypedContent
postConfirmR :: AuthHandler a TypedContent
postConfirmR = do
m ()
forall a. AuthHandler a ()
clearError
Bool
okCsrf <- Text -> m Bool
forall (m :: * -> *). MonadHandler m => Text -> m Bool
hasValidCsrfParamNamed Text
defaultCsrfParamName
Maybe Email
mEmail <- m (Maybe Email)
forall a. YesodAuthSimple a => AuthHandler a (Maybe Email)
verifyRegisterTokenFromSession
case Maybe Email
mEmail of
Maybe Email
_ | Bool -> Bool
not Bool
okCsrf -> AuthRoute -> Text -> AuthHandler a TypedContent
forall a. AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError AuthRoute
confirmR Text
invalidCsrfMessage
Maybe Email
Nothing -> m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
invalidRegistrationTokenHandler
Just Email
email -> do
Text
password <- FormInput m Text -> m Text
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost (FormInput m Text -> m Text) -> FormInput m Text -> m Text
forall a b. (a -> b) -> a -> b
$ Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"password"
Email -> Pass -> AuthHandler a TypedContent
forall m.
YesodAuthSimple m =>
Email -> Pass -> AuthHandler m TypedContent
createUser Email
email (ByteString -> Pass
Pass (ByteString -> Pass) -> (Text -> ByteString) -> Text -> Pass
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 (Text -> Pass) -> Text -> Pass
forall a b. (a -> b) -> a -> b
$ Text
password)
createUser :: forall m. YesodAuthSimple m
=> Email -> Pass -> AuthHandler m TypedContent
createUser :: Email -> Pass -> AuthHandler m TypedContent
createUser Email
email Pass
password = do
Either Text Strength
check <- IO (Either Text Strength) -> m (Either Text Strength)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text Strength) -> m (Either Text Strength))
-> IO (Either Text Strength) -> m (Either Text Strength)
forall a b. (a -> b) -> a -> b
$ PasswordStrength -> Either Text Strength
strengthToEither
(PasswordStrength -> Either Text Strength)
-> IO PasswordStrength -> IO (Either Text Strength)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PasswordCheck -> Pass -> IO PasswordStrength
checkPasswordStrength (YesodAuthSimple m => PasswordCheck
forall a. YesodAuthSimple a => PasswordCheck
passwordCheck @m) Pass
password
case Either Text Strength
check of
Left Text
msg -> do
Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
setError Text
msg
AuthRoute -> Route m
tp <- m (AuthRoute -> Route m)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
Route m -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route m -> m TypedContent) -> Route m -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route m
tp AuthRoute
confirmR
Right Strength
_ -> do
Maybe Email -> AuthHandler m ()
forall a. YesodAuthSimple a => Maybe Email -> AuthHandler a ()
markRegisterTokenAsUsed (Maybe Email -> AuthHandler m ())
-> Maybe Email -> AuthHandler m ()
forall a b. (a -> b) -> a -> b
$ Email -> Maybe Email
forall a. a -> Maybe a
Just Email
email
EncryptedPass
encrypted <- IO EncryptedPass -> m EncryptedPass
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EncryptedPass -> m EncryptedPass)
-> IO EncryptedPass -> m EncryptedPass
forall a b. (a -> b) -> a -> b
$ Pass -> IO EncryptedPass
encryptPassIO' Pass
password
Email -> EncryptedPass -> m (Maybe (AuthSimpleId m))
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> EncryptedPass -> m (Maybe (AuthSimpleId a))
insertUser Email
email EncryptedPass
encrypted m (Maybe (AuthSimpleId m))
-> (Maybe (AuthSimpleId m) -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just AuthSimpleId m
uid -> do
let creds :: Creds m
creds = Text -> Text -> [(Text, Text)] -> Creds m
forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"simple" (AuthSimpleId m -> Text
forall s. PathPiece s => s -> Text
toPathPiece AuthSimpleId m
uid) []
Bool -> Creds (HandlerSite m) -> m ()
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Bool -> Creds (HandlerSite m) -> m ()
setCreds Bool
False Creds m
Creds (HandlerSite m)
creds
m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
onRegisterSuccess
Maybe (AuthSimpleId m)
Nothing -> do
AuthRoute -> Route m
tp <- m (AuthRoute -> Route m)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
Route m -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route m -> m TypedContent) -> Route m -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route m
tp AuthRoute
userExistsR
getConfirmationEmailSentR :: YesodAuthSimple a => AuthHandler a TypedContent
getConfirmationEmailSentR :: AuthHandler a TypedContent
getConfirmationEmailSentR = Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Confirmation email sent"
WidgetFor a ()
forall a. YesodAuthSimple a => WidgetFor a ()
confirmationEmailSentTemplate
getConfirmationEmailResentR :: YesodAuthSimple a => AuthHandler a TypedContent
getConfirmationEmailResentR :: AuthHandler a TypedContent
getConfirmationEmailResentR = Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Confirmation email resent"
WidgetFor a ()
forall a. YesodAuthSimple a => WidgetFor a ()
confirmationEmailResentTemplate
getResetPasswordEmailSentR :: YesodAuthSimple a => AuthHandler a TypedContent
getResetPasswordEmailSentR :: AuthHandler a TypedContent
getResetPasswordEmailSentR = Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Reset password email sent"
WidgetFor a ()
forall a. YesodAuthSimple a => WidgetFor a ()
resetPasswordEmailSentTemplate
getRegisterSuccessR :: AuthHandler a TypedContent
getRegisterSuccessR :: m TypedContent
getRegisterSuccessR = do
Html -> m ()
forall (m :: * -> *). MonadHandler m => Html -> m ()
setMessage Html
"Account created. Welcome!"
Text -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Text
"/" :: Text)
getUserExistsR :: YesodAuthSimple a => AuthHandler a TypedContent
getUserExistsR :: AuthHandler a TypedContent
getUserExistsR = Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"User already exists"
WidgetFor a ()
forall a. YesodAuthSimple a => WidgetFor a ()
userExistsTemplate
postPasswordStrengthR :: forall a. (YesodAuthSimple a) => AuthHandler a J.Value
postPasswordStrengthR :: AuthHandler a Value
postPasswordStrengthR = do
Bool
okCsrf <- Text -> m Bool
forall (m :: * -> *). MonadHandler m => Text -> m Bool
hasValidCsrfParamNamed Text
defaultCsrfParamName
if Bool -> Bool
not Bool
okCsrf
then Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> m Value)
-> (PasswordStrength -> Value) -> PasswordStrength -> m Value
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PasswordStrength -> Value
forall a. ToJSON a => a -> Value
toJSON (PasswordStrength -> m Value) -> PasswordStrength -> m Value
forall a b. (a -> b) -> a -> b
$ Strength -> Maybe Text -> PasswordStrength
BadPassword Strength
PW.Risky (Maybe Text -> PasswordStrength) -> Maybe Text -> PasswordStrength
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
invalidCsrfMessage
else do
Text
password <- FormInput m Text -> m Text
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost (Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"password")
let pass :: Pass
pass = ByteString -> Pass
Pass (ByteString -> Pass) -> (Text -> ByteString) -> Text -> Pass
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 (Text -> Pass) -> Text -> Pass
forall a b. (a -> b) -> a -> b
$ Text
password
IO Value -> m Value
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Value -> m Value) -> IO Value -> m Value
forall a b. (a -> b) -> a -> b
$ PasswordStrength -> Value
forall a. ToJSON a => a -> Value
toJSON (PasswordStrength -> Value) -> IO PasswordStrength -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PasswordCheck -> Pass -> IO PasswordStrength
checkPasswordStrength (YesodAuthSimple a => PasswordCheck
forall a. YesodAuthSimple a => PasswordCheck
passwordCheck @a) Pass
pass
checkPassWithZxcvbn ::
PW.Strength
-> Vector Text
-> Day
-> Text
-> PasswordStrength
checkPassWithZxcvbn :: Strength -> Vector Text -> Day -> Text -> PasswordStrength
checkPassWithZxcvbn Strength
minStrength' Vector Text
extraWords' Day
day Text
password =
let conf :: Config
conf = Vector Text -> Config -> Config
PW.addCustomFrequencyList Vector Text
extraWords' Config
PW.en_US
guesses :: Score
guesses = Config -> Day -> Text -> Score
PW.score Config
conf Day
day Text
password
stren :: Strength
stren = Score -> Strength
PW.strength Score
guesses
in if Strength
stren Strength -> Strength -> Bool
forall a. Ord a => a -> a -> Bool
>= Strength
minStrength' then Strength -> PasswordStrength
GoodPassword Strength
stren
else Strength -> Maybe Text -> PasswordStrength
BadPassword Strength
stren (Maybe Text -> PasswordStrength) -> Maybe Text -> PasswordStrength
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"The password is not strong enough"
checkPassWithRules :: Int -> Text -> PasswordStrength
checkPassWithRules :: Int -> Text -> PasswordStrength
checkPassWithRules Int
minLen Text
password
| Text -> Int
T.length Text
password Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minLen = Strength -> PasswordStrength
GoodPassword Strength
PW.Safe
| Bool
otherwise = Strength -> Maybe Text -> PasswordStrength
BadPassword Strength
PW.Weak (Maybe Text -> PasswordStrength)
-> (String -> Maybe Text) -> String -> PasswordStrength
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> (String -> Text) -> String -> Maybe Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
T.pack
(String -> PasswordStrength) -> String -> PasswordStrength
forall a b. (a -> b) -> a -> b
$ String
"Password must be at least " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
minLen String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" characters"
strengthToEither :: PasswordStrength -> Either Text PW.Strength
strengthToEither :: PasswordStrength -> Either Text Strength
strengthToEither (GoodPassword Strength
stren) = Strength -> Either Text Strength
forall a b. b -> Either a b
Right Strength
stren
strengthToEither (BadPassword Strength
_ (Just Text
err)) = Text -> Either Text Strength
forall a b. a -> Either a b
Left Text
err
strengthToEither (BadPassword Strength
_ Maybe Text
Nothing) =
Text -> Either Text Strength
forall a b. a -> Either a b
Left Text
"The password is not strong enough"
getPWStrength :: PasswordStrength -> PW.Strength
getPWStrength :: PasswordStrength -> Strength
getPWStrength (GoodPassword Strength
stren) = Strength
stren
getPWStrength (BadPassword Strength
stren Maybe Text
_) = Strength
stren
checkPasswordStrength :: PasswordCheck -> Pass -> IO PasswordStrength
checkPasswordStrength :: PasswordCheck -> Pass -> IO PasswordStrength
checkPasswordStrength PasswordCheck
check Pass
pass =
case ByteString -> Either UnicodeException Text
decodeUtf8' (Pass -> ByteString
getPass Pass
pass) of
Left UnicodeException
_ -> PasswordStrength -> IO PasswordStrength
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PasswordStrength -> IO PasswordStrength)
-> PasswordStrength -> IO PasswordStrength
forall a b. (a -> b) -> a -> b
$ Strength -> Maybe Text -> PasswordStrength
BadPassword Strength
PW.Weak (Maybe Text -> PasswordStrength) -> Maybe Text -> PasswordStrength
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Invalid characters in password"
Right Text
password ->
if Bool -> Bool
not Bool
satisfiesMaxLen
then PasswordStrength -> IO PasswordStrength
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PasswordStrength -> IO PasswordStrength)
-> (Text -> PasswordStrength) -> Text -> IO PasswordStrength
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Strength -> Maybe Text -> PasswordStrength
BadPassword Strength
PW.Weak (Maybe Text -> PasswordStrength)
-> (Text -> Maybe Text) -> Text -> PasswordStrength
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Maybe Text
forall a. a -> Maybe a
Just
(Text -> IO PasswordStrength) -> Text -> IO PasswordStrength
forall a b. (a -> b) -> a -> b
$ Text
"Password exceeds maximum length of "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
maxPasswordLength)
else case PasswordCheck
check of
RuleBased Int
minLen ->
PasswordStrength -> IO PasswordStrength
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PasswordStrength -> IO PasswordStrength)
-> PasswordStrength -> IO PasswordStrength
forall a b. (a -> b) -> a -> b
$ Int -> Text -> PasswordStrength
checkPassWithRules (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
minLen Int
minPasswordLength) Text
password
Zxcvbn Strength
minStren Vector Text
extraWords' -> do
Day
today <- UTCTime -> Day
utctDay (UTCTime -> Day) -> IO UTCTime -> IO Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
let pwstren :: PasswordStrength
pwstren = Strength -> Vector Text -> Day -> Text -> PasswordStrength
checkPassWithZxcvbn Strength
minStren Vector Text
extraWords' Day
today Text
password
PasswordStrength -> IO PasswordStrength
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PasswordStrength -> IO PasswordStrength)
-> PasswordStrength -> IO PasswordStrength
forall a b. (a -> b) -> a -> b
$
if Bool
satisfiesMinLen
then PasswordStrength
pwstren
else Strength -> Maybe Text -> PasswordStrength
BadPassword (Strength -> Strength -> Strength
forall a. Ord a => a -> a -> a
min (PasswordStrength -> Strength
getPWStrength PasswordStrength
pwstren) (Strength -> Strength
forall a. Enum a => a -> a
pred Strength
minStren))
(Maybe Text -> PasswordStrength)
-> (Text -> Maybe Text) -> Text -> PasswordStrength
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> PasswordStrength) -> Text -> PasswordStrength
forall a b. (a -> b) -> a -> b
$ Text
"The password must be at least "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
minPasswordLength) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" characters"
where (Text
boundedPw, Text
extra) = Int -> Text -> (Text, Text)
T.splitAt Int
maxPasswordLength Text
password
satisfiesMinLen :: Bool
satisfiesMinLen = Text -> Int
T.length Text
boundedPw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minPasswordLength
satisfiesMaxLen :: Bool
satisfiesMaxLen = Text -> Bool
T.null Text
extra
normalizeEmail :: Text -> Text
normalizeEmail :: Text -> Text
normalizeEmail = Text -> Text
T.toLower
validateAndNormalizeEmail :: Text -> AuthHandler a (Maybe Text)
validateAndNormalizeEmail :: Text -> AuthHandler a (Maybe Text)
validateAndNormalizeEmail Text
email = case ByteString -> Maybe ByteString
canonicalizeEmail (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 Text
email of
Just ByteString
bytes ->
Maybe Text -> m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> m (Maybe Text)) -> Maybe Text -> m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
normalizeEmail (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
bytes
Maybe ByteString
Nothing -> Maybe Text -> m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
errorSessionName :: Text
errorSessionName :: Text
errorSessionName = Text
"yesod-auth-simple-error"
emailSessionName :: Text
emailSessionName :: Text
emailSessionName = Text
"yesod-auth-simple-email"
getError :: AuthHandler a (Maybe Text)
getError :: m (Maybe Text)
getError = do
Maybe Text
mErr <- Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
errorSessionName
m ()
forall a. AuthHandler a ()
clearError
Maybe Text -> m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
mErr
setError :: MonadHandler m => Text -> m ()
setError :: Text -> m ()
setError = Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
errorSessionName
clearError :: AuthHandler a ()
clearError :: m ()
clearError = Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
errorSessionName
getEmail :: AuthHandler a (Maybe Text)
getEmail :: m (Maybe Text)
getEmail = do
Maybe Text
mEmail <- Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
emailSessionName
m ()
forall a. AuthHandler a ()
clearEmail
Maybe Text -> m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
mEmail
setEmail :: MonadHandler m => Text -> m ()
setEmail :: Text -> m ()
setEmail = Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
emailSessionName
clearEmail :: AuthHandler a ()
clearEmail :: m ()
clearEmail = Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
emailSessionName
postLoginR :: YesodAuthSimple a => AuthHandler a TypedContent
postLoginR :: AuthHandler a TypedContent
postLoginR = do
m ()
forall a. AuthHandler a ()
clearError
m ()
forall a. AuthHandler a ()
clearEmail
Bool
okCsrf <- Text -> m Bool
forall (m :: * -> *). MonadHandler m => Text -> m Bool
hasValidCsrfParamNamed Text
defaultCsrfParamName
if Bool -> Bool
not Bool
okCsrf
then AuthRoute -> Text -> AuthHandler a TypedContent
forall a. AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError AuthRoute
loginR Text
invalidCsrfMessage
else do
(Text
email, Text
password') <- FormInput m (Text, Text) -> m (Text, Text)
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost (FormInput m (Text, Text) -> m (Text, Text))
-> FormInput m (Text, Text) -> m (Text, Text)
forall a b. (a -> b) -> a -> b
$ (,)
(Text -> Text -> (Text, Text))
-> FormInput m Text -> FormInput m (Text -> (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"email"
FormInput m (Text -> (Text, Text))
-> FormInput m Text -> FormInput m (Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"password"
Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
setEmail Text
email
let password :: Pass
password = ByteString -> Pass
Pass (ByteString -> Pass) -> (Text -> ByteString) -> Text -> Pass
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 (Text -> Pass) -> Text -> Pass
forall a b. (a -> b) -> a -> b
$ Text
password'
Maybe (AuthSimpleId a)
mUid <- Email -> m (Maybe (AuthSimpleId a))
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> m (Maybe (AuthSimpleId a))
getUserId (Text -> Email
Email Text
email)
Maybe UTCTime
mLockedOut <- Maybe (AuthSimpleId a) -> m (Maybe UTCTime)
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Maybe (AuthSimpleId a) -> m (Maybe UTCTime)
shouldPreventLoginAttempt Maybe (AuthSimpleId a)
mUid
case (Maybe UTCTime
mLockedOut, Maybe (AuthSimpleId a)
mUid) of
(Just UTCTime
expires, Maybe (AuthSimpleId a)
_) -> UTCTime -> AuthHandler a TypedContent
forall a.
YesodAuthSimple a =>
UTCTime -> AuthHandler a TypedContent
tooManyLoginAttemptsHandler UTCTime
expires
(Maybe UTCTime
_, Just AuthSimpleId a
uid) -> do
EncryptedPass
storedPassword <- AuthSimpleId a -> m EncryptedPass
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
AuthSimpleId a -> m EncryptedPass
getUserPassword AuthSimpleId a
uid
if Pass -> EncryptedPass -> Bool
verifyPass' Pass
password EncryptedPass
storedPassword
then do
Maybe (AuthSimpleId a) -> Bool -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Maybe (AuthSimpleId a) -> Bool -> m ()
onLoginAttempt (AuthSimpleId a -> Maybe (AuthSimpleId a)
forall a. a -> Maybe a
Just AuthSimpleId a
uid) Bool
True
Creds (HandlerSite m) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect (Creds (HandlerSite m) -> m TypedContent)
-> Creds (HandlerSite m) -> m TypedContent
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [(Text, Text)] -> Creds a
forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"simple" (AuthSimpleId a -> Text
forall s. PathPiece s => s -> Text
toPathPiece AuthSimpleId a
uid) []
else do
Maybe (AuthSimpleId a) -> Bool -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Maybe (AuthSimpleId a) -> Bool -> m ()
onLoginAttempt (AuthSimpleId a -> Maybe (AuthSimpleId a)
forall a. a -> Maybe a
Just AuthSimpleId a
uid) Bool
False
m TypedContent
forall a. AuthHandler a TypedContent
wrongEmailOrPasswordRedirect
(Maybe UTCTime, Maybe (AuthSimpleId a))
_ -> do
Maybe (AuthSimpleId a) -> Bool -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Maybe (AuthSimpleId a) -> Bool -> m ()
onLoginAttempt Maybe (AuthSimpleId a)
forall a. Maybe a
Nothing Bool
False
m TypedContent
forall a. AuthHandler a TypedContent
wrongEmailOrPasswordRedirect
tooManyLoginAttemptsHandler ::
YesodAuthSimple a
=> UTCTime
-> AuthHandler a TypedContent
tooManyLoginAttemptsHandler :: UTCTime -> AuthHandler a TypedContent
tooManyLoginAttemptsHandler UTCTime
expires = do
Html
html <- WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m Html) -> WidgetFor a () -> m Html
forall a b. (a -> b) -> a -> b
$ do
Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Too many login attempts"
UTCTime -> WidgetFor a ()
forall a. YesodAuthSimple a => UTCTime -> WidgetFor a ()
tooManyLoginAttemptsTemplate UTCTime
expires
let contentType :: [(HeaderName, ByteString)]
contentType = [(HeaderName
"Content-Type", ByteString
"text/html")]
Html -> Builder
renderHtmlBuilder Html
html
Builder -> (Builder -> Response) -> Response
forall a b. a -> (a -> b) -> b
& Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
tooManyRequests429 [(HeaderName, ByteString)]
contentType
Response -> (Response -> m TypedContent) -> m TypedContent
forall a b. a -> (a -> b) -> b
& Response -> m TypedContent
forall (m :: * -> *) b. MonadHandler m => Response -> m b
sendWaiResponse
redirectTo :: AuthRoute -> AuthHandler a b
redirectTo :: AuthRoute -> AuthHandler a b
redirectTo AuthRoute
route = do
AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
Route a -> m b
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route a -> m b) -> Route a -> m b
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tp AuthRoute
route
redirectWithError :: AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError :: AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError AuthRoute
route Text
err = do
Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
setError Text
err
AuthRoute -> AuthHandler a TypedContent
forall a b. AuthRoute -> AuthHandler a b
redirectTo AuthRoute
route
wrongEmailOrPasswordRedirect :: AuthHandler a TypedContent
wrongEmailOrPasswordRedirect :: m TypedContent
wrongEmailOrPasswordRedirect =
AuthRoute -> Text -> AuthHandler a TypedContent
forall a. AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError AuthRoute
loginR Text
"Wrong email or password"
invalidCsrfMessage :: Text
invalidCsrfMessage :: Text
invalidCsrfMessage =
Text
"Invalid anti-forgery token. \
\Please try again in a new browser tab or window. \
\Contact support if the problem persists."
invalidRegistrationMessage :: Text
invalidRegistrationMessage :: Text
invalidRegistrationMessage =
Text
"Invalid registration link. \
\Please try registering again and contact support if the problem persists"
invalidPasswordTokenMessage :: Text
invalidPasswordTokenMessage :: Text
invalidPasswordTokenMessage =
Text
"Invalid password reset token. \
\Please try again and contact support if the problem persists."
getSetPasswordTokenR :: Text -> AuthHandler a TypedContent
getSetPasswordTokenR :: Text -> AuthHandler a TypedContent
getSetPasswordTokenR Text
token = do
Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
passwordTokenSessionKey (Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Text
hashAndEncodeToken (ByteString -> Text) -> (Text -> ByteString) -> Text -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
decodeToken (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
token
AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
Route a -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route a -> m TypedContent) -> Route a -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tp AuthRoute
setPasswordR
getSetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent
getSetPasswordR :: AuthHandler a TypedContent
getSetPasswordR = do
Maybe (AuthSimpleId a)
mUid <- m (Maybe (AuthSimpleId a))
forall a.
YesodAuthSimple a =>
AuthHandler a (Maybe (AuthSimpleId a))
verifyPasswordTokenFromSession
case Maybe (AuthSimpleId a)
mUid of
Maybe (AuthSimpleId a)
Nothing -> m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
invalidPasswordTokenHandler
Just AuthSimpleId a
_ -> do
AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
Maybe Text
mErr <- m (Maybe Text)
forall a. AuthHandler a (Maybe Text)
getError
Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Set password"
(AuthRoute -> Route a) -> Route a -> Maybe Text -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a) -> Route a -> Maybe Text -> WidgetFor a ()
setPasswordTemplate AuthRoute -> Route a
tp (AuthRoute -> Route a
tp AuthRoute
setPasswordR) Maybe Text
mErr
postSetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent
postSetPasswordR :: AuthHandler a TypedContent
postSetPasswordR = do
m ()
forall a. AuthHandler a ()
clearError
Bool
okCsrf <- Text -> m Bool
forall (m :: * -> *). MonadHandler m => Text -> m Bool
hasValidCsrfParamNamed Text
defaultCsrfParamName
Maybe (AuthSimpleId a)
mUid <- m (Maybe (AuthSimpleId a))
forall a.
YesodAuthSimple a =>
AuthHandler a (Maybe (AuthSimpleId a))
verifyPasswordTokenFromSession
case Maybe (AuthSimpleId a)
mUid of
Maybe (AuthSimpleId a)
_ | Bool -> Bool
not Bool
okCsrf -> AuthRoute -> Text -> AuthHandler a TypedContent
forall a. AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError AuthRoute
setPasswordR Text
invalidCsrfMessage
Maybe (AuthSimpleId a)
Nothing -> do
Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
passwordTokenSessionKey
m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
invalidPasswordTokenHandler
Just AuthSimpleId a
uid -> do
Text
password <- FormInput m Text -> m Text
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost (FormInput m Text -> m Text) -> FormInput m Text -> m Text
forall a b. (a -> b) -> a -> b
$ Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"password"
AuthSimpleId a -> Pass -> AuthHandler a TypedContent
forall a.
YesodAuthSimple a =>
AuthSimpleId a -> Pass -> AuthHandler a TypedContent
setPass AuthSimpleId a
uid (ByteString -> Pass
Pass (ByteString -> Pass) -> (Text -> ByteString) -> Text -> Pass
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 (Text -> Pass) -> Text -> Pass
forall a b. (a -> b) -> a -> b
$ Text
password)
setPass :: forall a. YesodAuthSimple a
=> AuthSimpleId a
-> Pass
-> AuthHandler a TypedContent
setPass :: AuthSimpleId a -> Pass -> AuthHandler a TypedContent
setPass AuthSimpleId a
uid Pass
password = do
Either Text Strength
check <- IO (Either Text Strength) -> m (Either Text Strength)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text Strength) -> m (Either Text Strength))
-> IO (Either Text Strength) -> m (Either Text Strength)
forall a b. (a -> b) -> a -> b
$ PasswordStrength -> Either Text Strength
strengthToEither
(PasswordStrength -> Either Text Strength)
-> IO PasswordStrength -> IO (Either Text Strength)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PasswordCheck -> Pass -> IO PasswordStrength
checkPasswordStrength (YesodAuthSimple a => PasswordCheck
forall a. YesodAuthSimple a => PasswordCheck
passwordCheck @a) Pass
password
case Either Text Strength
check of
Left Text
msg -> do
Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
setError Text
msg
AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
Route a -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route a -> m TypedContent) -> Route a -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tp AuthRoute
setPasswordR
Right Strength
_ -> do
EncryptedPass
encrypted <- IO EncryptedPass -> m EncryptedPass
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EncryptedPass -> m EncryptedPass)
-> IO EncryptedPass -> m EncryptedPass
forall a b. (a -> b) -> a -> b
$ Pass -> IO EncryptedPass
encryptPassIO' Pass
password
()
_ <- AuthSimpleId a -> EncryptedPass -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
AuthSimpleId a -> EncryptedPass -> m ()
updateUserPassword AuthSimpleId a
uid EncryptedPass
encrypted
AuthSimpleId a -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
AuthSimpleId a -> m ()
onPasswordUpdated AuthSimpleId a
uid
Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
passwordTokenSessionKey
Creds (HandlerSite m) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect (Creds (HandlerSite m) -> m TypedContent)
-> Creds (HandlerSite m) -> m TypedContent
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [(Text, Text)] -> Creds a
forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"simple" (AuthSimpleId a -> Text
forall s. PathPiece s => s -> Text
toPathPiece AuthSimpleId a
uid) []
redirectTemplate :: Route a -> WidgetFor a ()
redirectTemplate :: Route a -> WidgetFor a ()
redirectTemplate Route a
destUrl = do
WidgetFor a () -> WidgetFor a ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget $(whamletFile "templates/redirect.hamlet")
JavascriptUrl (Route a) -> WidgetFor a ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [julius|window.location = "@{destUrl}";|]
csrfTokenTemplate :: WidgetFor a ()
csrfTokenTemplate :: WidgetFor a ()
csrfTokenTemplate = do
YesodRequest
request <- WidgetFor a YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
$(whamletFile "templates/csrf-token.hamlet")
loginTemplateDef ::
(AuthRoute -> Route a)
-> Maybe Text
-> Maybe Text
-> WidgetFor a ()
loginTemplateDef :: (AuthRoute -> Route a)
-> Maybe Text -> Maybe Text -> WidgetFor a ()
loginTemplateDef AuthRoute -> Route a
toParent Maybe Text
mErr Maybe Text
mEmail = $(whamletFile "templates/login.hamlet")
passwordFieldTemplateBasic :: WidgetFor a ()
passwordFieldTemplateBasic :: WidgetFor a ()
passwordFieldTemplateBasic =
$(whamletFile "templates/password-field-basic.hamlet")
zxcvbnJsUrl :: Text
zxcvbnJsUrl :: Text
zxcvbnJsUrl = Text
"https://cdn.jsdelivr.net/npm/zxcvbn@4.4.2/dist/zxcvbn.js"
passwordFieldTemplateZxcvbn ::
(AuthRoute -> Route a)
-> PW.Strength
-> Vector Text
-> WidgetFor a ()
passwordFieldTemplateZxcvbn :: (AuthRoute -> Route a) -> Strength -> Vector Text -> WidgetFor a ()
passwordFieldTemplateZxcvbn AuthRoute -> Route a
toParent Strength
minStren Vector Text
extraWords' = do
let extraWordsStr :: Text
extraWordsStr = Texts -> Text
T.unwords (Texts -> Text) -> (Vector Text -> Texts) -> Vector Text -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Vector Text -> Texts
forall mono. MonoFoldable mono => mono -> [Element mono]
toList (Vector Text -> Text) -> Vector Text -> Text
forall a b. (a -> b) -> a -> b
$ Vector Text
extraWords'
blankPasswordScore :: PasswordStrength
blankPasswordScore = Strength -> Maybe Text -> PasswordStrength
BadPassword Strength
PW.Risky Maybe Text
forall a. Maybe a
Nothing
Maybe Text
mCsrfToken <- YesodRequest -> Maybe Text
reqToken (YesodRequest -> Maybe Text)
-> WidgetFor a YesodRequest -> WidgetFor a (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WidgetFor a YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
Text -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Text -> m ()
addScriptRemote Text
zxcvbnJsUrl
(RY a -> Html) -> WidgetFor a ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget $(hamletFile "templates/password-field-zxcvbn.hamlet")
(RY a -> Css) -> WidgetFor a ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget $(luciusFile "templates/password-field-zxcvbn.lucius")
JavascriptUrl (Route a) -> WidgetFor a ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget $(juliusFile "templates/password-field-zxcvbn.julius")
setPasswordTemplateDef ::
forall a. YesodAuthSimple a
=> (AuthRoute -> Route a)
-> Route a
-> Maybe Text
-> WidgetFor a ()
setPasswordTemplateDef :: (AuthRoute -> Route a) -> Route a -> Maybe Text -> WidgetFor a ()
setPasswordTemplateDef AuthRoute -> Route a
toParent Route a
url Maybe Text
mErr =
let pwField :: WidgetFor a ()
pwField = (AuthRoute -> Route a) -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a) -> WidgetFor a ()
passwordFieldTemplate @a AuthRoute -> Route a
toParent
in $(whamletFile "templates/set-password.hamlet")
invalidTokenTemplateDef :: Text -> WidgetFor a ()
invalidTokenTemplateDef :: Text -> WidgetFor a ()
invalidTokenTemplateDef Text
msg = $(whamletFile "templates/invalid-token.hamlet")
tooManyLoginAttemptsTemplateDef :: UTCTime -> WidgetFor a ()
tooManyLoginAttemptsTemplateDef :: UTCTime -> WidgetFor a ()
tooManyLoginAttemptsTemplateDef UTCTime
expires =
let formatted :: String
formatted = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%d/%m/%_Y %T" UTCTime
expires
in $(whamletFile "templates/too-many-login-attempts.hamlet")
userExistsTemplateDef :: WidgetFor a ()
userExistsTemplateDef :: WidgetFor a ()
userExistsTemplateDef = $(whamletFile "templates/user-exists.hamlet")
registerSuccessTemplateDef :: WidgetFor a ()
registerSuccessTemplateDef :: WidgetFor a ()
registerSuccessTemplateDef = $(whamletFile "templates/register-success.hamlet")
resetPasswordEmailSentTemplateDef :: WidgetFor a ()
resetPasswordEmailSentTemplateDef :: WidgetFor a ()
resetPasswordEmailSentTemplateDef =
$(whamletFile "templates/reset-password-email-sent.hamlet")
confirmationEmailSentTemplateDef :: WidgetFor a ()
confirmationEmailSentTemplateDef :: WidgetFor a ()
confirmationEmailSentTemplateDef =
$(whamletFile "templates/confirmation-email-sent.hamlet")
confirmTemplateDef ::
forall a. YesodAuthSimple a
=> (AuthRoute -> Route a)
-> Route a
-> Email
-> Maybe Text
-> WidgetFor a ()
confirmTemplateDef :: (AuthRoute -> Route a)
-> Route a -> Email -> Maybe Text -> WidgetFor a ()
confirmTemplateDef AuthRoute -> Route a
toParent Route a
confirmUrl (Email Text
email) Maybe Text
mErr =
let pwField :: WidgetFor a ()
pwField = (AuthRoute -> Route a) -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a) -> WidgetFor a ()
passwordFieldTemplate @a AuthRoute -> Route a
toParent
in $(whamletFile "templates/confirm.hamlet")
resetPasswordTemplateDef ::
(AuthRoute -> Route a)
-> Maybe Text
-> WidgetFor a ()
resetPasswordTemplateDef :: (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
resetPasswordTemplateDef AuthRoute -> Route a
toParent Maybe Text
mErr =
$(whamletFile "templates/reset-password.hamlet")
honeypotName :: Text
honeypotName :: Text
honeypotName = Text
"yas-password-backup"
honeypotFieldTemplate :: WidgetFor a ()
honeypotFieldTemplate :: WidgetFor a ()
honeypotFieldTemplate = do
(RY a -> Css) -> WidgetFor a ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [lucius| .#{honeypotName} { display:none !important; } |]
(RY a -> Html) -> WidgetFor a ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget $(hamletFile "templates/honeypot-field.hamlet")
registerTemplateDef :: (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
registerTemplateDef :: (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
registerTemplateDef AuthRoute -> Route a
toParent Maybe Text
mErr = $(whamletFile "templates/register.hamlet")