    {-# 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
        { forall site. EmailCreds site -> AuthEmailId site
    emailCredsId     :: AuthEmailId site
        , forall site. EmailCreds site -> Maybe (AuthId site)
    emailCredsAuthId :: Maybe (AuthId site)
        , forall site. EmailCreds site -> Bool
    emailCredsStatus :: VerStatus
        , forall site. EmailCreds site -> Maybe Text
    emailCredsVerkey :: Maybe VerKey
        , forall site. 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 ()
    Text -> Text -> Text -> AuthHandler site ()
    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 a. IO a -> m a
    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 a. a -> m a
    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
            mkey <- Text -> m (Maybe Text)
    forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
    lookupSession Text
    loginLinkKey
            case mkey >>= readMay . 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
                    now <- IO UTCTime -> m UTCTime
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO UTCTime
    getCurrentTime
                    return $ addUTCTime (60 * 30) time <= now
                Maybe (Text, UTCTime)
    _ -> Bool -> m Bool
    forall a. a -> m a
    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 a. a -> m a
    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 a. a -> m a
    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
            mr <- m (AuthMessage -> Text)
    forall (m :: * -> *) message.
    (MonadHandler m, RenderMessage (HandlerSite m) message) =>
    m (message -> Text)
    getMessageRender
            selectRep $ do
                provideJsonMessage (mr msg)
                provideRep $ authLayout $ do
                  setTitleI 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
    AuthHandler site 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
    AuthHandler site 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
    Bool -> AuthHandler site 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 :: forall m. YesodAuthEmail m => 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 -> m TypedContent
    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 :: forall m.
    YesodAuthEmail m =>
    Text -> Texts -> AuthHandler m TypedContent
    dispatch Text
    "GET" [Text
    "register"] = m Html
    forall master. YesodAuthEmail master => AuthHandler master Html
    AuthHandler m Html
    getRegisterR m Html -> (Html -> m TypedContent) -> m TypedContent
    forall a b. m a -> (a -> m b) -> m b
    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
    AuthHandler m TypedContent
    postRegisterR m TypedContent
    -> (TypedContent -> m TypedContent) -> m TypedContent
    forall a b. m a -> (a -> m b) -> m b
    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
    AuthHandler m Html
    getForgotPasswordR m Html -> (Html -> m TypedContent) -> m TypedContent
    forall a b. m a -> (a -> m b) -> m b
    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
    AuthHandler m TypedContent
    postForgotPasswordR m TypedContent
    -> (TypedContent -> m TypedContent) -> m TypedContent
    forall a b. m a -> (a -> m b) -> m b
    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 a b. m a -> (a -> m b) -> m b
    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 a b. m a -> (a -> m b) -> m b
    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
    AuthHandler m TypedContent
    postLoginR m TypedContent
    -> (TypedContent -> m TypedContent) -> m TypedContent
    forall a b. m a -> (a -> m b) -> m b
    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
    AuthHandler m TypedContent
    getPasswordR m TypedContent
    -> (TypedContent -> m TypedContent) -> m TypedContent
    forall a b. m a -> (a -> m b) -> m b
    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
    AuthHandler m TypedContent
    postPasswordR m TypedContent
    -> (TypedContent -> m TypedContent) -> m TypedContent
    forall a b. m a -> (a -> m b) -> m b
    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 :: forall master. YesodAuthEmail master => AuthHandler master Html
    getRegisterR = m Html
    forall master. YesodAuthEmail master => AuthHandler master Html
    AuthHandler master Html
    registerHandler

    -- | Default implementation of 'emailLoginHandler'.
    --
    -- @since 1.4.17
    defaultEmailLoginHandler
      :: YesodAuthEmail master
      => (Route Auth -> Route master)
      -> WidgetFor master ()
    defaultEmailLoginHandler :: forall master.
    YesodAuthEmail master =>
    (AuthRoute -> Route master) -> WidgetFor master ()
    defaultEmailLoginHandler AuthRoute -> Route master
    toParent = do
            (widget, 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 ())
    Html
    -> RWST
         (Maybe (Env, FileEnv), HandlerSite (WidgetFor master), Texts)
         Enctype
         Ints
         (WidgetFor master)
         (FormResult UserLoginForm,
          WidgetFor (HandlerSite (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

            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
            (emailRes, emailView) <- mreq emailField (emailSettings emailMsg) Nothing

            passwordMsg <- renderMessage' Msg.Password
            (passwordRes, passwordView) <- mreq passwordField (passwordSettings passwordMsg) Nothing

            let 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 a b. FormResult (a -> b) -> FormResult a -> FormResult b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    Control.Applicative.<*> FormResult Text
    passwordRes
            let widget = do
                  [whamlet|
                      #{extra}
                      <div>
                          ^{fvInput emailView}
                      <div>
                          ^{fvInput passwordView}
                  |]

            return (userRes, widget)
        emailSettings :: Text -> FieldSettings master
    emailSettings Text
    emailMsg = do
            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 {
                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
            langs <- m Texts
    forall (m :: * -> *). MonadHandler m => m Texts
    languages
            master <- getYesod
            return $ renderAuthMessage master langs msg

    -- | Default implementation of 'registerHandler'.
    --
    -- @since 1.2.6
    defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html
    defaultRegisterHandler :: forall master. YesodAuthEmail master => AuthHandler master Html
    defaultRegisterHandler = do
        (widget, 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 ())
    Html
    -> RWST
         (Maybe (Env, FileEnv), HandlerSite m, Texts)
         Enctype
         Ints
         m
         (FormResult UserForm, WidgetFor (HandlerSite m) ())
    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
        toParentRoute <- getRouteToParent
        authLayout $ do
            setTitleI 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 {
                    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
    "")]
                }

                (emailRes, emailView) <- Field m Text
    -> FieldSettings (HandlerSite m)
    -> Maybe Text
    -> RWST
         (Maybe (Env, FileEnv), HandlerSite m, Texts)
         Enctype
         Ints
         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 = 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 = do
                      [whamlet|
                          #{extra}
                          ^{fvLabel emailView}
                          ^{fvInput emailView}
                      |]

                return (userRes, 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
                                          email <- Object
    obj Object -> Key -> Parser Text
    forall a. FromJSON a => Object -> Key -> Parser a
    .: Key
    "email"
                                          pass <- obj .:? "password"
                                          return (email, 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 :: forall master.
    YesodAuthEmail master =>
    Bool -> Bool -> AuthRoute -> AuthHandler master TypedContent
    defaultRegisterHelper Bool
    allowUsername Bool
    forgotPassword AuthRoute
    dest = do
        y <- m master
    m (HandlerSite m)
    forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
    getYesod
        checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName
        result <- runInputPostResult $ (,)
            <$> ireq textField "email"
            <*> iopt textField "password"

        creds <- case result of
                     FormSuccess (Text
    iden, Maybe Text
    pass) -> Maybe (Text, Maybe Text) -> m (Maybe (Text, Maybe Text))
    forall a. a -> m a
    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
                         (creds :: Result Value) <- m (Result Value)
    forall (m :: * -> *) a.
    (MonadHandler m, FromJSON a) =>
    m (Result a)
    parseCheckJsonBody
                         return $ case 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 = 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 = 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 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
                mecreds <- Text -> AuthHandler master (Maybe (EmailCreds master))
    forall site.
    YesodAuthEmail site =>
    Text -> AuthHandler site (Maybe (EmailCreds site))
    getEmailCreds Text
    identifier
                registerCreds <-
                    case 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 a. a -> m a
    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
                            key <- IO Text -> m Text
    forall a. IO a -> m a
    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
                            setVerifyKey lid key
                            return $ Just (lid, verStatus, key, email)
                        Maybe (EmailCreds master)
    Nothing
                            | Bool
    allowUsername -> Maybe (AuthEmailId master, Bool, Text, Text)
    -> m (Maybe (AuthEmailId master, Bool, Text, Text))
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (AuthEmailId master, Bool, Text, Text)
    forall a. Maybe a
    Nothing
                            | Bool
    otherwise -> do
                                key <- IO Text -> m Text
    forall a. IO a -> m a
    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
                                lid <- case mpass of
                                    Just Text
    pass -> do
                                        salted <- Text -> AuthHandler master Text
    forall site. YesodAuthEmail site => Text -> AuthHandler site Text
    hashAndSaltPassword Text
    pass
                                        addUnverifiedWithPass identifier key salted
                                    Maybe Text
    _ -> Text -> Text -> AuthHandler master (AuthEmailId master)
    forall site.
    YesodAuthEmail site =>
    Text -> Text -> AuthHandler site (AuthEmailId site)
    addUnverified Text
    identifier Text
    key
                                return $ Just (lid, False, key, identifier)
                case 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)
    forall (m :: * -> *).
    MonadAuthHandler master 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
                          render <- m (Route master -> Text)
    m (Route (HandlerSite m) -> Text)
    forall (m :: * -> *).
    MonadHandler m =>
    m (Route (HandlerSite m) -> Text)
    getUrlRender
                          tp <- getRouteToParent
                          let 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 forgotPassword
                             then sendForgotPasswordEmail email verKey verUrl
                             else sendVerifyEmail email verKey verUrl
                          confirmationEmailSentResponse identifier

    postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent
    postRegisterR :: forall master.
    YesodAuthEmail master =>
    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 :: forall master. YesodAuthEmail master => AuthHandler master Html
    getForgotPasswordR = m Html
    forall master. YesodAuthEmail master => AuthHandler master Html
    AuthHandler master Html
    forgotPasswordHandler

    -- | Default implementation of 'forgotPasswordHandler'.
    --
    -- @since 1.2.6
    defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html
    defaultForgotPasswordHandler :: forall master. YesodAuthEmail master => AuthHandler master Html
    defaultForgotPasswordHandler = do
        (widget, 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
        toParent <- getRouteToParent
        authLayout $ do
            setTitleI 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
            (emailRes, emailView) <- Field m Text
    -> FieldSettings (HandlerSite m)
    -> Maybe Text
    -> RWST
         (Maybe (Env, FileEnv), HandlerSite m, Texts)
         Enctype
         Ints
         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 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 = do
                  [whamlet|
                      #{extra}
                      ^{fvLabel emailView}
                      ^{fvInput emailView}
                  |]
            return (forgotPasswordRes, widget)

        emailSettings :: FieldSettings (HandlerSite m)
    emailSettings =
            FieldSettings {
                fsLabel :: SomeMessage (HandlerSite m)
    fsLabel = AuthMessage -> SomeMessage (HandlerSite m)
    forall master msg.
    RenderMessage master msg =>
    msg -> SomeMessage master
    SomeMessage AuthMessage
    Msg.ProvideIdentifier,
                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
    "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 :: forall master.
    YesodAuthEmail master =>
    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 :: forall site.
    YesodAuthEmail site =>
    AuthEmailId site -> Text -> Bool -> AuthHandler site TypedContent
    getVerifyR AuthEmailId site
    lid Text
    key Bool
    hasSetPass = do
        realKey <- AuthEmailId site -> AuthHandler site (Maybe Text)
    forall site.
    YesodAuthEmail site =>
    AuthEmailId site -> AuthHandler site (Maybe Text)
    getVerifyKey AuthEmailId site
    lid
        memail <- getEmail lid
        mr <- getMessageRender
        case (realKey == Just key, memail) of
            (Bool
    True, Just Text
    email) -> do
                muid <- AuthEmailId site -> AuthHandler site (Maybe (AuthId site))
    forall site.
    YesodAuthEmail site =>
    AuthEmailId site -> AuthHandler site (Maybe (AuthId site))
    verifyAccount AuthEmailId site
    lid
                case 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
                            redirectRoute <- if Bool
    hasSetPass
                                then do
                                  y <- m site
    m (HandlerSite m)
    forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
    getYesod
                                  return $ afterVerificationWithPass y
                                else do
                                  tp <- m (Route (SubHandlerSite m) -> Route (HandlerSite m))
    m (AuthRoute -> Route site)
    forall (m :: * -> *).
    MonadHandler m =>
    m (Route (SubHandlerSite m) -> Route (HandlerSite m))
    getRouteToParent
                                  return $ tp setpassR
                            fmap asHtml $ redirect 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
    forall (m :: * -> *).
    (MonadHandler m, HandlerSite m ~ HandlerSite m) =>
    WidgetFor (HandlerSite m) () -> 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
                                       email' <- Object
    obj Object -> Key -> Parser Text
    forall a. FromJSON a => Object -> Key -> Parser a
    .: Key
    "email"
                                       pass <- obj .: "password"
                                       return (email', pass))

    postLoginR :: YesodAuthEmail master => AuthHandler master TypedContent
    postLoginR :: forall master.
    YesodAuthEmail master =>
    AuthHandler master TypedContent
    postLoginR = do
        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 a b. FormInput m (a -> b) -> FormInput m a -> FormInput m b
    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"

        midentifier <- case result of
                         FormSuccess (Text
    iden, Text
    pass) -> Maybe (Text, Text) -> m (Maybe (Text, Text))
    forall a. a -> m a
    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
                           (creds :: Result Value) <- m (Result Value)
    forall (m :: * -> *) a.
    (MonadHandler m, FromJSON a) =>
    m (Result a)
    parseCheckJsonBody
                           case creds of
                             Error String
    _     -> Maybe (Text, Text) -> m (Maybe (Text, Text))
    forall a. a -> m a
    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 a. a -> m a
    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 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
              mecreds <- Text -> AuthHandler master (Maybe (EmailCreds master))
    forall site.
    YesodAuthEmail site =>
    Text -> AuthHandler site (Maybe (EmailCreds site))
    getEmailCreds Text
    identifier
              maid <-
                  case ( mecreds >>= emailCredsAuthId
                       , emailCredsEmail <$> mecreds
                       , emailCredsStatus <$> mecreds
                       ) of
                    (Just AuthId master
    aid, Just Text
    email', Just Bool
    True) -> do
                          mrealpass <- AuthId master -> AuthHandler master (Maybe Text)
    forall site.
    YesodAuthEmail site =>
    AuthId site -> AuthHandler site (Maybe Text)
    getPassword AuthId master
    aid
                          case mrealpass of
                            Maybe Text
    Nothing -> Maybe Text -> m (Maybe Text)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe Text
    forall a. Maybe a
    Nothing
                            Just Text
    realpass -> do
                                passValid <- Text -> Text -> AuthHandler master Bool
    forall site.
    YesodAuthEmail site =>
    Text -> Text -> AuthHandler site Bool
    verifyPassword Text
    pass Text
    realpass
                                return $ if passValid
                                        then Just email'
                                        else Nothing
                    (Maybe (AuthId master), Maybe Text, Maybe Bool)
    _ -> Maybe Text -> m (Maybe Text)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe Text
    forall a. Maybe a
    Nothing
              let isEmail = ByteString -> Bool
    Text.Email.Validate.isValid (ByteString -> Bool) -> ByteString -> Bool
    forall a b. (a -> b) -> a -> b
    $ Text -> ByteString
    encodeUtf8 Text
    identifier
              case 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 :: forall master.
    YesodAuthEmail master =>
    AuthHandler master TypedContent
    getPasswordR = do
        maid <- m (Maybe (AuthId master))
    forall master (m :: * -> *).
    (YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
    m (Maybe (AuthId master))
    forall (m :: * -> *).
    (MonadHandler m, master ~ HandlerSite m) =>
    m (Maybe (AuthId master))
    maybeAuthId
        case 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
                needOld <- AuthId master -> AuthHandler master Bool
    forall site.
    YesodAuthEmail site =>
    AuthId site -> AuthHandler site Bool
    needOldPassword AuthId master
    aid
                setPasswordHandler needOld

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

            let 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 a b. FormResult (a -> b) -> FormResult a -> FormResult b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> FormResult Text
    newPasswordRes FormResult (Text -> PasswordForm)
    -> FormResult Text -> FormResult PasswordForm
    forall a b. FormResult (a -> b) -> FormResult a -> FormResult b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> FormResult Text
    confirmPasswordRes
            let 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}>
                  |]

            return (passwordFormRes, widget)
        currentPasswordSettings :: FieldSettings (HandlerSite (WidgetFor master))
    currentPasswordSettings =
             FieldSettings {
                 fsLabel :: SomeMessage (HandlerSite (WidgetFor master))
    fsLabel = AuthMessage -> SomeMessage (HandlerSite (WidgetFor master))
    forall master msg.
    RenderMessage master msg =>
    msg -> SomeMessage master
    SomeMessage AuthMessage
    Msg.CurrentPassword,
                 fsTooltip :: Maybe (SomeMessage (HandlerSite (WidgetFor master)))
    fsTooltip = Maybe (SomeMessage (HandlerSite (WidgetFor 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 (HandlerSite (WidgetFor master))
    newPasswordSettings =
            FieldSettings {
                fsLabel :: SomeMessage (HandlerSite (WidgetFor master))
    fsLabel = AuthMessage -> SomeMessage (HandlerSite (WidgetFor master))
    forall master msg.
    RenderMessage master msg =>
    msg -> SomeMessage master
    SomeMessage AuthMessage
    Msg.NewPass,
                fsTooltip :: Maybe (SomeMessage (HandlerSite (WidgetFor master)))
    fsTooltip = Maybe (SomeMessage (HandlerSite (WidgetFor 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 (HandlerSite (WidgetFor master))
    confirmPasswordSettings =
            FieldSettings {
                fsLabel :: SomeMessage (HandlerSite (WidgetFor master))
    fsLabel = AuthMessage -> SomeMessage (HandlerSite (WidgetFor master))
    forall master msg.
    RenderMessage master msg =>
    msg -> SomeMessage master
    SomeMessage AuthMessage
    Msg.ConfirmPass,
                fsTooltip :: Maybe (SomeMessage (HandlerSite (WidgetFor master)))
    fsTooltip = Maybe (SomeMessage (HandlerSite (WidgetFor 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
                                             email' <- Object
    obj Object -> Key -> Parser Text
    forall a. FromJSON a => Object -> Key -> Parser a
    .: Key
    "new"
                                             pass <- obj .: "confirm"
                                             curr <- obj .:? "current"
                                             return (email', pass, curr))

    postPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
    postPasswordR :: forall master.
    YesodAuthEmail master =>
    AuthHandler master TypedContent
    postPasswordR = do
        maid <- m (Maybe (AuthId master))
    forall master (m :: * -> *).
    (YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
    m (Maybe (AuthId master))
    forall (m :: * -> *).
    (MonadHandler m, master ~ HandlerSite m) =>
    m (Maybe (AuthId master))
    maybeAuthId
        (creds :: Result Value) <- parseCheckJsonBody
        let 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 = Maybe (Text, Text, Maybe Text) -> Bool
    forall a. Maybe a -> Bool
    isJust Maybe (Text, Text, Maybe Text)
    jcreds
        case 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
                tm <- m (Route (SubHandlerSite m) -> Route (HandlerSite m))
    m (AuthRoute -> Route master)
    forall (m :: * -> *).
    MonadHandler m =>
    m (Route (SubHandlerSite m) -> Route (HandlerSite m))
    getRouteToParent
                needOld <- needOldPassword aid
                if not needOld then confirmPassword aid tm jcreds else do
                    res <- runInputPostResult $ ireq textField "current"
                    let 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 = 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
                    mrealpass <- getPassword aid
                    case (mrealpass, 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
                            passValid <- Text -> Text -> AuthHandler master Bool
    forall site.
    YesodAuthEmail site =>
    Text -> Text -> AuthHandler site Bool
    verifyPassword Text
    current' Text
    realpass
                            if passValid
                              then confirmPassword aid tm jcreds
                              else loginErrorMessage (tm setpassR) "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
            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 a b. FormInput m (a -> b) -> FormInput m a -> FormInput m b
    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 = 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 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
                    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 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
                         salted <- Text -> AuthHandler (HandlerSite m) Text
    forall site. YesodAuthEmail site => Text -> AuthHandler site Text
    hashAndSaltPassword Text
    new
                         y <- do
                                    setPassword aid salted
                                    deleteSession loginLinkKey
                                    addMessageI "success" msgOk
                                    getYesod

                         mr <- getMessageRender
                         selectRep $ do
                             provideRep $
                                fmap asHtml $ redirect $ afterPasswordRoute y
                             provideJsonMessage (mr 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 a b. (a -> b) -> IO a -> IO b
    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 :: forall (m :: * -> *).
    (MonadHandler m, YesodAuthEmail (HandlerSite m)) =>
    AuthId (HandlerSite m) -> m ()
    setLoginLinkKey AuthId (HandlerSite m)
    aid = do
        now <- IO UTCTime -> m UTCTime
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO UTCTime
    getCurrentTime
        setSession loginLinkKey $ TS.pack $ show (toPathPiece aid, 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 #-}