{-# 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"forall a. a -> [a] -> [a]
:Text
eidforall a. a -> [a] -> [a]
:Text
verkeyforall 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
_ = 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 = 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 = forall (m :: * -> *) a. Monad m => a -> m a
return 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
_ = 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 = 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 <- forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
loginLinkKey
        case Maybe Text
mkey forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Read a => String -> Maybe a
readMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TS.unpack of
            Just (Text
aidT, UTCTime
time) | Just AuthId site
aid <- forall s. PathPiece s => Text -> Maybe s
fromPathPiece Text
aidT, forall s. PathPiece s => s -> Text
toPathPiece (AuthId site
aid forall a. a -> a -> a
`asTypeOf` AuthId site
aid') forall a. Eq a => a -> a -> Bool
== forall s. PathPiece s => s -> Text
toPathPiece AuthId site
aid' -> do
                UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime
60 forall a. Num a => a -> a -> a
* NominalDiffTime
30) UTCTime
time forall a. Ord a => a -> a -> Bool
<= UTCTime
now
            Maybe (Text, UTCTime)
_ -> 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 forall a. Ord a => a -> a -> Bool
>= Int
3 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
        | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 <- forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
        forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *).
Monad m =>
Text -> Writer (Endo [ProvidedRep m]) ()
provideJsonMessage (AuthMessage -> Text
mr AuthMessage
msg)
            forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep forall a b. (a -> b) -> a -> b
$ forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout forall a b. (a -> b) -> a -> b
$ do
              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
_ = 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 = 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 = 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 = 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 = 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 = 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 = 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 =
    forall master.
Text
-> (Text -> Texts -> AuthHandler master TypedContent)
-> ((AuthRoute -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
"email" forall m.
YesodAuthEmail m =>
Text -> Texts -> AuthHandler m TypedContent
dispatch 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"] = forall master. YesodAuthEmail master => AuthHandler master Html
getRegisterR forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"POST" [Text
"register"] = forall master.
YesodAuthEmail master =>
AuthHandler master TypedContent
postRegisterR forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"GET" [Text
"forgot-password"] = forall master. YesodAuthEmail master => AuthHandler master Html
getForgotPasswordR forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"POST" [Text
"forgot-password"] = forall master.
YesodAuthEmail master =>
AuthHandler master TypedContent
postForgotPasswordR forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"GET" [Text
"verify", Text
eid, Text
verkey] =
        case forall s. PathPiece s => Text -> Maybe s
fromPathPiece Text
eid of
            Maybe (AuthEmailId m)
Nothing   -> forall (m :: * -> *) a. MonadHandler m => m a
notFound
            Just AuthEmailId m
eid' -> forall site.
YesodAuthEmail site =>
AuthEmailId site -> Text -> Bool -> AuthHandler site TypedContent
getVerifyR AuthEmailId m
eid' Text
verkey Bool
False forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"GET" [Text
"verify", Text
eid, Text
verkey, Text
hasSetPass] =
        case forall s. PathPiece s => Text -> Maybe s
fromPathPiece Text
eid of
            Maybe (AuthEmailId m)
Nothing -> forall (m :: * -> *) a. MonadHandler m => m a
notFound
            Just AuthEmailId m
eid' -> forall site.
YesodAuthEmail site =>
AuthEmailId site -> Text -> Bool -> AuthHandler site TypedContent
getVerifyR AuthEmailId m
eid' Text
verkey (Text
hasSetPass forall a. Eq a => a -> a -> Bool
== Text
verifyURLHasSetPassText) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"POST" [Text
"login"] = forall master.
YesodAuthEmail master =>
AuthHandler master TypedContent
postLoginR forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"GET" [Text
"set-password"] = forall master.
YesodAuthEmail master =>
AuthHandler master TypedContent
getPasswordR forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
"POST" [Text
"set-password"] = forall master.
YesodAuthEmail master =>
AuthHandler master TypedContent
postPasswordR forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
_ Texts
_ = forall (m :: * -> *) a. MonadHandler m => m a
notFound

getRegisterR :: YesodAuthEmail master => AuthHandler master Html
getRegisterR :: forall master. YesodAuthEmail master => AuthHandler master Html
getRegisterR = 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 :: forall master.
YesodAuthEmail master =>
(AuthRoute -> Route master) -> WidgetFor master ()
defaultEmailLoginHandler AuthRoute -> Route master
toParent = do
        (WidgetFor master ()
widget, Enctype
enctype) <- forall (m :: * -> *) a xml.
(RenderMessage (HandlerSite m) FormMessage, MonadHandler m) =>
(Html -> MForm m (FormResult a, xml)) -> m (xml, Enctype)
generateFormPost 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 <- forall {m :: * -> *}.
(MonadHandler m, YesodAuth (HandlerSite m)) =>
AuthMessage -> m Text
renderMessage' AuthMessage
Msg.Email
        (FormResult Text
emailRes, FieldView (HandlerSite m)
emailView) <- 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 forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
emailField (forall {master}. YesodAuth master => Text -> FieldSettings master
emailSettings Text
emailMsg) forall a. Maybe a
Nothing

        Text
passwordMsg <- forall {m :: * -> *}.
(MonadHandler m, YesodAuth (HandlerSite m)) =>
AuthMessage -> m Text
renderMessage' AuthMessage
Msg.Password
        (FormResult Text
passwordRes, FieldView (HandlerSite m)
passwordView) <- 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 forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
passwordField (forall {master}. YesodAuth master => Text -> FieldSettings master
passwordSettings Text
passwordMsg) forall a. Maybe a
Nothing

        let userRes :: FormResult UserLoginForm
userRes = Text -> Text -> UserLoginForm
UserLoginForm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Control.Applicative.<$> FormResult Text
emailRes
                                    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}
              |]

        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 {
            fsLabel :: SomeMessage master
fsLabel = forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage AuthMessage
Msg.Email,
            fsTooltip :: Maybe (SomeMessage master)
fsTooltip = forall a. Maybe a
Nothing,
            fsId :: Maybe Text
fsId = forall a. a -> Maybe a
Just Text
"email",
            fsName :: Maybe Text
fsName = 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 = forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage AuthMessage
Msg.Password,
            fsTooltip :: Maybe (SomeMessage master)
fsTooltip = forall a. Maybe a
Nothing,
            fsId :: Maybe Text
fsId = forall a. a -> Maybe a
Just Text
"password",
            fsName :: Maybe Text
fsName = 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 <- forall (m :: * -> *). MonadHandler m => m Texts
languages
        HandlerSite m
master <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 :: forall master. YesodAuthEmail master => AuthHandler master Html
defaultRegisterHandler = do
    (WidgetFor master ()
widget, Enctype
enctype) <- forall (m :: * -> *) a xml.
(RenderMessage (HandlerSite m) FormMessage, MonadHandler m) =>
(Html -> MForm m (FormResult a, xml)) -> m (xml, Enctype)
generateFormPost 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 <- forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
    forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout forall a b. (a -> b) -> a -> b
$ do
        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 {
                fsLabel :: SomeMessage (HandlerSite m)
fsLabel = forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage AuthMessage
Msg.Email,
                fsTooltip :: Maybe (SomeMessage (HandlerSite m))
fsTooltip = forall a. Maybe a
Nothing,
                fsId :: Maybe Text
fsId = forall a. a -> Maybe a
Just Text
"email",
                fsName :: Maybe Text
fsName = forall a. a -> Maybe a
Just Text
"email",
                fsAttrs :: [(Text, Text)]
fsAttrs = [(Text
"autofocus", Text
"")]
            }

            (FormResult Text
emailRes, FieldView (HandlerSite m)
emailView) <- 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 forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
emailField FieldSettings (HandlerSite m)
emailSettings forall a. Maybe a
Nothing

            let userRes :: FormResult UserForm
userRes = Text -> UserForm
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}
                  |]

            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 = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"email" (\Object
obj -> do
                                      Text
email <- Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"email"
                                      Maybe Text
pass <- Object
obj forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"password"
                                      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 :: forall master.
YesodAuthEmail master =>
Bool -> Bool -> AuthRoute -> AuthHandler master TypedContent
defaultRegisterHelper Bool
allowUsername Bool
forgotPassword AuthRoute
dest = do
    master
y <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    forall (m :: * -> *).
(MonadHandler m, MonadLogger m) =>
CI ByteString -> Text -> m ()
checkCsrfHeaderOrParam CI ByteString
defaultCsrfHeaderName Text
defaultCsrfParamName
    FormResult (Text, Maybe Text)
result <- forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (FormResult a)
runInputPostResult forall a b. (a -> b) -> a -> b
$ (,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"email"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a.
Monad m =>
Field m a -> Text -> FormInput m (Maybe a)
iopt 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) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Text
iden, Maybe Text
pass)
                 FormResult (Text, Maybe Text)
_ -> do
                     (Result Value
creds :: Result Value) <- forall (m :: * -> *) a.
(MonadHandler m, FromJSON a) =>
m (Result a)
parseCheckJsonBody
                     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Result Value
creds of
                                  Error String
_     -> forall a. Maybe a
Nothing
                                  Success Value
val -> 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 -> 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) ->
                                         forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall site. YesodAuthEmail site => site -> Text -> Text
normalizeEmailAddress master
y forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
x'
                              | Bool
allowUsername -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Text
TS.strip Text
x
                              | Bool
otherwise -> 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))
_                     -> forall a. Maybe a
Nothing

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


postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent
postRegisterR :: forall master.
YesodAuthEmail master =>
AuthHandler master TypedContent
postRegisterR = 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 = forall master. YesodAuthEmail master => 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
    (WidgetFor master ()
widget, Enctype
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), HandlerSite m, Texts)
     Enctype
     Ints
     m
     (FormResult ForgotPasswordForm, WidgetFor master ())
forgotPasswordForm
    AuthRoute -> Route master
toParent <- forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
    forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout forall a b. (a -> b) -> a -> b
$ do
        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
-> RWST
     (Maybe (Env, FileEnv), HandlerSite m, Texts)
     Enctype
     Ints
     m
     (FormResult ForgotPasswordForm, WidgetFor master ())
forgotPasswordForm Html
extra = do
        (FormResult Text
emailRes, FieldView (HandlerSite m)
emailView) <- 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 forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
emailField FieldSettings (HandlerSite m)
emailSettings forall a. Maybe a
Nothing

        let forgotPasswordRes :: FormResult ForgotPasswordForm
forgotPasswordRes = Text -> ForgotPasswordForm
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}
              |]
        forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult ForgotPasswordForm
forgotPasswordRes, WidgetFor master ()
widget)

    emailSettings :: FieldSettings (HandlerSite m)
emailSettings =
        FieldSettings {
            fsLabel :: SomeMessage (HandlerSite m)
fsLabel = forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage AuthMessage
Msg.ProvideIdentifier,
            fsTooltip :: Maybe (SomeMessage (HandlerSite m))
fsTooltip = forall a. Maybe a
Nothing,
            fsId :: Maybe Text
fsId = forall a. a -> Maybe a
Just Text
"forgotPassword",
            fsName :: Maybe Text
fsName = 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 = 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
    Maybe Text
realKey <- forall site.
YesodAuthEmail site =>
AuthEmailId site -> AuthHandler site (Maybe Text)
getVerifyKey AuthEmailId site
lid
    Maybe Text
memail <- forall site.
YesodAuthEmail site =>
AuthEmailId site -> AuthHandler site (Maybe Text)
getEmail AuthEmailId site
lid
    AuthMessage -> Text
mr <- forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
    case (Maybe Text
realKey forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
key, Maybe Text
memail) of
        (Bool
True, Just Text
email) -> do
            Maybe (AuthId site)
muid <- 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 -> forall {m :: * -> *}.
(MonadHandler m, YesodAuth (HandlerSite m)) =>
(AuthMessage -> Text) -> m TypedContent
invalidKey AuthMessage -> Text
mr
                Just AuthId site
uid -> do
                    forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Bool -> Creds (HandlerSite m) -> m ()
setCreds Bool
False forall a b. (a -> b) -> a -> b
$ forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"email-verify" Text
email [(Text
"verifiedEmail", Text
email)] -- FIXME uid?
                    forall (m :: * -> *).
(MonadHandler m, YesodAuthEmail (HandlerSite m)) =>
AuthId (HandlerSite m) -> m ()
setLoginLinkKey AuthId site
uid
                    let msgAv :: AuthMessage
msgAv = if Bool
hasSetPass
                                  then AuthMessage
Msg.EmailVerified
                                  else AuthMessage
Msg.EmailVerifiedChangePass
                    forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep forall a b. (a -> b) -> a -> b
$ do
                      forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep forall a b. (a -> b) -> a -> b
$ do
                        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 <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
                              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall site. YesodAuthEmail site => site -> Route site
afterVerificationWithPass site
y
                            else do
                              AuthRoute -> Route site
tp <- forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
                              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route site
tp AuthRoute
setpassR
                        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Html -> Html
asHtml forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect Route site
redirectRoute
                      forall (m :: * -> *).
Monad m =>
Text -> Writer (Endo [ProvidedRep m]) ()
provideJsonMessage forall a b. (a -> b) -> a -> b
$ AuthMessage -> Text
mr AuthMessage
msgAv
        (Bool, Maybe Text)
_ -> 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 = forall (m :: * -> *).
MonadHandler m =>
Text -> m Html -> m TypedContent
messageJson401 (AuthMessage -> Text
mr AuthMessage
msgIk) forall a b. (a -> b) -> a -> b
$ forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout forall a b. (a -> b) -> a -> b
$ do
        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 = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"creds" (\Object
obj -> do
                                   Text
email' <- Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"email"
                                   Text
pass <- Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"password"
                                   forall (m :: * -> *) a. Monad m => a -> m a
return (Text
email', Text
pass))


postLoginR :: YesodAuthEmail master => AuthHandler master TypedContent
postLoginR :: forall master.
YesodAuthEmail master =>
AuthHandler master TypedContent
postLoginR = do
    FormResult (Text, Text)
result <- forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (FormResult a)
runInputPostResult forall a b. (a -> b) -> a -> b
$ (,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"email"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq 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) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Text
iden, Text
pass)
                     FormResult (Text, Text)
_ -> do
                       (Result Value
creds :: Result Value) <- forall (m :: * -> *) a.
(MonadHandler m, FromJSON a) =>
m (Result a)
parseCheckJsonBody
                       case Result Value
creds of
                         Error String
_     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                         Success Value
val -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 -> forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
LoginR AuthMessage
Msg.NoIdentifierProvided
      Just (Text
identifier, Text
pass) -> do
          Maybe (EmailCreds master)
mecreds <- forall site.
YesodAuthEmail site =>
Text -> AuthHandler site (Maybe (EmailCreds site))
getEmailCreds Text
identifier
          Maybe Text
maid <-
              case ( Maybe (EmailCreds master)
mecreds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall site. EmailCreds site -> Maybe (AuthId site)
emailCredsAuthId
                   , forall site. EmailCreds site -> Text
emailCredsEmail forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (EmailCreds master)
mecreds
                   , forall site. EmailCreds site -> Bool
emailCredsStatus 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 <- forall site.
YesodAuthEmail site =>
AuthId site -> AuthHandler site (Maybe Text)
getPassword AuthId master
aid
                      case Maybe Text
mrealpass of
                        Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                        Just Text
realpass -> do
                            Bool
passValid <- forall site.
YesodAuthEmail site =>
Text -> Text -> AuthHandler site Bool
verifyPassword Text
pass Text
realpass
                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
passValid
                                    then forall a. a -> Maybe a
Just Text
email'
                                    else forall a. Maybe a
Nothing
                (Maybe (AuthId master), Maybe Text, Maybe Bool)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
          let isEmail :: Bool
isEmail = ByteString -> Bool
Text.Email.Validate.isValid forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
identifier
          case Maybe Text
maid of
            Just Text
email' ->
                forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect forall a b. (a -> b) -> a -> b
$ 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 ->
                forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
LoginR 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
    Maybe (AuthId master)
maid <- 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 -> forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
LoginR AuthMessage
Msg.BadSetPass
        Just AuthId master
aid -> do
            Bool
needOld <- forall site.
YesodAuthEmail site =>
AuthId site -> AuthHandler site Bool
needOldPassword AuthId master
aid
            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 :: forall master.
YesodAuthEmail master =>
Bool -> AuthHandler master TypedContent
defaultSetPasswordHandler Bool
needOld = do
    AuthMessage -> Text
messageRender <- forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
    AuthRoute -> Route master
toParent <- forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
    forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *).
Monad m =>
Text -> Writer (Endo [ProvidedRep m]) ()
provideJsonMessage forall a b. (a -> b) -> a -> b
$ AuthMessage -> Text
messageRender AuthMessage
Msg.SetPass
        forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep forall a b. (a -> b) -> a -> b
$ forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout forall a b. (a -> b) -> a -> b
$ do
            (WidgetFor master ()
widget, Enctype
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), HandlerSite (WidgetFor master), Texts)
     Enctype
     Ints
     (WidgetFor master)
     (FormResult PasswordForm, WidgetFor master ())
setPasswordForm
            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), HandlerSite (WidgetFor master), Texts)
     Enctype
     Ints
     (WidgetFor master)
     (FormResult PasswordForm, WidgetFor master ())
setPasswordForm Html
extra = do
        (FormResult Text
currentPasswordRes, FieldView (HandlerSite (WidgetFor master))
currentPasswordView) <- 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 forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
passwordField FieldSettings (HandlerSite (WidgetFor master))
currentPasswordSettings forall a. Maybe a
Nothing
        (FormResult Text
newPasswordRes, FieldView (HandlerSite (WidgetFor master))
newPasswordView) <- 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 forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
passwordField FieldSettings (HandlerSite (WidgetFor master))
newPasswordSettings forall a. Maybe a
Nothing
        (FormResult Text
confirmPasswordRes, FieldView (HandlerSite (WidgetFor master))
confirmPasswordView) <- 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 forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
passwordField FieldSettings (HandlerSite (WidgetFor master))
confirmPasswordSettings forall a. Maybe a
Nothing

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

        forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult PasswordForm
passwordFormRes, WidgetFor master ()
widget)
    currentPasswordSettings :: FieldSettings (HandlerSite (WidgetFor master))
currentPasswordSettings =
         FieldSettings {
             fsLabel :: SomeMessage (HandlerSite (WidgetFor master))
fsLabel = forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage AuthMessage
Msg.CurrentPassword,
             fsTooltip :: Maybe (SomeMessage (HandlerSite (WidgetFor master)))
fsTooltip = forall a. Maybe a
Nothing,
             fsId :: Maybe Text
fsId = forall a. a -> Maybe a
Just Text
"currentPassword",
             fsName :: Maybe Text
fsName = 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 = forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage AuthMessage
Msg.NewPass,
            fsTooltip :: Maybe (SomeMessage (HandlerSite (WidgetFor master)))
fsTooltip = forall a. Maybe a
Nothing,
            fsId :: Maybe Text
fsId = forall a. a -> Maybe a
Just Text
"newPassword",
            fsName :: Maybe Text
fsName = 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 = forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage AuthMessage
Msg.ConfirmPass,
            fsTooltip :: Maybe (SomeMessage (HandlerSite (WidgetFor master)))
fsTooltip = forall a. Maybe a
Nothing,
            fsId :: Maybe Text
fsId = forall a. a -> Maybe a
Just Text
"confirmPassword",
            fsName :: Maybe Text
fsName = 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 = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"password" (\Object
obj -> do
                                         Text
email' <- Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"new"
                                         Text
pass <- Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"confirm"
                                         Maybe Text
curr <- Object
obj forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"current"
                                         forall (m :: * -> *) a. Monad m => a -> m a
return (Text
email', Text
pass, Maybe Text
curr))

postPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
postPasswordR :: forall master.
YesodAuthEmail master =>
AuthHandler master TypedContent
postPasswordR = do
    Maybe (AuthId master)
maid <- forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
maybeAuthId
    (Result Value
creds :: 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
_     -> forall a. Maybe a
Nothing
                   Success Value
val -> forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser (Text, Text, Maybe Text)
parsePassword Value
val
    let doJsonParsing :: Bool
doJsonParsing = forall a. Maybe a -> Bool
isJust Maybe (Text, Text, Maybe Text)
jcreds
    case Maybe (AuthId master)
maid of
        Maybe (AuthId master)
Nothing -> forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
LoginR AuthMessage
Msg.BadSetPass
        Just AuthId master
aid -> do
            AuthRoute -> Route master
tm <- forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
            Bool
needOld <- forall site.
YesodAuthEmail site =>
AuthId site -> AuthHandler site Bool
needOldPassword AuthId master
aid
            if Bool -> Bool
not Bool
needOld then forall {m :: * -> *} {c}.
(SubHandlerSite m ~ Auth, YesodAuthEmail (HandlerSite m),
 MonadUnliftIO m, MonadHandler m) =>
AuthId (HandlerSite m)
-> (AuthRoute -> Route (HandlerSite m))
-> Maybe (Text, Text, c)
-> m TypedContent
confirmPassword AuthId master
aid AuthRoute -> Route master
tm Maybe (Text, Text, Maybe Text)
jcreds else do
                FormResult Text
res <- forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (FormResult a)
runInputPostResult forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq 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 -> forall a. a -> Maybe a
Just Text
currentPass
                                 FormResult Text
_                       -> forall a. Maybe a
Nothing
                let current :: Maybe Text
current = if Bool
doJsonParsing
                              then 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 <- 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
_) ->
                        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) ->
                        forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
LoginR AuthMessage
Msg.BadSetPass
                    (Just Text
realpass, Just Text
current') -> do
                        Bool
passValid <- forall site.
YesodAuthEmail site =>
Text -> Text -> AuthHandler site Bool
verifyPassword Text
current' Text
realpass
                        if Bool
passValid
                          then forall {m :: * -> *} {c}.
(SubHandlerSite m ~ Auth, YesodAuthEmail (HandlerSite m),
 MonadUnliftIO m, MonadHandler m) =>
AuthId (HandlerSite m)
-> (AuthRoute -> Route (HandlerSite m))
-> Maybe (Text, Text, c)
-> m TypedContent
confirmPassword AuthId master
aid AuthRoute -> Route master
tm Maybe (Text, Text, Maybe Text)
jcreds
                          else 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        = forall a. Maybe a
Nothing
    getNewConfirm :: Maybe (a, b, c) -> Maybe (a, b)
getNewConfirm (Just (a
a,b
b,c
_)) = forall a. a -> Maybe a
Just (a
a,b
b)
    getNewConfirm Maybe (a, b, c)
_              = 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 <- forall (m :: * -> *) a.
MonadHandler m =>
FormInput m a -> m (FormResult a)
runInputPostResult forall a b. (a -> b) -> a -> b
$ (,)
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"new"
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"confirm"
        let creds :: Maybe (Text, Text)
creds = if (forall a. Maybe a -> Bool
isJust Maybe (Text, Text, c)
jcreds)
                    then 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' -> forall a. a -> Maybe a
Just (Text, Text)
res'
                           FormResult (Text, Text)
_                -> forall a. Maybe a
Nothing
        case Maybe (Text, Text)
creds of
          Maybe (Text, Text)
Nothing -> forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
setpassR AuthMessage
Msg.PassMismatch
          Just (Text
new, Text
confirm) ->
              if Text
new forall a. Eq a => a -> a -> Bool
/= Text
confirm
              then forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
setpassR AuthMessage
Msg.PassMismatch
              else do
                Either Text ()
isSecure <- 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 -> 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 <- forall site. YesodAuthEmail site => Text -> AuthHandler site Text
hashAndSaltPassword Text
new
                     HandlerSite m
y <- do
                                forall site.
YesodAuthEmail site =>
AuthId site -> Text -> AuthHandler site ()
setPassword AuthId (HandlerSite m)
aid Text
salted
                                forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
loginLinkKey
                                forall (m :: * -> *) msg.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
Text -> msg -> m ()
addMessageI Text
"success" AuthMessage
msgOk
                                forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod

                     AuthMessage -> Text
mr <- forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
                     forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep forall a b. (a -> b) -> a -> b
$ do
                         forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep forall a b. (a -> b) -> a -> b
$
                            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Html -> Html
asHtml forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect forall a b. (a -> b) -> a -> b
$ forall site. YesodAuthEmail site => site -> Route site
afterPasswordRoute HandlerSite m
y
                         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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode)
         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> Int -> IO ByteString
PS.makePassword Int
16
         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 forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (ByteString -> Text
TE.decodeUtf8 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B16.encode forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
H.hash (Text -> ByteString
TE.encodeUtf8 forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
salt 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 = forall a. Int -> [a] -> [a]
take Int
saltLength String
salted
     in String
salted 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
    UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
loginLinkKey forall a b. (a -> b) -> a -> b
$ String -> Text
TS.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (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 = forall a. IO a -> a
unsafePerformIO (forall (m :: * -> *). MonadIO m => m Generator
Nonce.new)
{-# NOINLINE defaultNonceGen #-}