{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE OverloadedStrings       #-}
{-# LANGUAGE PatternGuards           #-}
{-# LANGUAGE QuasiQuotes             #-}
{-# LANGUAGE Rank2Types              #-}
{-# LANGUAGE ScopedTypeVariables     #-}
{-# LANGUAGE TypeFamilies            #-}
-- | A Yesod plugin for Authentication via e-mail
--
-- This plugin works out of the box by only setting a few methods on
-- the type class that tell the plugin how to interoperate with your
-- user data storage (your database).  However, almost everything is
-- customizeable by setting more methods on the type class.  In
-- addition, you can send all the form submissions via JSON and
-- completely control the user's flow.
--
-- This is a standard registration e-mail flow
--
-- 1. A user registers a new e-mail address, and an e-mail is sent there
-- 2. The user clicks on the registration link in the e-mail. Note that
--   at this point they are actually logged in (without a
--   password). That means that when they log out they will need to
--  reset their password.
-- 3. The user sets their password and is redirected to the site.
-- 4. The user can now
--
--     * logout and sign in
--     * reset their password
--
-- = Using JSON Endpoints
--
-- We are assuming that you have declared auth route as follows
--
-- @
--    /auth AuthR Auth getAuth
-- @
--
-- If you are using a different route, then you have to adjust the
-- endpoints accordingly.
--
--     * Registration
--
-- @
--       Endpoint: \/auth\/page\/email\/register
--       Method: POST
--       JSON Data: {
--                      "email": "myemail@domain.com",
--                      "password": "myStrongPassword" (optional)
--                  }
-- @
--
--     * Forgot password
--
-- @
--       Endpoint: \/auth\/page\/email\/forgot-password
--       Method: POST
--       JSON Data: { "email": "myemail@domain.com" }
-- @
--
--     * Login
--
-- @
--       Endpoint: \/auth\/page\/email\/login
--       Method: POST
--       JSON Data: {
--                      "email": "myemail@domain.com",
--                      "password": "myStrongPassword"
--                  }
-- @
--
--     * Set new password
--
-- @
--       Endpoint: \/auth\/page\/email\/set-password
--       Method: POST
--       JSON Data: {
--                       "new": "newPassword",
--                       "confirm": "newPassword",
--                       "current": "currentPassword"
--                  }
-- @
--
--  Note that in the set password endpoint, the presence of the key
--  "current" is dependent on how the 'needOldPassword' is defined in
--  the instance for 'YesodAuthEmail'.

module Yesod.Auth.Email
    ( -- * Plugin
      authEmail
    , YesodAuthEmail (..)
    , EmailCreds (..)
    , saltPass
      -- * Routes
    , loginR
    , registerR
    , forgotPasswordR
    , setpassR
    , verifyR
    , isValidPass
      -- * Types
    , Email
    , VerKey
    , VerUrl
    , SaltedPass
    , VerStatus
    , Identifier
     -- * Misc
    , loginLinkKey
    , setLoginLinkKey
     -- * Default handlers
    , defaultEmailLoginHandler
    , defaultRegisterHandler
    , defaultForgotPasswordHandler
    , defaultSetPasswordHandler
     -- * Default helpers
    , defaultRegisterHelper
    ) where

import           Control.Applicative           ((<$>), (<*>))
import qualified Crypto.Hash                   as H
import qualified Crypto.Nonce                  as Nonce
import           Data.Aeson.Types              (Parser, Result (..), parseMaybe,
                                                withObject, (.:?))
import           Data.ByteArray                (convert)
import           Data.ByteString.Base16        as B16
import           Data.Maybe                    (isJust)
import           Data.Text                     (Text)
import qualified Data.Text                     as T
import qualified Data.Text                     as TS
import           Data.Text.Encoding            (decodeUtf8With, encodeUtf8)
import qualified Data.Text.Encoding            as TE
import           Data.Text.Encoding.Error      (lenientDecode)
import           Data.Time                     (addUTCTime, getCurrentTime)
import           Safe                          (readMay)
import           System.IO.Unsafe              (unsafePerformIO)
import qualified Text.Email.Validate
import           Yesod.Auth
import qualified Yesod.Auth.Message            as Msg
import qualified Yesod.Auth.Util.PasswordStore as PS
import           Yesod.Core
import           Yesod.Core.Types              (TypedContent (TypedContent))
import           Yesod.Form

loginR, registerR, forgotPasswordR, setpassR :: AuthRoute
loginR :: AuthRoute
loginR = Text -> Texts -> AuthRoute
PluginR Text
"email" [Text
"login"]
registerR :: AuthRoute
registerR = Text -> Texts -> AuthRoute
PluginR Text
"email" [Text
"register"]
forgotPasswordR :: AuthRoute
forgotPasswordR = Text -> Texts -> AuthRoute
PluginR Text
"email" [Text
"forgot-password"]
setpassR :: AuthRoute
setpassR = Text -> Texts -> AuthRoute
PluginR Text
"email" [Text
"set-password"]

verifyURLHasSetPassText :: Text
verifyURLHasSetPassText :: Text
verifyURLHasSetPassText = Text
"has-set-pass"

-- |
--
-- @since 1.4.5
verifyR :: Text -> Text -> Bool -> AuthRoute -- FIXME
verifyR :: Text -> Text -> Bool -> AuthRoute
verifyR Text
eid Text
verkey Bool
hasSetPass = Text -> Texts -> AuthRoute
PluginR Text
"email" Texts
path
    where path :: Texts
path = Text
"verify"Text -> Texts -> Texts
forall a. a -> [a] -> [a]
:Text
eidText -> Texts -> Texts
forall a. a -> [a] -> [a]
:Text
verkeyText -> Texts -> Texts
forall a. a -> [a] -> [a]
:(if Bool
hasSetPass then [Text
verifyURLHasSetPassText] else [])

type Email = Text
type VerKey = Text
type VerUrl = Text
type SaltedPass = Text
type VerStatus = Bool

-- | An Identifier generalizes an email address to allow users to log in with
-- some other form of credentials (e.g., username).
--
-- Note that any of these other identifiers must not be valid email addresses.
--
-- @since 1.2.0
type Identifier = Text

-- | Data stored in a database for each e-mail address.
data EmailCreds site = EmailCreds
    { EmailCreds site -> AuthEmailId site
emailCredsId     :: AuthEmailId site
    , EmailCreds site -> Maybe (AuthId site)
emailCredsAuthId :: Maybe (AuthId site)
    , EmailCreds site -> Bool
emailCredsStatus :: VerStatus
    , EmailCreds site -> Maybe Text
emailCredsVerkey :: Maybe VerKey
    , EmailCreds site -> Text
emailCredsEmail  :: Email
    }

data ForgotPasswordForm = ForgotPasswordForm { ForgotPasswordForm -> Text
_forgotEmail :: Text }
data PasswordForm = PasswordForm { PasswordForm -> Text
_passwordCurrent :: Text, PasswordForm -> Text
_passwordNew :: Text, PasswordForm -> Text
_passwordConfirm :: Text }
data UserForm = UserForm { UserForm -> Text
_userFormEmail :: Text }
data UserLoginForm = UserLoginForm { UserLoginForm -> Text
_loginEmail :: Text, UserLoginForm -> Text
_loginPassword :: Text }

class ( YesodAuth site
      , PathPiece (AuthEmailId site)
      , (RenderMessage site Msg.AuthMessage)
      )
  => YesodAuthEmail site where
    type AuthEmailId site

    -- | Add a new email address to the database, but indicate that the address
    -- has not yet been verified.
    --
    -- @since 1.1.0
    addUnverified :: Email -> VerKey -> AuthHandler site (AuthEmailId site)

    -- | Similar to `addUnverified`, but comes with the registered password.
    --
    -- The default implementation is just `addUnverified`, which ignores the password.
    --
    -- You may override this to save the salted password to your database.
    --
    -- @since 1.6.4
    addUnverifiedWithPass :: Email -> VerKey -> SaltedPass -> AuthHandler site (AuthEmailId site)
    addUnverifiedWithPass Text
email Text
verkey Text
_ = Text -> Text -> AuthHandler site (AuthEmailId site)
forall site.
YesodAuthEmail site =>
Text -> Text -> AuthHandler site (AuthEmailId site)
addUnverified Text
email Text
verkey

    -- | Send an email to the given address to verify ownership.
    --
    -- @since 1.1.0
    sendVerifyEmail :: Email -> VerKey -> VerUrl -> AuthHandler site ()

    -- | Send an email to the given address to re-verify ownership in the case of
    -- a password reset. This can be used to send a different email when a user
    -- goes through the 'forgot password' flow as opposed to the 'account registration'
    -- flow.
    --
    -- Default: Will call 'sendVerifyEmail', resulting in the same email getting sent
    -- for both registrations and password resets.
    --
    -- @since 1.6.10
    sendForgotPasswordEmail :: Email -> VerKey -> VerUrl -> AuthHandler site ()
    sendForgotPasswordEmail = Text -> Text -> Text -> m ()
forall site.
YesodAuthEmail site =>
Text -> Text -> Text -> AuthHandler site ()
sendVerifyEmail

    -- | Get the verification key for the given email ID.
    --
    -- @since 1.1.0
    getVerifyKey :: AuthEmailId site -> AuthHandler site (Maybe VerKey)

    -- | Set the verification key for the given email ID.
    --
    -- @since 1.1.0
    setVerifyKey :: AuthEmailId site -> VerKey -> AuthHandler site ()

    -- | Hash and salt a password
    --
    -- Default: 'saltPass'.
    --
    -- @since 1.4.20
    hashAndSaltPassword :: Text -> AuthHandler site SaltedPass
    hashAndSaltPassword Text
password = IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ Text -> IO Text
saltPass Text
password

    -- | Verify a password matches the stored password for the given account.
    --
    -- Default: Fetch a password with 'getPassword' and match using 'Yesod.Auth.Util.PasswordStore.verifyPassword'.
    --
    -- @since 1.4.20
    verifyPassword :: Text -> SaltedPass -> AuthHandler site Bool
    verifyPassword Text
plain Text
salted = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Bool
isValidPass Text
plain Text
salted

    -- | Verify the email address on the given account.
    --
    -- __/Warning!/__ If you have persisted the @'AuthEmailId' site@
    -- somewhere, this method should delete that key, or make it unusable
    -- in some fashion. Otherwise, the same key can be used multiple times!
    --
    -- See <https://github.com/yesodweb/yesod/issues/1222>.
    --
    -- @since 1.1.0
    verifyAccount :: AuthEmailId site -> AuthHandler site (Maybe (AuthId site))

    -- | Get the salted password for the given account.
    --
    -- @since 1.1.0
    getPassword :: AuthId site -> AuthHandler site (Maybe SaltedPass)

    -- | Set the salted password for the given account.
    --
    -- @since 1.1.0
    setPassword :: AuthId site -> SaltedPass -> AuthHandler site ()

    -- | Get the credentials for the given @Identifier@, which may be either an
    -- email address or some other identification (e.g., username).
    --
    -- @since 1.2.0
    getEmailCreds :: Identifier -> AuthHandler site (Maybe (EmailCreds site))

    -- | Get the email address for the given email ID.
    --
    -- @since 1.1.0
    getEmail :: AuthEmailId site -> AuthHandler site (Maybe Email)

    -- | Generate a random alphanumeric string.
    --
    -- @since 1.1.0
    randomKey :: site -> IO VerKey
    randomKey site
_ = Generator -> IO Text
forall (m :: * -> *). MonadIO m => Generator -> m Text
Nonce.nonce128urlT Generator
defaultNonceGen

    -- | Route to send user to after password has been set correctly.
    --
    -- @since 1.2.0
    afterPasswordRoute :: site -> Route site

    -- | Route to send user to after verification with a password
    --
    -- @since 1.6.4
    afterVerificationWithPass :: site -> Route site
    afterVerificationWithPass = site -> Route site
forall site. YesodAuthEmail site => site -> Route site
afterPasswordRoute

    -- | Does the user need to provide the current password in order to set a
    -- new password?
    --
    -- Default: if the user logged in via an email link do not require a password.
    --
    -- @since 1.2.1
    needOldPassword :: AuthId site -> AuthHandler site Bool
    needOldPassword AuthId site
aid' = do
        Maybe Text
mkey <- Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
loginLinkKey
        case Maybe Text
mkey Maybe Text
-> (Text -> Maybe (Text, UTCTime)) -> Maybe (Text, UTCTime)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe (Text, UTCTime)
forall a. Read a => String -> Maybe a
readMay (String -> Maybe (Text, UTCTime))
-> (Text -> String) -> Text -> Maybe (Text, UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TS.unpack of
            Just (Text
aidT, UTCTime
time) | Just AuthId site
aid <- Text -> Maybe (AuthId site)
forall s. PathPiece s => Text -> Maybe s
fromPathPiece Text
aidT, AuthId site -> Text
forall s. PathPiece s => s -> Text
toPathPiece (AuthId site
aid AuthId site -> AuthId site -> AuthId site
forall a. a -> a -> a
`asTypeOf` AuthId site
aid') Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== AuthId site -> Text
forall s. PathPiece s => s -> Text
toPathPiece AuthId site
aid' -> do
                UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime
60 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
30) UTCTime
time UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
now
            Maybe (Text, UTCTime)
_ -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

    -- | Check that the given plain-text password meets minimum security standards.
    --
    -- Default: password is at least three characters.
    checkPasswordSecurity :: AuthId site -> Text -> AuthHandler site (Either Text ())
    checkPasswordSecurity AuthId site
_ Text
x
        | Text -> Int
TS.length Text
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3 = Either Text () -> m (Either Text ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text () -> m (Either Text ()))
-> Either Text () -> m (Either Text ())
forall a b. (a -> b) -> a -> b
$ () -> Either Text ()
forall a b. b -> Either a b
Right ()
        | Bool
otherwise = Either Text () -> m (Either Text ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text () -> m (Either Text ()))
-> Either Text () -> m (Either Text ())
forall a b. (a -> b) -> a -> b
$ Text -> Either Text ()
forall a b. a -> Either a b
Left Text
"Password must be at least three characters"

    -- | Response after sending a confirmation email.
    --
    -- @since 1.2.2
    confirmationEmailSentResponse :: Text -> AuthHandler site TypedContent
    confirmationEmailSentResponse Text
identifier = do
        AuthMessage -> Text
mr <- m (AuthMessage -> Text)
forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
        Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
            Text -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *).
Monad m =>
Text -> Writer (Endo [ProvidedRep m]) ()
provideJsonMessage (AuthMessage -> Text
mr AuthMessage
msg)
            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]) ())
-> m Html -> Writer (Endo [ProvidedRep m]) ()
forall a b. (a -> b) -> a -> b
$ WidgetFor site () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor site () -> m Html) -> WidgetFor site () -> m Html
forall a b. (a -> b) -> a -> b
$ do
              AuthMessage -> WidgetFor site ()
forall (m :: * -> *) msg.
(MonadWidget m, RenderMessage (HandlerSite m) msg) =>
msg -> m ()
setTitleI AuthMessage
Msg.ConfirmationEmailSentTitle
              [whamlet|<p>_{msg}|]
      where
        msg :: AuthMessage
msg = Text -> AuthMessage
Msg.ConfirmationEmailSent Text
identifier

    -- | If a response is set, it will be used when an already-verified email
    -- tries to re-register. Otherwise, `confirmationEmailSentResponse` will be
    -- used.
    --
    -- @since 1.6.4
    emailPreviouslyRegisteredResponse :: MonadAuthHandler site m => Text -> Maybe (m TypedContent)
    emailPreviouslyRegisteredResponse Text
_ = Maybe (m TypedContent)
forall a. Maybe a
Nothing

    -- | Additional normalization of email addresses, besides standard canonicalization.
    --
    -- Default: Lower case the email address.
    --
    -- @since 1.2.3
    normalizeEmailAddress :: site -> Text -> Text
    normalizeEmailAddress site
_ = Text -> Text
TS.toLower

    -- | Handler called to render the login page.
    -- The default works fine, but you may want to override it in
    -- order to have a different DOM.
    --
    -- Default: 'defaultEmailLoginHandler'.
    --
    -- @since 1.4.17
    emailLoginHandler :: (Route Auth -> Route site) -> WidgetFor site ()
    emailLoginHandler = (AuthRoute -> Route site) -> WidgetFor site ()
forall master.
YesodAuthEmail master =>
(AuthRoute -> Route master) -> WidgetFor master ()
defaultEmailLoginHandler


    -- | Handler called to render the registration page.  The
    -- default works fine, but you may want to override it in
    -- order to have a different DOM.
    --
    -- Default: 'defaultRegisterHandler'.
    --
    -- @since: 1.2.6
    registerHandler :: AuthHandler site Html
    registerHandler = m Html
forall master. YesodAuthEmail master => AuthHandler master Html
defaultRegisterHandler

    -- | Handler called to render the \"forgot password\" page.
    -- The default works fine, but you may want to override it in
    -- order to have a different DOM.
    --
    -- Default: 'defaultForgotPasswordHandler'.
    --
    -- @since: 1.2.6
    forgotPasswordHandler :: AuthHandler site Html
    forgotPasswordHandler = m Html
forall master. YesodAuthEmail master => AuthHandler master Html
defaultForgotPasswordHandler

    -- | Handler called to render the \"set password\" page.  The
    -- default works fine, but you may want to override it in
    -- order to have a different DOM.
    --
    -- Default: 'defaultSetPasswordHandler'.
    --
    -- @since: 1.2.6
    setPasswordHandler ::
         Bool
         -- ^ Whether the old password is needed.  If @True@, a
         -- field for the old password should be presented.
         -- Otherwise, just two fields for the new password are
         -- needed.
      -> AuthHandler site TypedContent
    setPasswordHandler = Bool -> m TypedContent
forall master.
YesodAuthEmail master =>
Bool -> AuthHandler master TypedContent
defaultSetPasswordHandler


    -- | Helper that controls what happens after a user registration
    -- request is submitted. This method can be overridden to completely
    -- customize what happens during the user registration process,
    -- such as for handling additional fields in the registration form.
    --
    -- The default implementation is in terms of 'defaultRegisterHelper'.
    --
    -- @since: 1.6.9
    registerHelper :: Route Auth
                      -- ^ Where to sent the user in the event
                      -- that registration fails
                   -> AuthHandler site TypedContent
    registerHelper = Bool -> Bool -> AuthRoute -> AuthHandler site TypedContent
forall master.
YesodAuthEmail master =>
Bool -> Bool -> AuthRoute -> AuthHandler master TypedContent
defaultRegisterHelper Bool
False Bool
False

    -- | Helper that controls what happens after a forgot password
    -- request is submitted. As with `registerHelper`, this method can
    -- be overridden to customize the behavior when a user attempts
    -- to recover their password.
    --
    -- The default implementation is in terms of 'defaultRegisterHelper'.
    --
    -- @since: 1.6.9
    passwordResetHelper :: Route Auth
                           -- ^ Where to sent the user in the event
                           -- that the password reset fails
                        -> AuthHandler site TypedContent
    passwordResetHelper = Bool -> Bool -> AuthRoute -> AuthHandler site TypedContent
forall master.
YesodAuthEmail master =>
Bool -> Bool -> AuthRoute -> AuthHandler master TypedContent
defaultRegisterHelper Bool
True Bool
True

authEmail :: (YesodAuthEmail m) => AuthPlugin m
authEmail :: AuthPlugin m
authEmail =
    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
"email" Text -> Texts -> AuthHandler m TypedContent
forall m.
YesodAuthEmail m =>
Text -> Texts -> AuthHandler m TypedContent
dispatch (AuthRoute -> Route m) -> WidgetFor m ()
forall master.
YesodAuthEmail master =>
(AuthRoute -> Route master) -> WidgetFor master ()
emailLoginHandler
  where
    dispatch :: YesodAuthEmail m => Text -> [Text] -> AuthHandler m TypedContent
    dispatch :: Text -> Texts -> AuthHandler m TypedContent
dispatch Text
"GET" [Text
"register"] = m Html
forall master. YesodAuthEmail master => AuthHandler master Html
getRegisterR m Html -> (Html -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Html -> m TypedContent
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"POST" [Text
"register"] = m TypedContent
forall master.
YesodAuthEmail master =>
AuthHandler master TypedContent
postRegisterR m TypedContent
-> (TypedContent -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypedContent -> m TypedContent
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"GET" [Text
"forgot-password"] = m Html
forall master. YesodAuthEmail master => AuthHandler master Html
getForgotPasswordR m Html -> (Html -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Html -> m TypedContent
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"POST" [Text
"forgot-password"] = m TypedContent
forall master.
YesodAuthEmail master =>
AuthHandler master TypedContent
postForgotPasswordR m TypedContent
-> (TypedContent -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypedContent -> m TypedContent
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"GET" [Text
"verify", Text
eid, Text
verkey] =
        case Text -> Maybe (AuthEmailId m)
forall s. PathPiece s => Text -> Maybe s
fromPathPiece Text
eid of
            Maybe (AuthEmailId m)
Nothing   -> m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
notFound
            Just AuthEmailId m
eid' -> AuthEmailId m -> Text -> Bool -> AuthHandler m TypedContent
forall site.
YesodAuthEmail site =>
AuthEmailId site -> Text -> Bool -> AuthHandler site TypedContent
getVerifyR AuthEmailId m
eid' Text
verkey Bool
False m TypedContent
-> (TypedContent -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypedContent -> m TypedContent
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"GET" [Text
"verify", Text
eid, Text
verkey, Text
hasSetPass] =
        case Text -> Maybe (AuthEmailId m)
forall s. PathPiece s => Text -> Maybe s
fromPathPiece Text
eid of
            Maybe (AuthEmailId m)
Nothing -> m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
notFound
            Just AuthEmailId m
eid' -> AuthEmailId m -> Text -> Bool -> AuthHandler m TypedContent
forall site.
YesodAuthEmail site =>
AuthEmailId site -> Text -> Bool -> AuthHandler site TypedContent
getVerifyR AuthEmailId m
eid' Text
verkey (Text
hasSetPass Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
verifyURLHasSetPassText) m TypedContent
-> (TypedContent -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypedContent -> m TypedContent
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"POST" [Text
"login"] = m TypedContent
forall master.
YesodAuthEmail master =>
AuthHandler master TypedContent
postLoginR m TypedContent
-> (TypedContent -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypedContent -> m TypedContent
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"GET" [Text
"set-password"] = m TypedContent
forall master.
YesodAuthEmail master =>
AuthHandler master TypedContent
getPasswordR m TypedContent
-> (TypedContent -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypedContent -> m TypedContent
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"POST" [Text
"set-password"] = m TypedContent
forall master.
YesodAuthEmail master =>
AuthHandler master TypedContent
postPasswordR m TypedContent
-> (TypedContent -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypedContent -> m TypedContent
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
_ Texts
_ = m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
notFound

getRegisterR :: YesodAuthEmail master => AuthHandler master Html
getRegisterR :: AuthHandler master Html
getRegisterR = m Html
forall master. YesodAuthEmail master => AuthHandler master Html
registerHandler

-- | Default implementation of 'emailLoginHandler'.
--
-- @since 1.4.17
defaultEmailLoginHandler
  :: YesodAuthEmail master
  => (Route Auth -> Route master)
  -> WidgetFor master ()
defaultEmailLoginHandler :: (AuthRoute -> Route master) -> WidgetFor master ()
defaultEmailLoginHandler AuthRoute -> Route master
toParent = do
        (WidgetFor master ()
widget, Enctype
enctype) <- (Html
 -> MForm
      (WidgetFor master) (FormResult UserLoginForm, WidgetFor master ()))
-> WidgetFor master (WidgetFor master (), Enctype)
forall (m :: * -> *) a xml.
(RenderMessage (HandlerSite m) FormMessage, MonadHandler m) =>
(Html -> MForm m (FormResult a, xml)) -> m (xml, Enctype)
generateFormPost Html
-> MForm
     (WidgetFor master) (FormResult UserLoginForm, WidgetFor master ())
forall a (m :: * -> *).
(ToMarkup a, YesodAuth (HandlerSite m), MonadHandler m) =>
a
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, Texts)
     Enctype
     Ints
     m
     (FormResult UserLoginForm, WidgetFor (HandlerSite m) ())
loginForm

        [whamlet|
            <form method="post" action="@{toParent loginR}" enctype=#{enctype}>
                <div id="emailLoginForm">
                    ^{widget}
                    <div>
                        <button type=submit .btn .btn-success>
                            _{Msg.LoginViaEmail}
                        &nbsp;
                        <a href="@{toParent registerR}" .btn .btn-default>
                            _{Msg.RegisterLong}
        |]
  where
    loginForm :: a
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, Texts)
     Enctype
     Ints
     m
     (FormResult UserLoginForm, WidgetFor (HandlerSite m) ())
loginForm a
extra = do

        Text
emailMsg <- AuthMessage
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, Texts) Enctype Ints m Text
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
AuthMessage -> m Text
renderMessage' AuthMessage
Msg.Email
        (FormResult Text
emailRes, FieldView (HandlerSite m)
emailView) <- Field m Text
-> FieldSettings (HandlerSite m)
-> Maybe Text
-> MForm m (FormResult Text, FieldView (HandlerSite m))
forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
emailField (Text -> FieldSettings (HandlerSite m)
forall master. YesodAuth master => Text -> FieldSettings master
emailSettings Text
emailMsg) Maybe Text
forall a. Maybe a
Nothing

        Text
passwordMsg <- AuthMessage
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, Texts) Enctype Ints m Text
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
AuthMessage -> m Text
renderMessage' AuthMessage
Msg.Password
        (FormResult Text
passwordRes, FieldView (HandlerSite m)
passwordView) <- Field m Text
-> FieldSettings (HandlerSite m)
-> Maybe Text
-> MForm m (FormResult Text, FieldView (HandlerSite m))
forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
passwordField (Text -> FieldSettings (HandlerSite m)
forall master. YesodAuth master => Text -> FieldSettings master
passwordSettings Text
passwordMsg) Maybe Text
forall a. Maybe a
Nothing

        let userRes :: FormResult UserLoginForm
userRes = Text -> Text -> UserLoginForm
UserLoginForm (Text -> Text -> UserLoginForm)
-> FormResult Text -> FormResult (Text -> UserLoginForm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Control.Applicative.<$> FormResult Text
emailRes
                                    FormResult (Text -> UserLoginForm)
-> FormResult Text -> FormResult UserLoginForm
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
Control.Applicative.<*> FormResult Text
passwordRes
        let widget :: WidgetFor (HandlerSite m) ()
widget = do
              [whamlet|
                  #{extra}
                  <div>
                      ^{fvInput emailView}
                  <div>
                      ^{fvInput passwordView}
              |]

        (FormResult UserLoginForm, WidgetFor (HandlerSite m) ())
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, Texts)
     Enctype
     Ints
     m
     (FormResult UserLoginForm, WidgetFor (HandlerSite m) ())
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult UserLoginForm
userRes, WidgetFor (HandlerSite m) ()
widget)
    emailSettings :: Text -> FieldSettings master
emailSettings Text
emailMsg = do
        FieldSettings :: forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings {
            fsLabel :: SomeMessage master
fsLabel = AuthMessage -> SomeMessage master
forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage AuthMessage
Msg.Email,
            fsTooltip :: Maybe (SomeMessage master)
fsTooltip = Maybe (SomeMessage master)
forall a. Maybe a
Nothing,
            fsId :: Maybe Text
fsId = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"email",
            fsName :: Maybe Text
fsName = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"email",
            fsAttrs :: [(Text, Text)]
fsAttrs = [(Text
"autofocus", Text
""), (Text
"placeholder", Text
emailMsg)]
        }
    passwordSettings :: Text -> FieldSettings master
passwordSettings Text
passwordMsg =
         FieldSettings :: forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings {
            fsLabel :: SomeMessage master
fsLabel = AuthMessage -> SomeMessage master
forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage AuthMessage
Msg.Password,
            fsTooltip :: Maybe (SomeMessage master)
fsTooltip = Maybe (SomeMessage master)
forall a. Maybe a
Nothing,
            fsId :: Maybe Text
fsId = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"password",
            fsName :: Maybe Text
fsName = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"password",
            fsAttrs :: [(Text, Text)]
fsAttrs = [(Text
"placeholder", Text
passwordMsg)]
        }
    renderMessage' :: AuthMessage -> m Text
renderMessage' AuthMessage
msg = do
        Texts
langs <- m Texts
forall (m :: * -> *). MonadHandler m => m Texts
languages
        HandlerSite m
master <- m (HandlerSite m)
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
        Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ HandlerSite m -> Texts -> AuthMessage -> Text
forall master.
YesodAuth master =>
master -> Texts -> AuthMessage -> Text
renderAuthMessage HandlerSite m
master Texts
langs AuthMessage
msg

-- | Default implementation of 'registerHandler'.
--
-- @since 1.2.6
defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html
defaultRegisterHandler :: AuthHandler master Html
defaultRegisterHandler = do
    (WidgetFor master ()
widget, Enctype
enctype) <- (Html -> MForm m (FormResult UserForm, WidgetFor master ()))
-> m (WidgetFor master (), Enctype)
forall (m :: * -> *) a xml.
(RenderMessage (HandlerSite m) FormMessage, MonadHandler m) =>
(Html -> MForm m (FormResult a, xml)) -> m (xml, Enctype)
generateFormPost Html -> MForm m (FormResult UserForm, WidgetFor master ())
forall a (m :: * -> *).
(ToMarkup a, MonadHandler m, YesodAuth (HandlerSite m)) =>
a
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, Texts)
     Enctype
     Ints
     m
     (FormResult UserForm, WidgetFor (HandlerSite m) ())
registrationForm
    AuthRoute -> Route master
toParentRoute <- m (AuthRoute -> Route master)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
    WidgetFor master () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor master () -> m Html) -> WidgetFor master () -> m Html
forall a b. (a -> b) -> a -> b
$ do
        AuthMessage -> WidgetFor master ()
forall (m :: * -> *) msg.
(MonadWidget m, RenderMessage (HandlerSite m) msg) =>
msg -> m ()
setTitleI AuthMessage
Msg.RegisterLong
        [whamlet|
            <p>_{Msg.EnterEmail}
            <form method="post" action="@{toParentRoute registerR}" enctype=#{enctype}>
                <div id="registerForm">
                    ^{widget}
                <button .btn>_{Msg.Register}
        |]
    where
        registrationForm :: a
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, Texts)
     Enctype
     Ints
     m
     (FormResult UserForm, WidgetFor (HandlerSite m) ())
registrationForm a
extra = do
            let emailSettings :: FieldSettings (HandlerSite m)
emailSettings = FieldSettings :: forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings {
                fsLabel :: SomeMessage (HandlerSite m)
fsLabel = AuthMessage -> SomeMessage (HandlerSite m)
forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage AuthMessage
Msg.Email,
                fsTooltip :: Maybe (SomeMessage (HandlerSite m))
fsTooltip = Maybe (SomeMessage (HandlerSite m))
forall a. Maybe a
Nothing,
                fsId :: Maybe Text
fsId = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"email",
                fsName :: Maybe Text
fsName = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"email",
                fsAttrs :: [(Text, Text)]
fsAttrs = [(Text
"autofocus", Text
"")]
            }

            (FormResult Text
emailRes, FieldView (HandlerSite m)
emailView) <- Field m Text
-> FieldSettings (HandlerSite m)
-> Maybe Text
-> MForm m (FormResult Text, FieldView (HandlerSite m))
forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
emailField FieldSettings (HandlerSite m)
emailSettings Maybe Text
forall a. Maybe a
Nothing

            let userRes :: FormResult UserForm
userRes = Text -> UserForm
UserForm (Text -> UserForm) -> FormResult Text -> FormResult UserForm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormResult Text
emailRes
            let widget :: WidgetFor (HandlerSite m) ()
widget = do
                  [whamlet|
                      #{extra}
                      ^{fvLabel emailView}
                      ^{fvInput emailView}
                  |]

            (FormResult UserForm, WidgetFor (HandlerSite m) ())
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, Texts)
     Enctype
     Ints
     m
     (FormResult UserForm, WidgetFor (HandlerSite m) ())
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult UserForm
userRes, WidgetFor (HandlerSite m) ()
widget)

parseRegister :: Value -> Parser (Text, Maybe Text)
parseRegister :: Value -> Parser (Text, Maybe Text)
parseRegister = String
-> (Object -> Parser (Text, Maybe Text))
-> Value
-> Parser (Text, Maybe Text)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"email" (\Object
obj -> do
                                      Text
email <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"email"
                                      Maybe Text
pass <- Object
obj Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"password"
                                      (Text, Maybe Text) -> Parser (Text, Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
email, Maybe Text
pass))

defaultRegisterHelper :: YesodAuthEmail master
                      => Bool -- ^ Allow lookup via username in addition to email
                      -> Bool -- ^ Set to `True` for forgot password flow, `False` for new account registration
                      -> Route Auth
                      -> AuthHandler master TypedContent
defaultRegisterHelper :: Bool -> Bool -> AuthRoute -> AuthHandler master TypedContent
defaultRegisterHelper Bool
allowUsername Bool
forgotPassword AuthRoute
dest = do
    master
y <- m master
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    CI ByteString -> Text -> m ()
forall (m :: * -> *).
(MonadHandler m, MonadLogger m) =>
CI ByteString -> Text -> m ()
checkCsrfHeaderOrParam CI ByteString
defaultCsrfHeaderName Text
defaultCsrfParamName
    FormResult (Text, Maybe Text)
result <- FormInput m (Text, Maybe Text) -> m (FormResult (Text, Maybe Text))
forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (FormResult a)
runInputPostResult (FormInput m (Text, Maybe Text)
 -> m (FormResult (Text, Maybe Text)))
-> FormInput m (Text, Maybe Text)
-> m (FormResult (Text, Maybe Text))
forall a b. (a -> b) -> a -> b
$ (,)
        (Text -> Maybe Text -> (Text, Maybe Text))
-> FormInput m Text
-> FormInput m (Maybe Text -> (Text, Maybe 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 (Maybe Text -> (Text, Maybe Text))
-> FormInput m (Maybe Text) -> FormInput m (Text, Maybe Text)
forall (f :: * -> *) a b. Applicative f => 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
"password"

    Maybe (Text, Maybe Text)
creds <- case FormResult (Text, Maybe Text)
result of
                 FormSuccess (Text
iden, Maybe Text
pass) -> Maybe (Text, Maybe Text) -> m (Maybe (Text, Maybe Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Text, Maybe Text) -> m (Maybe (Text, Maybe Text)))
-> Maybe (Text, Maybe Text) -> m (Maybe (Text, Maybe Text))
forall a b. (a -> b) -> a -> b
$ (Text, Maybe Text) -> Maybe (Text, Maybe Text)
forall a. a -> Maybe a
Just (Text
iden, Maybe Text
pass)
                 FormResult (Text, Maybe Text)
_ -> do
                     (Result Value
creds :: Result Value) <- m (Result Value)
forall (m :: * -> *) a.
(MonadHandler m, FromJSON a) =>
m (Result a)
parseCheckJsonBody
                     Maybe (Text, Maybe Text) -> m (Maybe (Text, Maybe Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Text, Maybe Text) -> m (Maybe (Text, Maybe Text)))
-> Maybe (Text, Maybe Text) -> m (Maybe (Text, Maybe Text))
forall a b. (a -> b) -> a -> b
$ case Result Value
creds of
                                  Error String
_     -> Maybe (Text, Maybe Text)
forall a. Maybe a
Nothing
                                  Success Value
val -> (Value -> Parser (Text, Maybe Text))
-> Value -> Maybe (Text, Maybe Text)
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser (Text, Maybe Text)
parseRegister Value
val

    let eidentifier :: Either AuthMessage Text
eidentifier = case Maybe (Text, Maybe Text)
creds of
                          Maybe (Text, Maybe Text)
Nothing -> AuthMessage -> Either AuthMessage Text
forall a b. a -> Either a b
Left AuthMessage
Msg.NoIdentifierProvided
                          Just (Text
x, Maybe Text
_)
                              | Just ByteString
x' <- ByteString -> Maybe ByteString
Text.Email.Validate.canonicalizeEmail (Text -> ByteString
encodeUtf8 Text
x) ->
                                         Text -> Either AuthMessage Text
forall a b. b -> Either a b
Right (Text -> Either AuthMessage Text)
-> Text -> Either AuthMessage Text
forall a b. (a -> b) -> a -> b
$ master -> Text -> Text
forall site. YesodAuthEmail site => site -> Text -> Text
normalizeEmailAddress master
y (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
x'
                              | Bool
allowUsername -> Text -> Either AuthMessage Text
forall a b. b -> Either a b
Right (Text -> Either AuthMessage Text)
-> Text -> Either AuthMessage Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
TS.strip Text
x
                              | Bool
otherwise -> AuthMessage -> Either AuthMessage Text
forall a b. a -> Either a b
Left AuthMessage
Msg.InvalidEmailAddress

    let mpass :: Maybe Text
mpass = case (Bool
forgotPassword, Maybe (Text, Maybe Text)
creds) of
                    (Bool
False, Just (Text
_, Maybe Text
mp)) -> Maybe Text
mp
                    (Bool, Maybe (Text, Maybe Text))
_                     -> Maybe Text
forall a. Maybe a
Nothing

    case Either AuthMessage Text
eidentifier of
      Left AuthMessage
failMsg -> AuthRoute -> AuthMessage -> AuthHandler master TypedContent
forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
dest AuthMessage
failMsg
      Right Text
identifier -> do
            Maybe (EmailCreds master)
mecreds <- Text -> AuthHandler master (Maybe (EmailCreds master))
forall site.
YesodAuthEmail site =>
Text -> AuthHandler site (Maybe (EmailCreds site))
getEmailCreds Text
identifier
            Maybe (AuthEmailId master, Bool, Text, Text)
registerCreds <-
                case Maybe (EmailCreds master)
mecreds of
                    Just (EmailCreds AuthEmailId master
lid Maybe (AuthId master)
_ Bool
verStatus (Just Text
key) Text
email) -> Maybe (AuthEmailId master, Bool, Text, Text)
-> m (Maybe (AuthEmailId master, Bool, Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (AuthEmailId master, Bool, Text, Text)
 -> m (Maybe (AuthEmailId master, Bool, Text, Text)))
-> Maybe (AuthEmailId master, Bool, Text, Text)
-> m (Maybe (AuthEmailId master, Bool, Text, Text))
forall a b. (a -> b) -> a -> b
$ (AuthEmailId master, Bool, Text, Text)
-> Maybe (AuthEmailId master, Bool, Text, Text)
forall a. a -> Maybe a
Just (AuthEmailId master
lid, Bool
verStatus, Text
key, Text
email)
                    Just (EmailCreds AuthEmailId master
lid Maybe (AuthId master)
_ Bool
verStatus Maybe Text
Nothing Text
email) -> do
                        Text
key <- IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ master -> IO Text
forall site. YesodAuthEmail site => site -> IO Text
randomKey master
y
                        AuthEmailId master -> Text -> AuthHandler master ()
forall site.
YesodAuthEmail site =>
AuthEmailId site -> Text -> AuthHandler site ()
setVerifyKey AuthEmailId master
lid Text
key
                        Maybe (AuthEmailId master, Bool, Text, Text)
-> m (Maybe (AuthEmailId master, Bool, Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (AuthEmailId master, Bool, Text, Text)
 -> m (Maybe (AuthEmailId master, Bool, Text, Text)))
-> Maybe (AuthEmailId master, Bool, Text, Text)
-> m (Maybe (AuthEmailId master, Bool, Text, Text))
forall a b. (a -> b) -> a -> b
$ (AuthEmailId master, Bool, Text, Text)
-> Maybe (AuthEmailId master, Bool, Text, Text)
forall a. a -> Maybe a
Just (AuthEmailId master
lid, Bool
verStatus, Text
key, Text
email)
                    Maybe (EmailCreds master)
Nothing
                        | Bool
allowUsername -> Maybe (AuthEmailId master, Bool, Text, Text)
-> m (Maybe (AuthEmailId master, Bool, Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (AuthEmailId master, Bool, Text, Text)
forall a. Maybe a
Nothing
                        | Bool
otherwise -> do
                            Text
key <- IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ master -> IO Text
forall site. YesodAuthEmail site => site -> IO Text
randomKey master
y
                            AuthEmailId master
lid <- case Maybe Text
mpass of
                                Just Text
pass -> do
                                    Text
salted <- Text -> AuthHandler master Text
forall site. YesodAuthEmail site => Text -> AuthHandler site Text
hashAndSaltPassword Text
pass
                                    Text -> Text -> Text -> AuthHandler master (AuthEmailId master)
forall site.
YesodAuthEmail site =>
Text -> Text -> Text -> AuthHandler site (AuthEmailId site)
addUnverifiedWithPass Text
identifier Text
key Text
salted
                                Maybe Text
_ -> Text -> Text -> AuthHandler master (AuthEmailId master)
forall site.
YesodAuthEmail site =>
Text -> Text -> AuthHandler site (AuthEmailId site)
addUnverified Text
identifier Text
key
                            Maybe (AuthEmailId master, Bool, Text, Text)
-> m (Maybe (AuthEmailId master, Bool, Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (AuthEmailId master, Bool, Text, Text)
 -> m (Maybe (AuthEmailId master, Bool, Text, Text)))
-> Maybe (AuthEmailId master, Bool, Text, Text)
-> m (Maybe (AuthEmailId master, Bool, Text, Text))
forall a b. (a -> b) -> a -> b
$ (AuthEmailId master, Bool, Text, Text)
-> Maybe (AuthEmailId master, Bool, Text, Text)
forall a. a -> Maybe a
Just (AuthEmailId master
lid, Bool
False, Text
key, Text
identifier)
            case Maybe (AuthEmailId master, Bool, Text, Text)
registerCreds of
                Maybe (AuthEmailId master, Bool, Text, Text)
Nothing -> AuthRoute -> AuthMessage -> AuthHandler master TypedContent
forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
dest (Text -> AuthMessage
Msg.IdentifierNotFound Text
identifier)
                Just creds :: (AuthEmailId master, Bool, Text, Text)
creds@(AuthEmailId master
_, Bool
False, Text
_, Text
_) -> (AuthEmailId master, Bool, Text, Text) -> m TypedContent
sendConfirmationEmail (AuthEmailId master, Bool, Text, Text)
creds
                Just creds :: (AuthEmailId master, Bool, Text, Text)
creds@(AuthEmailId master
_, Bool
True, Text
_, Text
_) -> do
                  if Bool
forgotPassword
                    then (AuthEmailId master, Bool, Text, Text) -> m TypedContent
sendConfirmationEmail (AuthEmailId master, Bool, Text, Text)
creds
                    else case Text -> Maybe (m TypedContent)
forall site (m :: * -> *).
(YesodAuthEmail site, MonadAuthHandler site m) =>
Text -> Maybe (m TypedContent)
emailPreviouslyRegisteredResponse Text
identifier of
                      Just m TypedContent
response -> m TypedContent
response
                      Maybe (m TypedContent)
Nothing       -> (AuthEmailId master, Bool, Text, Text) -> m TypedContent
sendConfirmationEmail (AuthEmailId master, Bool, Text, Text)
creds
              where sendConfirmationEmail :: (AuthEmailId master, Bool, Text, Text) -> m TypedContent
sendConfirmationEmail (AuthEmailId master
lid, Bool
_, Text
verKey, Text
email) = do
                      Route master -> Text
render <- m (Route master -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
                      AuthRoute -> Route master
tp <- m (AuthRoute -> Route master)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
                      let verUrl :: Text
verUrl = Route master -> Text
render (Route master -> Text) -> Route master -> Text
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route master
tp (AuthRoute -> Route master) -> AuthRoute -> Route master
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Bool -> AuthRoute
verifyR (AuthEmailId master -> Text
forall s. PathPiece s => s -> Text
toPathPiece AuthEmailId master
lid) Text
verKey (Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
mpass)
                      if Bool
forgotPassword
                         then Text -> Text -> Text -> AuthHandler master ()
forall site.
YesodAuthEmail site =>
Text -> Text -> Text -> AuthHandler site ()
sendForgotPasswordEmail Text
email Text
verKey Text
verUrl
                         else Text -> Text -> Text -> AuthHandler master ()
forall site.
YesodAuthEmail site =>
Text -> Text -> Text -> AuthHandler site ()
sendVerifyEmail Text
email Text
verKey Text
verUrl
                      Text -> AuthHandler master TypedContent
forall site.
YesodAuthEmail site =>
Text -> AuthHandler site TypedContent
confirmationEmailSentResponse Text
identifier


postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent
postRegisterR :: AuthHandler master TypedContent
postRegisterR = AuthRoute -> AuthHandler master TypedContent
forall site.
YesodAuthEmail site =>
AuthRoute -> AuthHandler site TypedContent
registerHelper AuthRoute
registerR

getForgotPasswordR :: YesodAuthEmail master => AuthHandler master Html
getForgotPasswordR :: AuthHandler master Html
getForgotPasswordR = m Html
forall master. YesodAuthEmail master => AuthHandler master Html
forgotPasswordHandler

-- | Default implementation of 'forgotPasswordHandler'.
--
-- @since 1.2.6
defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html
defaultForgotPasswordHandler :: AuthHandler master Html
defaultForgotPasswordHandler = do
    (WidgetFor master ()
widget, Enctype
enctype) <- (Html
 -> MForm m (FormResult ForgotPasswordForm, WidgetFor master ()))
-> m (WidgetFor master (), Enctype)
forall (m :: * -> *) a xml.
(RenderMessage (HandlerSite m) FormMessage, MonadHandler m) =>
(Html -> MForm m (FormResult a, xml)) -> m (xml, Enctype)
generateFormPost Html
-> MForm m (FormResult ForgotPasswordForm, WidgetFor master ())
forgotPasswordForm
    AuthRoute -> Route master
toParent <- m (AuthRoute -> Route master)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
    WidgetFor master () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor master () -> m Html) -> WidgetFor master () -> m Html
forall a b. (a -> b) -> a -> b
$ do
        AuthMessage -> WidgetFor master ()
forall (m :: * -> *) msg.
(MonadWidget m, RenderMessage (HandlerSite m) msg) =>
msg -> m ()
setTitleI AuthMessage
Msg.PasswordResetTitle
        [whamlet|
            <p>_{Msg.PasswordResetPrompt}
            <form method=post action=@{toParent forgotPasswordR} enctype=#{enctype}>
                <div id="forgotPasswordForm">
                    ^{widget}
                    <button .btn>_{Msg.SendPasswordResetEmail}
        |]
  where
    forgotPasswordForm :: Html
-> MForm m (FormResult ForgotPasswordForm, WidgetFor master ())
forgotPasswordForm Html
extra = do
        (FormResult Text
emailRes, FieldView master
emailView) <- Field m Text
-> FieldSettings master
-> Maybe Text
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, Texts)
     Enctype
     Ints
     m
     (FormResult Text, FieldView master)
forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
emailField FieldSettings master
emailSettings Maybe Text
forall a. Maybe a
Nothing

        let forgotPasswordRes :: FormResult ForgotPasswordForm
forgotPasswordRes = Text -> ForgotPasswordForm
ForgotPasswordForm (Text -> ForgotPasswordForm)
-> FormResult Text -> FormResult ForgotPasswordForm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormResult Text
emailRes
        let widget :: WidgetFor master ()
widget = do
              [whamlet|
                  #{extra}
                  ^{fvLabel emailView}
                  ^{fvInput emailView}
              |]
        (FormResult ForgotPasswordForm, WidgetFor master ())
-> MForm m (FormResult ForgotPasswordForm, WidgetFor master ())
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult ForgotPasswordForm
forgotPasswordRes, WidgetFor master ()
widget)

    emailSettings :: FieldSettings master
emailSettings =
        FieldSettings :: forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings {
            fsLabel :: SomeMessage master
fsLabel = AuthMessage -> SomeMessage master
forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage AuthMessage
Msg.ProvideIdentifier,
            fsTooltip :: Maybe (SomeMessage master)
fsTooltip = Maybe (SomeMessage master)
forall a. Maybe a
Nothing,
            fsId :: Maybe Text
fsId = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"forgotPassword",
            fsName :: Maybe Text
fsName = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"email",
            fsAttrs :: [(Text, Text)]
fsAttrs = [(Text
"autofocus", Text
"")]
        }

postForgotPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
postForgotPasswordR :: AuthHandler master TypedContent
postForgotPasswordR = AuthRoute -> AuthHandler master TypedContent
forall site.
YesodAuthEmail site =>
AuthRoute -> AuthHandler site TypedContent
passwordResetHelper AuthRoute
forgotPasswordR

getVerifyR :: YesodAuthEmail site
           => AuthEmailId site
           -> Text
           -> Bool
           -> AuthHandler site TypedContent
getVerifyR :: AuthEmailId site -> Text -> Bool -> AuthHandler site TypedContent
getVerifyR AuthEmailId site
lid Text
key Bool
hasSetPass = do
    Maybe Text
realKey <- AuthEmailId site -> AuthHandler site (Maybe Text)
forall site.
YesodAuthEmail site =>
AuthEmailId site -> AuthHandler site (Maybe Text)
getVerifyKey AuthEmailId site
lid
    Maybe Text
memail <- AuthEmailId site -> AuthHandler site (Maybe Text)
forall site.
YesodAuthEmail site =>
AuthEmailId site -> AuthHandler site (Maybe Text)
getEmail AuthEmailId site
lid
    AuthMessage -> Text
mr <- m (AuthMessage -> Text)
forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
    case (Maybe Text
realKey Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
key, Maybe Text
memail) of
        (Bool
True, Just Text
email) -> do
            Maybe (AuthId site)
muid <- AuthEmailId site -> AuthHandler site (Maybe (AuthId site))
forall site.
YesodAuthEmail site =>
AuthEmailId site -> AuthHandler site (Maybe (AuthId site))
verifyAccount AuthEmailId site
lid
            case Maybe (AuthId site)
muid of
                Maybe (AuthId site)
Nothing -> (AuthMessage -> Text) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
(AuthMessage -> Text) -> m TypedContent
invalidKey AuthMessage -> Text
mr
                Just AuthId site
uid -> do
                    Bool -> Creds (HandlerSite m) -> m ()
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Bool -> Creds (HandlerSite m) -> m ()
setCreds Bool
False (Creds (HandlerSite m) -> m ()) -> Creds (HandlerSite m) -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [(Text, Text)] -> Creds site
forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"email-verify" Text
email [(Text
"verifiedEmail", Text
email)] -- FIXME uid?
                    AuthId (HandlerSite m) -> m ()
forall (m :: * -> *).
(MonadHandler m, YesodAuthEmail (HandlerSite m)) =>
AuthId (HandlerSite m) -> m ()
setLoginLinkKey AuthId site
AuthId (HandlerSite m)
uid
                    let msgAv :: AuthMessage
msgAv = if Bool
hasSetPass
                                  then AuthMessage
Msg.EmailVerified
                                  else AuthMessage
Msg.EmailVerifiedChangePass
                    Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
                      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]) ())
-> m Html -> Writer (Endo [ProvidedRep m]) ()
forall a b. (a -> b) -> a -> b
$ do
                        Text -> AuthMessage -> m ()
forall (m :: * -> *) msg.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
Text -> msg -> m ()
addMessageI Text
"success" AuthMessage
msgAv
                        Route site
redirectRoute <- if Bool
hasSetPass
                            then do
                              site
y <- m site
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
                              Route site -> m (Route site)
forall (m :: * -> *) a. Monad m => a -> m a
return (Route site -> m (Route site)) -> Route site -> m (Route site)
forall a b. (a -> b) -> a -> b
$ site -> Route site
forall site. YesodAuthEmail site => site -> Route site
afterVerificationWithPass site
y
                            else do
                              AuthRoute -> Route site
tp <- m (AuthRoute -> Route site)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
                              Route site -> m (Route site)
forall (m :: * -> *) a. Monad m => a -> m a
return (Route site -> m (Route site)) -> Route site -> m (Route site)
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route site
tp AuthRoute
setpassR
                        (Html -> Html) -> m Html -> m Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Html -> Html
asHtml (m Html -> m Html) -> m Html -> m Html
forall a b. (a -> b) -> a -> b
$ Route site -> m Html
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect Route site
redirectRoute
                      Text -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *).
Monad m =>
Text -> Writer (Endo [ProvidedRep m]) ()
provideJsonMessage (Text -> Writer (Endo [ProvidedRep m]) ())
-> Text -> Writer (Endo [ProvidedRep m]) ()
forall a b. (a -> b) -> a -> b
$ AuthMessage -> Text
mr AuthMessage
msgAv
        (Bool, Maybe Text)
_ -> (AuthMessage -> Text) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
(AuthMessage -> Text) -> m TypedContent
invalidKey AuthMessage -> Text
mr
  where
    msgIk :: AuthMessage
msgIk = AuthMessage
Msg.InvalidKey
    invalidKey :: (AuthMessage -> Text) -> m TypedContent
invalidKey AuthMessage -> Text
mr = Text -> m Html -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Text -> m Html -> m TypedContent
messageJson401 (AuthMessage -> Text
mr AuthMessage
msgIk) (m Html -> m TypedContent) -> m Html -> m TypedContent
forall a b. (a -> b) -> a -> b
$ WidgetFor (HandlerSite m) () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor (HandlerSite m) () -> m Html)
-> WidgetFor (HandlerSite m) () -> m Html
forall a b. (a -> b) -> a -> b
$ do
        AuthMessage -> WidgetFor (HandlerSite m) ()
forall (m :: * -> *) msg.
(MonadWidget m, RenderMessage (HandlerSite m) msg) =>
msg -> m ()
setTitleI AuthMessage
msgIk
        [whamlet|
$newline never
<p>_{msgIk}
|]


parseCreds :: Value -> Parser (Text, Text)
parseCreds :: Value -> Parser (Text, Text)
parseCreds = String
-> (Object -> Parser (Text, Text)) -> Value -> Parser (Text, Text)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"creds" (\Object
obj -> do
                                   Text
email' <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"email"
                                   Text
pass <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"password"
                                   (Text, Text) -> Parser (Text, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
email', Text
pass))


postLoginR :: YesodAuthEmail master => AuthHandler master TypedContent
postLoginR :: AuthHandler master TypedContent
postLoginR = do
    FormResult (Text, Text)
result <- FormInput m (Text, Text) -> m (FormResult (Text, Text))
forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (FormResult a)
runInputPostResult (FormInput m (Text, Text) -> m (FormResult (Text, Text)))
-> FormInput m (Text, Text) -> m (FormResult (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"

    Maybe (Text, Text)
midentifier <- case FormResult (Text, Text)
result of
                     FormSuccess (Text
iden, Text
pass) -> Maybe (Text, Text) -> m (Maybe (Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Text, Text) -> m (Maybe (Text, Text)))
-> Maybe (Text, Text) -> m (Maybe (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
iden, Text
pass)
                     FormResult (Text, Text)
_ -> do
                       (Result Value
creds :: Result Value) <- m (Result Value)
forall (m :: * -> *) a.
(MonadHandler m, FromJSON a) =>
m (Result a)
parseCheckJsonBody
                       case Result Value
creds of
                         Error String
_     -> Maybe (Text, Text) -> m (Maybe (Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Text, Text)
forall a. Maybe a
Nothing
                         Success Value
val -> Maybe (Text, Text) -> m (Maybe (Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Text, Text) -> m (Maybe (Text, Text)))
-> Maybe (Text, Text) -> m (Maybe (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Value -> Parser (Text, Text)) -> Value -> Maybe (Text, Text)
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser (Text, Text)
parseCreds Value
val

    case Maybe (Text, Text)
midentifier of
      Maybe (Text, Text)
Nothing -> AuthRoute -> AuthMessage -> AuthHandler master TypedContent
forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
LoginR AuthMessage
Msg.NoIdentifierProvided
      Just (Text
identifier, Text
pass) -> do
          Maybe (EmailCreds master)
mecreds <- Text -> AuthHandler master (Maybe (EmailCreds master))
forall site.
YesodAuthEmail site =>
Text -> AuthHandler site (Maybe (EmailCreds site))
getEmailCreds Text
identifier
          Maybe Text
maid <-
              case ( Maybe (EmailCreds master)
mecreds Maybe (EmailCreds master)
-> (EmailCreds master -> Maybe (AuthId master))
-> Maybe (AuthId master)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EmailCreds master -> Maybe (AuthId master)
forall site. EmailCreds site -> Maybe (AuthId site)
emailCredsAuthId
                   , EmailCreds master -> Text
forall site. EmailCreds site -> Text
emailCredsEmail (EmailCreds master -> Text)
-> Maybe (EmailCreds master) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (EmailCreds master)
mecreds
                   , EmailCreds master -> Bool
forall site. EmailCreds site -> Bool
emailCredsStatus (EmailCreds master -> Bool)
-> Maybe (EmailCreds master) -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (EmailCreds master)
mecreds
                   ) of
                (Just AuthId master
aid, Just Text
email', Just Bool
True) -> do
                      Maybe Text
mrealpass <- AuthId master -> AuthHandler master (Maybe Text)
forall site.
YesodAuthEmail site =>
AuthId site -> AuthHandler site (Maybe Text)
getPassword AuthId master
aid
                      case Maybe Text
mrealpass of
                        Maybe Text
Nothing -> Maybe Text -> m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
                        Just Text
realpass -> do
                            Bool
passValid <- Text -> Text -> AuthHandler master Bool
forall site.
YesodAuthEmail site =>
Text -> Text -> AuthHandler site Bool
verifyPassword Text
pass Text
realpass
                            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
$ if Bool
passValid
                                    then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
email'
                                    else Maybe Text
forall a. Maybe a
Nothing
                (Maybe (AuthId master), Maybe Text, Maybe Bool)
_ -> Maybe Text -> m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
          let isEmail :: Bool
isEmail = ByteString -> Bool
Text.Email.Validate.isValid (ByteString -> Bool) -> ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
identifier
          case Maybe Text
maid of
            Just Text
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 master
forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds
                         (if Bool
isEmail then Text
"email" else Text
"username")
                         Text
email'
                         [(Text
"verifiedEmail", Text
email')]
            Maybe Text
Nothing ->
                AuthRoute -> AuthMessage -> AuthHandler master TypedContent
forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
LoginR (AuthMessage -> AuthHandler master TypedContent)
-> AuthMessage -> AuthHandler master TypedContent
forall a b. (a -> b) -> a -> b
$
                                   if Bool
isEmail
                                   then AuthMessage
Msg.InvalidEmailPass
                                   else AuthMessage
Msg.InvalidUsernamePass

getPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
getPasswordR :: AuthHandler master TypedContent
getPasswordR = do
    Maybe (AuthId master)
maid <- m (Maybe (AuthId master))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
maybeAuthId
    case Maybe (AuthId master)
maid of
        Maybe (AuthId master)
Nothing -> AuthRoute -> AuthMessage -> AuthHandler master TypedContent
forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
LoginR AuthMessage
Msg.BadSetPass
        Just AuthId master
aid -> do
            Bool
needOld <- AuthId master -> AuthHandler master Bool
forall site.
YesodAuthEmail site =>
AuthId site -> AuthHandler site Bool
needOldPassword AuthId master
aid
            Bool -> AuthHandler master TypedContent
forall master.
YesodAuthEmail master =>
Bool -> AuthHandler master TypedContent
setPasswordHandler Bool
needOld

-- | Default implementation of 'setPasswordHandler'.
--
-- @since 1.2.6
defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent
defaultSetPasswordHandler :: Bool -> AuthHandler master TypedContent
defaultSetPasswordHandler Bool
needOld = do
    AuthMessage -> Text
messageRender <- m (AuthMessage -> Text)
forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
    AuthRoute -> Route master
toParent <- m (AuthRoute -> Route master)
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)
-> Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
        Text -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *).
Monad m =>
Text -> Writer (Endo [ProvidedRep m]) ()
provideJsonMessage (Text -> Writer (Endo [ProvidedRep m]) ())
-> Text -> Writer (Endo [ProvidedRep m]) ()
forall a b. (a -> b) -> a -> b
$ AuthMessage -> Text
messageRender AuthMessage
Msg.SetPass
        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]) ())
-> m Html -> Writer (Endo [ProvidedRep m]) ()
forall a b. (a -> b) -> a -> b
$ WidgetFor master () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor master () -> m Html) -> WidgetFor master () -> m Html
forall a b. (a -> b) -> a -> b
$ do
            (WidgetFor master ()
widget, Enctype
enctype) <- (Html
 -> MForm
      (WidgetFor master) (FormResult PasswordForm, WidgetFor master ()))
-> WidgetFor master (WidgetFor master (), Enctype)
forall (m :: * -> *) a xml.
(RenderMessage (HandlerSite m) FormMessage, MonadHandler m) =>
(Html -> MForm m (FormResult a, xml)) -> m (xml, Enctype)
generateFormPost Html
-> RWST
     (Maybe (Env, FileEnv), master, Texts)
     Enctype
     Ints
     (WidgetFor master)
     (FormResult PasswordForm, WidgetFor master ())
Html
-> MForm
     (WidgetFor master) (FormResult PasswordForm, WidgetFor master ())
setPasswordForm
            AuthMessage -> WidgetFor master ()
forall (m :: * -> *) msg.
(MonadWidget m, RenderMessage (HandlerSite m) msg) =>
msg -> m ()
setTitleI AuthMessage
Msg.SetPassTitle
            [whamlet|
                <h3>_{Msg.SetPass}
                <form method="post" action="@{toParent setpassR}" enctype=#{enctype}>
                    ^{widget}
            |]
  where
    setPasswordForm :: Html
-> RWST
     (Maybe (Env, FileEnv), master, Texts)
     Enctype
     Ints
     (WidgetFor master)
     (FormResult PasswordForm, WidgetFor master ())
setPasswordForm Html
extra = do
        (FormResult Text
currentPasswordRes, FieldView master
currentPasswordView) <- Field (WidgetFor master) Text
-> FieldSettings master
-> Maybe Text
-> MForm (WidgetFor master) (FormResult Text, FieldView master)
forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field (WidgetFor master) Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
passwordField FieldSettings master
currentPasswordSettings Maybe Text
forall a. Maybe a
Nothing
        (FormResult Text
newPasswordRes, FieldView master
newPasswordView) <- Field (WidgetFor master) Text
-> FieldSettings master
-> Maybe Text
-> MForm (WidgetFor master) (FormResult Text, FieldView master)
forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field (WidgetFor master) Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
passwordField FieldSettings master
newPasswordSettings Maybe Text
forall a. Maybe a
Nothing
        (FormResult Text
confirmPasswordRes, FieldView master
confirmPasswordView) <- Field (WidgetFor master) Text
-> FieldSettings master
-> Maybe Text
-> MForm (WidgetFor master) (FormResult Text, FieldView master)
forall site (m :: * -> *) a.
(RenderMessage site FormMessage, HandlerSite m ~ site,
 MonadHandler m) =>
Field m a
-> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq Field (WidgetFor master) Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
passwordField FieldSettings master
confirmPasswordSettings Maybe Text
forall a. Maybe a
Nothing

        let passwordFormRes :: FormResult PasswordForm
passwordFormRes = Text -> Text -> Text -> PasswordForm
PasswordForm (Text -> Text -> Text -> PasswordForm)
-> FormResult Text -> FormResult (Text -> Text -> PasswordForm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormResult Text
currentPasswordRes FormResult (Text -> Text -> PasswordForm)
-> FormResult Text -> FormResult (Text -> PasswordForm)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FormResult Text
newPasswordRes FormResult (Text -> PasswordForm)
-> FormResult Text -> FormResult PasswordForm
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FormResult Text
confirmPasswordRes
        let widget :: WidgetFor master ()
widget = do
              [whamlet|
                  #{extra}
                  <table>
                      $if needOld
                          <tr>
                              <th>
                                  ^{fvLabel currentPasswordView}
                              <td>
                                  ^{fvInput currentPasswordView}
                      <tr>
                          <th>
                              ^{fvLabel newPasswordView}
                          <td>
                              ^{fvInput newPasswordView}
                      <tr>
                          <th>
                              ^{fvLabel confirmPasswordView}
                          <td>
                              ^{fvInput confirmPasswordView}
                      <tr>
                          <td colspan="2">
                              <input type=submit value=_{Msg.SetPassTitle}>
              |]

        (FormResult PasswordForm, WidgetFor master ())
-> RWST
     (Maybe (Env, FileEnv), master, Texts)
     Enctype
     Ints
     (WidgetFor master)
     (FormResult PasswordForm, WidgetFor master ())
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult PasswordForm
passwordFormRes, WidgetFor master ()
widget)
    currentPasswordSettings :: FieldSettings master
currentPasswordSettings =
         FieldSettings :: forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings {
             fsLabel :: SomeMessage master
fsLabel = AuthMessage -> SomeMessage master
forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage AuthMessage
Msg.CurrentPassword,
             fsTooltip :: Maybe (SomeMessage master)
fsTooltip = Maybe (SomeMessage master)
forall a. Maybe a
Nothing,
             fsId :: Maybe Text
fsId = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"currentPassword",
             fsName :: Maybe Text
fsName = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"current",
             fsAttrs :: [(Text, Text)]
fsAttrs = [(Text
"autofocus", Text
"")]
         }
    newPasswordSettings :: FieldSettings master
newPasswordSettings =
        FieldSettings :: forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings {
            fsLabel :: SomeMessage master
fsLabel = AuthMessage -> SomeMessage master
forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage AuthMessage
Msg.NewPass,
            fsTooltip :: Maybe (SomeMessage master)
fsTooltip = Maybe (SomeMessage master)
forall a. Maybe a
Nothing,
            fsId :: Maybe Text
fsId = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"newPassword",
            fsName :: Maybe Text
fsName = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"new",
            fsAttrs :: [(Text, Text)]
fsAttrs = [(Text
"autofocus", Text
""), (Text
":not", Text
""), (Text
"needOld:autofocus", Text
"")]
        }
    confirmPasswordSettings :: FieldSettings master
confirmPasswordSettings =
        FieldSettings :: forall master.
SomeMessage master
-> Maybe (SomeMessage master)
-> Maybe Text
-> Maybe Text
-> [(Text, Text)]
-> FieldSettings master
FieldSettings {
            fsLabel :: SomeMessage master
fsLabel = AuthMessage -> SomeMessage master
forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage AuthMessage
Msg.ConfirmPass,
            fsTooltip :: Maybe (SomeMessage master)
fsTooltip = Maybe (SomeMessage master)
forall a. Maybe a
Nothing,
            fsId :: Maybe Text
fsId = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"confirmPassword",
            fsName :: Maybe Text
fsName = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"confirm",
            fsAttrs :: [(Text, Text)]
fsAttrs = [(Text
"autofocus", Text
"")]
        }

parsePassword :: Value -> Parser (Text, Text, Maybe Text)
parsePassword :: Value -> Parser (Text, Text, Maybe Text)
parsePassword = String
-> (Object -> Parser (Text, Text, Maybe Text))
-> Value
-> Parser (Text, Text, Maybe Text)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"password" (\Object
obj -> do
                                         Text
email' <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"new"
                                         Text
pass <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"confirm"
                                         Maybe Text
curr <- Object
obj Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"current"
                                         (Text, Text, Maybe Text) -> Parser (Text, Text, Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
email', Text
pass, Maybe Text
curr))

postPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
postPasswordR :: AuthHandler master TypedContent
postPasswordR = do
    Maybe (AuthId master)
maid <- m (Maybe (AuthId master))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
maybeAuthId
    (Result Value
creds :: Result Value) <- m (Result Value)
forall (m :: * -> *) a.
(MonadHandler m, FromJSON a) =>
m (Result a)
parseCheckJsonBody
    let jcreds :: Maybe (Text, Text, Maybe Text)
jcreds = case Result Value
creds of
                   Error String
_     -> Maybe (Text, Text, Maybe Text)
forall a. Maybe a
Nothing
                   Success Value
val -> (Value -> Parser (Text, Text, Maybe Text))
-> Value -> Maybe (Text, Text, Maybe Text)
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser (Text, Text, Maybe Text)
parsePassword Value
val
    let doJsonParsing :: Bool
doJsonParsing = Maybe (Text, Text, Maybe Text) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Text, Text, Maybe Text)
jcreds
    case Maybe (AuthId master)
maid of
        Maybe (AuthId master)
Nothing -> AuthRoute -> AuthMessage -> AuthHandler master TypedContent
forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
LoginR AuthMessage
Msg.BadSetPass
        Just AuthId master
aid -> do
            AuthRoute -> Route master
tm <- m (AuthRoute -> Route master)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
            Bool
needOld <- AuthId master -> AuthHandler master Bool
forall site.
YesodAuthEmail site =>
AuthId site -> AuthHandler site Bool
needOldPassword AuthId master
aid
            if Bool -> Bool
not Bool
needOld then AuthId (HandlerSite m)
-> (AuthRoute -> Route (HandlerSite m))
-> Maybe (Text, Text, Maybe Text)
-> m TypedContent
forall (m :: * -> *) c.
(YesodAuthEmail (HandlerSite m), MonadUnliftIO m, MonadHandler m,
 SubHandlerSite m ~ Auth) =>
AuthId (HandlerSite m)
-> (AuthRoute -> Route (HandlerSite m))
-> Maybe (Text, Text, c)
-> m TypedContent
confirmPassword AuthId master
AuthId (HandlerSite m)
aid AuthRoute -> Route master
AuthRoute -> Route (HandlerSite m)
tm Maybe (Text, Text, Maybe Text)
jcreds else do
                FormResult Text
res <- FormInput m Text -> m (FormResult Text)
forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (FormResult a)
runInputPostResult (FormInput m Text -> m (FormResult Text))
-> FormInput m Text -> m (FormResult 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
"current"
                let fcurrent :: Maybe Text
fcurrent = case FormResult Text
res of
                                 FormSuccess Text
currentPass -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
currentPass
                                 FormResult Text
_                       -> Maybe Text
forall a. Maybe a
Nothing
                let current :: Maybe Text
current = if Bool
doJsonParsing
                              then Maybe (Text, Text, Maybe Text) -> Maybe Text
forall a b a. Maybe (a, b, Maybe a) -> Maybe a
getThird Maybe (Text, Text, Maybe Text)
jcreds
                              else Maybe Text
fcurrent
                Maybe Text
mrealpass <- AuthId master -> AuthHandler master (Maybe Text)
forall site.
YesodAuthEmail site =>
AuthId site -> AuthHandler site (Maybe Text)
getPassword AuthId master
aid
                case (Maybe Text
mrealpass, Maybe Text
current) of
                    (Maybe Text
Nothing, Maybe Text
_) ->
                        Route (HandlerSite m) -> Text -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Route (HandlerSite m) -> Text -> m TypedContent
loginErrorMessage (AuthRoute -> Route master
tm AuthRoute
setpassR) Text
"You do not currently have a password set on your account"
                    (Maybe Text
_, Maybe Text
Nothing) ->
                        AuthRoute -> AuthMessage -> AuthHandler master TypedContent
forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
LoginR AuthMessage
Msg.BadSetPass
                    (Just Text
realpass, Just Text
current') -> do
                        Bool
passValid <- Text -> Text -> AuthHandler master Bool
forall site.
YesodAuthEmail site =>
Text -> Text -> AuthHandler site Bool
verifyPassword Text
current' Text
realpass
                        if Bool
passValid
                          then AuthId (HandlerSite m)
-> (AuthRoute -> Route (HandlerSite m))
-> Maybe (Text, Text, Maybe Text)
-> m TypedContent
forall (m :: * -> *) c.
(YesodAuthEmail (HandlerSite m), MonadUnliftIO m, MonadHandler m,
 SubHandlerSite m ~ Auth) =>
AuthId (HandlerSite m)
-> (AuthRoute -> Route (HandlerSite m))
-> Maybe (Text, Text, c)
-> m TypedContent
confirmPassword AuthId master
AuthId (HandlerSite m)
aid AuthRoute -> Route master
AuthRoute -> Route (HandlerSite m)
tm Maybe (Text, Text, Maybe Text)
jcreds
                          else Route (HandlerSite m) -> Text -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Route (HandlerSite m) -> Text -> m TypedContent
loginErrorMessage (AuthRoute -> Route master
tm AuthRoute
setpassR) Text
"Invalid current password, please try again"

  where
    msgOk :: AuthMessage
msgOk = AuthMessage
Msg.PassUpdated
    getThird :: Maybe (a, b, Maybe a) -> Maybe a
getThird (Just (a
_,b
_,Maybe a
t)) = Maybe a
t
    getThird Maybe (a, b, Maybe a)
Nothing        = Maybe a
forall a. Maybe a
Nothing
    getNewConfirm :: Maybe (a, b, c) -> Maybe (a, b)
getNewConfirm (Just (a
a,b
b,c
_)) = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
a,b
b)
    getNewConfirm Maybe (a, b, c)
_              = Maybe (a, b)
forall a. Maybe a
Nothing
    confirmPassword :: AuthId (HandlerSite m)
-> (AuthRoute -> Route (HandlerSite m))
-> Maybe (Text, Text, c)
-> m TypedContent
confirmPassword AuthId (HandlerSite m)
aid AuthRoute -> Route (HandlerSite m)
tm Maybe (Text, Text, c)
jcreds = do
        FormResult (Text, Text)
res <- FormInput m (Text, Text) -> m (FormResult (Text, Text))
forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (FormResult a)
runInputPostResult (FormInput m (Text, Text) -> m (FormResult (Text, Text)))
-> FormInput m (Text, Text) -> m (FormResult (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
"new"
            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
"confirm"
        let creds :: Maybe (Text, Text)
creds = if (Maybe (Text, Text, c) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Text, Text, c)
jcreds)
                    then Maybe (Text, Text, c) -> Maybe (Text, Text)
forall a b c. Maybe (a, b, c) -> Maybe (a, b)
getNewConfirm Maybe (Text, Text, c)
jcreds
                    else case FormResult (Text, Text)
res of
                           FormSuccess (Text, Text)
res' -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text, Text)
res'
                           FormResult (Text, Text)
_                -> Maybe (Text, Text)
forall a. Maybe a
Nothing
        case Maybe (Text, Text)
creds of
          Maybe (Text, Text)
Nothing -> AuthRoute
-> AuthMessage -> AuthHandler (HandlerSite m) TypedContent
forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
setpassR AuthMessage
Msg.PassMismatch
          Just (Text
new, Text
confirm) ->
              if Text
new Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
confirm
              then AuthRoute
-> AuthMessage -> AuthHandler (HandlerSite m) TypedContent
forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
setpassR AuthMessage
Msg.PassMismatch
              else do
                Either Text ()
isSecure <- AuthId (HandlerSite m)
-> Text -> AuthHandler (HandlerSite m) (Either Text ())
forall site.
YesodAuthEmail site =>
AuthId site -> Text -> AuthHandler site (Either Text ())
checkPasswordSecurity AuthId (HandlerSite m)
aid Text
new
                case Either Text ()
isSecure of
                  Left Text
e -> Route (HandlerSite m) -> Text -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Route (HandlerSite m) -> Text -> m TypedContent
loginErrorMessage (AuthRoute -> Route (HandlerSite m)
tm AuthRoute
setpassR) Text
e
                  Right () -> do
                     Text
salted <- Text -> AuthHandler (HandlerSite m) Text
forall site. YesodAuthEmail site => Text -> AuthHandler site Text
hashAndSaltPassword Text
new
                     HandlerSite m
y <- do
                                AuthId (HandlerSite m) -> Text -> AuthHandler (HandlerSite m) ()
forall site.
YesodAuthEmail site =>
AuthId site -> Text -> AuthHandler site ()
setPassword AuthId (HandlerSite m)
aid Text
salted
                                Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
loginLinkKey
                                Text -> AuthMessage -> m ()
forall (m :: * -> *) msg.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
Text -> msg -> m ()
addMessageI Text
"success" AuthMessage
msgOk
                                m (HandlerSite m)
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod

                     AuthMessage -> Text
mr <- m (AuthMessage -> Text)
forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
                     Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
                         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]) ())
-> m Html -> Writer (Endo [ProvidedRep m]) ()
forall a b. (a -> b) -> a -> b
$
                            (Html -> Html) -> m Html -> m Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Html -> Html
asHtml (m Html -> m Html) -> m Html -> m Html
forall a b. (a -> b) -> a -> b
$ Route (HandlerSite m) -> m Html
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route (HandlerSite m) -> m Html)
-> Route (HandlerSite m) -> m Html
forall a b. (a -> b) -> a -> b
$ HandlerSite m -> Route (HandlerSite m)
forall site. YesodAuthEmail site => site -> Route site
afterPasswordRoute HandlerSite m
y
                         Text -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *).
Monad m =>
Text -> Writer (Endo [ProvidedRep m]) ()
provideJsonMessage (AuthMessage -> Text
mr AuthMessage
msgOk)

saltLength :: Int
saltLength :: Int
saltLength = Int
5

-- | Salt a password with a randomly generated salt.
saltPass :: Text -> IO Text
saltPass :: Text -> IO Text
saltPass = (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode)
         (IO ByteString -> IO Text)
-> (Text -> IO ByteString) -> Text -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Int -> IO ByteString)
-> Int -> ByteString -> IO ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> Int -> IO ByteString
PS.makePassword Int
16
         (ByteString -> IO ByteString)
-> (Text -> ByteString) -> Text -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

saltPass' :: String -> String -> String
saltPass' :: String -> String -> String
saltPass' String
salt String
pass =
    String
salt String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B16.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Digest MD5 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (ByteString -> Digest MD5
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
H.hash (Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
salt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pass) :: H.Digest H.MD5))

isValidPass :: Text -- ^ cleartext password
            -> SaltedPass -- ^ salted password
            -> Bool
isValidPass :: Text -> Text -> Bool
isValidPass Text
ct Text
salted =
    ByteString -> ByteString -> Bool
PS.verifyPassword (Text -> ByteString
encodeUtf8 Text
ct) (Text -> ByteString
encodeUtf8 Text
salted) Bool -> Bool -> Bool
|| Text -> Text -> Bool
isValidPass' Text
ct Text
salted

isValidPass' :: Text -- ^ cleartext password
            -> SaltedPass -- ^ salted password
            -> Bool
isValidPass' :: Text -> Text -> Bool
isValidPass' Text
clear' Text
salted' =
    let salt :: String
salt = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
saltLength String
salted
     in String
salted String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String -> String
saltPass' String
salt String
clear
  where
    clear :: String
clear = Text -> String
TS.unpack Text
clear'
    salted :: String
salted = Text -> String
TS.unpack Text
salted'

-- | Session variable set when user logged in via a login link. See
-- 'needOldPassword'.
--
-- @since 1.2.1
loginLinkKey :: Text
loginLinkKey :: Text
loginLinkKey = Text
"_AUTH_EMAIL_LOGIN_LINK"

-- | Set 'loginLinkKey' to the current time.
--
-- @since 1.2.1
--setLoginLinkKey :: (MonadHandler m) => AuthId site -> m ()
setLoginLinkKey :: (MonadHandler m, YesodAuthEmail (HandlerSite m))
                => AuthId (HandlerSite m)
                -> m ()
setLoginLinkKey :: AuthId (HandlerSite m) -> m ()
setLoginLinkKey AuthId (HandlerSite m)
aid = do
    UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
loginLinkKey (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
TS.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (Text, UTCTime) -> String
forall a. Show a => a -> String
show (AuthId (HandlerSite m) -> Text
forall s. PathPiece s => s -> Text
toPathPiece AuthId (HandlerSite m)
aid, UTCTime
now)

-- See https://github.com/yesodweb/yesod/issues/1245 for discussion on this
-- use of unsafePerformIO.
defaultNonceGen :: Nonce.Generator
defaultNonceGen :: Generator
defaultNonceGen = IO Generator -> Generator
forall a. IO a -> a
unsafePerformIO (IO Generator
forall (m :: * -> *). MonadIO m => m Generator
Nonce.new)
{-# NOINLINE defaultNonceGen #-}