{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

{- | A Yesod plugin for traditional email/password authentication

 This plugin uses an alternative flow to Yesod.Auth.Email fom the yesod-auth
 package.

__Note:__ this plugin reserves the following session names for its needs:

 * @yesod-auth-simple-error@
 * @yesod-auth-simple-email@
 * @yas-set-password-token@
 * @yas-registration-token@
 * @yas-password-backup@
-}

module Yesod.Auth.Simple
  ( -- * Plugin
    YesodAuthSimple(..)
  , authSimple
    -- * Routes
  , loginR
  , registerR
  , resetPasswordR
  , resetPasswordEmailSentR
  , setPasswordTokenR
  , confirmTokenR
  , confirmR
  , userExistsR
  , registerSuccessR
  , confirmationEmailSentR
  , passwordStrengthR
    -- * Default widgets
  , loginTemplateDef
  , setPasswordTemplateDef
  , invalidTokenTemplateDef
  , userExistsTemplateDef
  , registerSuccessTemplateDef
  , resetPasswordEmailSentTemplateDef
  , confirmationEmailSentTemplateDef
  , confirmTemplateDef
  , resetPasswordTemplateDef
  , registerTemplateDef
  , passwordFieldTemplateBasic
  , passwordFieldTemplateZxcvbn
  , honeypotFieldTemplate
    -- * Tokens
  , genToken
  , encodeToken
  , hashAndEncodeToken
  , decodeToken
    -- * Error handlers
  , getError
  , setError
  , clearError
    -- * Misc
  , maxPasswordLength
    -- * Types
  , Email(..)
  , Password(..)
  , PW.Strength(..)
  , PasswordCheck(..)
  , PasswordStrength(..)
    -- * Re-export from Scrypt
  , EncryptedPass(..)
  , Pass(..)
  , encryptPassIO'
  ) where

import ClassyPrelude
import Crypto.Hash (Digest, SHA256)
import qualified Crypto.Hash as C
import Crypto.Random (getRandomBytes)
import Crypto.Scrypt (EncryptedPass(..), Pass(..), encryptPassIO', verifyPass')
import Data.Aeson
import qualified Data.ByteArray as ByteArray
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Base64.URL as B64Url
import Data.Function ((&))
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8', decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Vector as Vec
import Network.HTTP.Types (badRequest400, tooManyRequests429)
import Network.Wai (responseBuilder)
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
import Text.Email.Validate (canonicalizeEmail)
import Text.Hamlet (hamletFile)
import Text.Julius (juliusFile)
import Text.Lucius (luciusFile)
import qualified Text.Password.Strength as PW
import qualified Text.Password.Strength.Config as PW
import Yesod.Auth
import Yesod.Auth.Simple.Types
import Yesod.Core
import Yesod.Core.Json as J
import Yesod.Form (iopt, ireq, runInputPost, textField)

minPasswordLength :: Int
minPasswordLength :: Int
minPasswordLength = Int
8 -- min length required in NIST SP 800-63B

maxPasswordLength :: Int
maxPasswordLength :: Int
maxPasswordLength = Int
150 -- zxcvbn takes too long after this point

confirmTokenR :: Text -> AuthRoute
confirmTokenR :: Text -> AuthRoute
confirmTokenR Text
token = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"confirm", Text
token]

confirmR :: AuthRoute
confirmR :: AuthRoute
confirmR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"confirm"]

confirmationEmailSentR :: AuthRoute
confirmationEmailSentR :: AuthRoute
confirmationEmailSentR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"confirmation-email-sent"]

confirmationEmailResentR :: AuthRoute
confirmationEmailResentR :: AuthRoute
confirmationEmailResentR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"confirmation-email-resent"]

loginR :: AuthRoute
loginR :: AuthRoute
loginR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"login"]

registerR :: AuthRoute
registerR :: AuthRoute
registerR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"register"]

registerSuccessR :: AuthRoute
registerSuccessR :: AuthRoute
registerSuccessR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"register-success"]

resetPasswordEmailSentR :: AuthRoute
resetPasswordEmailSentR :: AuthRoute
resetPasswordEmailSentR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"reset-password-email-sent"]

resetPasswordR :: AuthRoute
resetPasswordR :: AuthRoute
resetPasswordR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"reset-password"]

setPasswordR :: AuthRoute
setPasswordR :: AuthRoute
setPasswordR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"set-password"]

setPasswordTokenR :: Text -> AuthRoute
setPasswordTokenR :: Text -> AuthRoute
setPasswordTokenR Text
token = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"set-password", Text
token]

userExistsR :: AuthRoute
userExistsR :: AuthRoute
userExistsR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"user-exists"]

passwordStrengthR :: AuthRoute
passwordStrengthR :: AuthRoute
passwordStrengthR = Text -> Texts -> AuthRoute
PluginR Text
"simple" [Text
"password-strength"]

class (YesodAuth a, PathPiece (AuthSimpleId a)) => YesodAuthSimple a where
  -- | Alias for some UserId datatype, likely same as the one in YesodAuth
  -- Refer to documentation for yesod-auth: http://hackage.haskell.org/package/yesod-auth
  type AuthSimpleId a

  -- | route to redirect to after resetting password e.g. homepage
  afterPasswordRoute :: a -> Route a

  -- | find user by email e.g. `runDB $ getBy $ UniqueUser email`
  getUserId :: MonadAuthHandler a m => Email -> m (Maybe (AuthSimpleId a))

  -- | find user's password (encrypted), handling user not found case
  getUserPassword :: MonadAuthHandler a m => AuthSimpleId a -> m EncryptedPass

  -- | return this content after successful user registration
  onRegisterSuccess :: MonadAuthHandler a m => m TypedContent

  -- | insert user to database with just email and password
  -- other mandatory fields are not supported
  insertUser :: MonadAuthHandler a m => Email -> EncryptedPass -> m (Maybe (AuthSimpleId a))

  -- | update record in database after validation
  updateUserPassword :: MonadAuthHandler a m => AuthSimpleId a -> EncryptedPass -> m ()

  -- | Return time until which the user should not be allowed to log in.
  -- The time is returned so that the UI can provide a helpful message in the
  -- event that a legitimate user somehow triggers the rate-limiting mechanism.
  -- If the time is Nothing, the user may log in.
  shouldPreventLoginAttempt :: MonadAuthHandler a m =>
    Maybe (AuthSimpleId a) -> m (Maybe UTCTime)
  shouldPreventLoginAttempt Maybe (AuthSimpleId a)
_ = Maybe UTCTime -> m (Maybe UTCTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UTCTime
forall a. Maybe a
Nothing

  -- | Perform an action on a login attempt.
  onLoginAttempt :: MonadAuthHandler a m => Maybe (AuthSimpleId a)
                 -- ^ The user id of the given email, if one exists
                 -> Bool
                 -- ^ Whether the password given was correct. Always
                 -- False when user id is Nothing
                 -> m ()
  onLoginAttempt Maybe (AuthSimpleId a)
_ Bool
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- | Called when someone requests registration.
  sendVerifyEmail :: MonadAuthHandler a m => Email -- ^ A valid email they've registered.
                  -> VerUrl -- ^ An verification URL (in absolute form).
                  -> Text   -- ^ A sha256 base64-encoded hash of the
                           -- verification token. You should store this in your
                           -- database.
                  -> m ()
  sendVerifyEmail Email
_ Text
url Text
_ = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> IO ()
forall a (m :: * -> *). (Show a, MonadIO m) => a -> m ()
print (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
url

  -- | Like 'sendVerifyEmail' but for password resets.
  sendResetPasswordEmail :: MonadAuthHandler a m => Email -> VerUrl -> Text -> m ()
  sendResetPasswordEmail Email
_ Text
url Text
_ = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> IO ()
forall a (m :: * -> *). (Show a, MonadIO m) => a -> m ()
print (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
url

  -- | Given a hashed and base64-encoded token from the user, look up
  -- if the token is still valid and return the associated email if so.
  matchRegistrationToken :: MonadAuthHandler a m => Text -> m (Maybe Email)

  {- | Сheck if a registration confirmation is pending for the given email.
    
    @since 1.0.0
  -}
  isConfirmationPending :: MonadAuthHandler a m => Email -> m Bool
  isConfirmationPending Email
_ = Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

  -- | Like 'matchRegistrationToken' but for password resets.
  matchPasswordToken :: MonadAuthHandler a m => Text -> m (Maybe (AuthSimpleId a))

  -- | Can be used to invalidate the registration token. This is
  -- different from 'onRegisterSuccess' because this will also be
  -- called for existing users who use the registration form as a
  -- one-time login link. Note that 'onPasswordUpdated' can handle the
  -- case where a password reset token is used.
  onRegistrationTokenUsed :: MonadAuthHandler a m => Email -> m ()
  onRegistrationTokenUsed Email
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  
  {- | What to do if the email specified during registration is already registered.
    
    @since 1.0.0
  -}
  onEmailAlreadyExist :: MonadAuthHandler a m => m TypedContent
  onEmailAlreadyExist = do
    let msg :: Text
msg = Text
"This email address is already in use. Please login to your existing account."
    AuthRoute -> Text -> AuthHandler a TypedContent
forall a. AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError AuthRoute
registerR Text
msg

  -- | Password field widget for a chosen PasswordCheck algorithm
  passwordFieldTemplate :: (AuthRoute -> Route a) -> WidgetFor a ()
  passwordFieldTemplate AuthRoute -> Route a
tp =
    case YesodAuthSimple a => PasswordCheck
forall a. YesodAuthSimple a => PasswordCheck
passwordCheck @a of
      Zxcvbn Strength
minStren Vector Text
extraWords' ->
        (AuthRoute -> Route a) -> Strength -> Vector Text -> WidgetFor a ()
forall a.
(AuthRoute -> Route a) -> Strength -> Vector Text -> WidgetFor a ()
passwordFieldTemplateZxcvbn AuthRoute -> Route a
tp Strength
minStren Vector Text
extraWords'
      RuleBased Int
_ -> WidgetFor a ()
forall a. WidgetFor a ()
passwordFieldTemplateBasic

  -- | A template for showing the user authentication form
  --
  -- While a default is provided, you should probably override this with a
  -- template that matches your own product's branding.
  loginTemplate :: (AuthRoute -> Route a)
    -> Maybe Text  -- ^ Error
    -> Maybe Text  -- ^ Email
    -> WidgetFor a ()
  loginTemplate = (AuthRoute -> Route a)
-> Maybe Text -> Maybe Text -> WidgetFor a ()
forall a.
(AuthRoute -> Route a)
-> Maybe Text -> Maybe Text -> WidgetFor a ()
loginTemplateDef

  registerTemplate :: (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
  registerTemplate = (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
forall a. (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
registerTemplateDef

  resetPasswordTemplate ::
       (AuthRoute -> Route a)
    -> Maybe Text
    -> WidgetFor a ()
  resetPasswordTemplate = (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
forall a. (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
resetPasswordTemplateDef

  confirmTemplate ::
       (AuthRoute -> Route a)
    -> Route a
    -> Email
    -> Maybe Text
    -> WidgetFor a ()
  confirmTemplate = (AuthRoute -> Route a)
-> Route a -> Email -> Maybe Text -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a)
-> Route a -> Email -> Maybe Text -> WidgetFor a ()
confirmTemplateDef

  confirmationEmailSentTemplate :: WidgetFor a ()
  confirmationEmailSentTemplate = WidgetFor a ()
forall a. WidgetFor a ()
confirmationEmailSentTemplateDef

  {- | Template to notify user that a confirmation email has been resent.

    @since 1.0.0
  -}
  confirmationEmailResentTemplate :: WidgetFor a ()
  confirmationEmailResentTemplate = WidgetFor a ()
forall a. YesodAuthSimple a => WidgetFor a ()
confirmationEmailSentTemplate

  resetPasswordEmailSentTemplate :: WidgetFor a ()
  resetPasswordEmailSentTemplate = WidgetFor a ()
forall a. WidgetFor a ()
resetPasswordEmailSentTemplateDef

  registerSuccessTemplate :: WidgetFor a ()
  registerSuccessTemplate = WidgetFor a ()
forall a. WidgetFor a ()
registerSuccessTemplateDef

  userExistsTemplate :: WidgetFor a ()
  userExistsTemplate = WidgetFor a ()
forall a. WidgetFor a ()
userExistsTemplateDef

  invalidPasswordTokenTemplate :: Text -> WidgetFor a ()
  invalidPasswordTokenTemplate = Text -> WidgetFor a ()
forall a. Text -> WidgetFor a ()
invalidTokenTemplateDef

  invalidRegistrationTokenTemplate :: Text -> WidgetFor a ()
  invalidRegistrationTokenTemplate = Text -> WidgetFor a ()
forall a. Text -> WidgetFor a ()
invalidTokenTemplateDef

  tooManyLoginAttemptsTemplate :: UTCTime -> WidgetFor a ()
  tooManyLoginAttemptsTemplate = UTCTime -> WidgetFor a ()
forall a. UTCTime -> WidgetFor a ()
tooManyLoginAttemptsTemplateDef

  setPasswordTemplate ::
       (AuthRoute -> Route a)
    -> Route a
    -> Maybe Text
    -> WidgetFor a ()
  setPasswordTemplate = (AuthRoute -> Route a) -> Route a -> Maybe Text -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a) -> Route a -> Maybe Text -> WidgetFor a ()
setPasswordTemplateDef

  -- | Run after a user successfully changing the user's
  -- password. This is a good time to delete any password reset tokens
  -- for this user.
  onPasswordUpdated :: MonadAuthHandler a m => AuthSimpleId a -> m ()
  onPasswordUpdated AuthSimpleId a
_ = Html -> m ()
forall (m :: * -> *). MonadHandler m => Html -> m ()
setMessage Html
"Password has been updated"

  -- | Action called when a bot is detected
  onBotPost :: MonadAuthHandler a m => m ()
  onBotPost = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- | Provide suitable constructor e.g. `RuleBased 8`
  passwordCheck :: PasswordCheck
  passwordCheck = Strength -> Vector Text -> PasswordCheck
Zxcvbn Strength
PW.Safe Vector Text
forall a. Vector a
Vec.empty

-- | This instance of AuthPlugin for inserting into `authPlugins` of YesodAuth
authSimple :: YesodAuthSimple m => AuthPlugin m
authSimple :: AuthPlugin m
authSimple = Text
-> (Text -> Texts -> AuthHandler m TypedContent)
-> ((AuthRoute -> Route m) -> WidgetFor m ())
-> AuthPlugin m
forall master.
Text
-> (Text -> Texts -> AuthHandler master TypedContent)
-> ((AuthRoute -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
"simple" Text -> Texts -> AuthHandler m TypedContent
forall a.
YesodAuthSimple a =>
Text -> Texts -> AuthHandler a TypedContent
dispatch (AuthRoute -> Route m) -> WidgetFor m ()
forall a. (AuthRoute -> Route a) -> WidgetFor a ()
loginHandlerRedirect

loginHandlerRedirect :: (Route Auth -> Route a) -> WidgetFor a ()
loginHandlerRedirect :: (AuthRoute -> Route a) -> WidgetFor a ()
loginHandlerRedirect AuthRoute -> Route a
tm = Route a -> WidgetFor a ()
forall a. Route a -> WidgetFor a ()
redirectTemplate (Route a -> WidgetFor a ()) -> Route a -> WidgetFor a ()
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tm AuthRoute
loginR

dispatch :: YesodAuthSimple a => Text -> [Text] -> AuthHandler a TypedContent
dispatch :: Text -> Texts -> AuthHandler a TypedContent
dispatch Text
method Texts
path = case (Text
method, Texts
path) of
  (Text
"GET",  [Text
"register"])                  -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getRegisterR
  (Text
"POST", [Text
"register"])                  -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
postRegisterR
  (Text
"GET",  [Text
"confirm", Text
token])            -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr (m TypedContent -> m TypedContent)
-> m TypedContent -> m TypedContent
forall a b. (a -> b) -> a -> b
$ Text -> AuthHandler a TypedContent
forall a. Text -> AuthHandler a TypedContent
getConfirmTokenR Text
token
  (Text
"GET",  [Text
"confirm"])                   -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getConfirmR
  (Text
"POST", [Text
"confirm"])                   -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
postConfirmR
  (Text
"GET",  [Text
"confirmation-email-sent"])   -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getConfirmationEmailSentR
  -- @since 1.0.0
  (Text
"GET",  [Text
"confirmation-email-resent"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getConfirmationEmailResentR
  (Text
"GET",  [Text
"register-success"])          -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. AuthHandler a TypedContent
getRegisterSuccessR
  (Text
"GET",  [Text
"user-exists"])               -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getUserExistsR
  (Text
"GET",  [Text
"login"])                     -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getLoginR
  (Text
"POST", [Text
"login"])                     -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
postLoginR
  (Text
"GET",  [Text
"set-password", Text
token])       -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr (m TypedContent -> m TypedContent)
-> m TypedContent -> m TypedContent
forall a b. (a -> b) -> a -> b
$ Text -> AuthHandler a TypedContent
forall a. Text -> AuthHandler a TypedContent
getSetPasswordTokenR Text
token
  (Text
"GET",  [Text
"set-password"])              -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getSetPasswordR
  (Text
"POST", [Text
"set-password"])              -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
postSetPasswordR
  (Text
"GET",  [Text
"reset-password"])            -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getResetPasswordR
  (Text
"POST", [Text
"reset-password"])            -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
postResetPasswordR
  (Text
"GET",  [Text
"reset-password-email-sent"]) -> m TypedContent -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
getResetPasswordEmailSentR
  -- NB: We use a POST instead of GET so that we don't send the password
  -- in the URL query string
  (Text
"POST", [Text
"password-strength"])         -> m Value -> m TypedContent
forall (m :: * -> *) c b.
(MonadHandler m, ToTypedContent c) =>
m c -> m b
sr m Value
forall a. YesodAuthSimple a => AuthHandler a Value
postPasswordStrengthR
  (Text, Texts)
_                                       -> m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
notFound
  where sr :: m c -> m b
sr m c
r = m c
r m c -> (c -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= c -> m b
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse

-- | Registration page
getRegisterR :: YesodAuthSimple a => AuthHandler a TypedContent
getRegisterR :: AuthHandler a TypedContent
getRegisterR = do
  Maybe Text
mErr <- m (Maybe Text)
forall a. AuthHandler a (Maybe Text)
getError
  Maybe (AuthId a)
muid <- m (Maybe (AuthId a))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
maybeAuthId
  AuthRoute -> Route a
tp   <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
  case Maybe (AuthId a)
muid of
    Maybe (AuthId a)
Nothing -> Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
      Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Register a new account"
      (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
registerTemplate AuthRoute -> Route a
tp Maybe Text
mErr
    Just AuthId a
_ -> Text -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Text -> m TypedContent) -> Text -> m TypedContent
forall a b. (a -> b) -> a -> b
$ String -> Text
forall s. PathPiece s => s -> Text
toPathPiece (String
"/" :: String)

-- | Reset password page
getResetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent
getResetPasswordR :: AuthHandler a TypedContent
getResetPasswordR = do
  Maybe Text
mErr <- m (Maybe Text)
forall a. AuthHandler a (Maybe Text)
getError
  AuthRoute -> Route a
tp   <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
  Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
    Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Reset password"
    (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
resetPasswordTemplate AuthRoute -> Route a
tp Maybe Text
mErr

-- | Login page
getLoginR :: YesodAuthSimple a => AuthHandler a TypedContent
getLoginR :: AuthHandler a TypedContent
getLoginR = do
  Maybe Text
mErr <- m (Maybe Text)
forall a. AuthHandler a (Maybe Text)
getError
  Maybe Text
mEmail <- m (Maybe Text)
forall a. AuthHandler a (Maybe Text)
getEmail
  Maybe (AuthId a)
muid <- m (Maybe (AuthId a))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
maybeAuthId
  AuthRoute -> Route a
tp   <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
  case Maybe (AuthId a)
muid of
    Maybe (AuthId a)
Nothing -> Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
      Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Login"
      (AuthRoute -> Route a)
-> Maybe Text -> Maybe Text -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a)
-> Maybe Text -> Maybe Text -> WidgetFor a ()
loginTemplate AuthRoute -> Route a
tp Maybe Text
mErr Maybe Text
mEmail
    Just AuthId a
_ -> Text -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Text -> m TypedContent) -> Text -> m TypedContent
forall a b. (a -> b) -> a -> b
$ String -> Text
forall s. PathPiece s => s -> Text
toPathPiece (String
"/" :: String)

-- | Name for a password-reset token to store in cookies
-- see getSetPasswordTokenR for motivation
-- `yas` is short for Yesod Auth Simple :)
passwordTokenSessionKey :: Text
passwordTokenSessionKey :: Text
passwordTokenSessionKey = Text
"yas-set-password-token"

-- | Another key for registration tokens
registrationTokenSessionKey :: Text
registrationTokenSessionKey :: Text
registrationTokenSessionKey = Text
"yas-registration-token"

genToken :: IO ByteString
genToken :: IO ByteString
genToken = Int -> IO ByteString
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
24

-- | Hashes input via SHA256 and returns the hash encoded as base64 text
hashAndEncodeToken :: ByteString -> Text
hashAndEncodeToken :: ByteString -> Text
hashAndEncodeToken ByteString
bs = ByteString -> Text
forall textual binary. Utf8 textual binary => binary -> textual
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
B64.encode
               (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (ByteString -> Digest SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
C.hash ByteString
bs :: Digest SHA256)

-- | encode to base64url form
encodeToken :: ByteString -> Text
encodeToken :: ByteString -> Text
encodeToken = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
B64Url.encode

-- | Decode from base64url. Lenient decoding because this is random
-- input from the user and not all valid utf8 is valid base64
decodeToken :: Text -> ByteString
decodeToken :: Text -> ByteString
decodeToken = ByteString -> ByteString
B64Url.decodeLenient (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8

-- | Lookup and verify registration token
verifyRegisterTokenFromSession :: YesodAuthSimple a
  => AuthHandler a (Maybe Email)
verifyRegisterTokenFromSession :: AuthHandler a (Maybe Email)
verifyRegisterTokenFromSession =
  m (Maybe Email)
-> (Text -> m (Maybe Email)) -> Maybe Text -> m (Maybe Email)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Email -> m (Maybe Email)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Email
forall a. Maybe a
Nothing) Text -> m (Maybe Email)
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Text -> m (Maybe Email)
matchRegistrationToken
    (Maybe Text -> m (Maybe Email))
-> m (Maybe Text) -> m (Maybe Email)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
registrationTokenSessionKey

-- | Lookup and verify password token
verifyPasswordTokenFromSession :: YesodAuthSimple a
                               => AuthHandler a (Maybe (AuthSimpleId a))
verifyPasswordTokenFromSession :: AuthHandler a (Maybe (AuthSimpleId a))
verifyPasswordTokenFromSession =
  m (Maybe (AuthSimpleId a))
-> (Text -> m (Maybe (AuthSimpleId a)))
-> Maybe Text
-> m (Maybe (AuthSimpleId a))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (AuthSimpleId a) -> m (Maybe (AuthSimpleId a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (AuthSimpleId a)
forall a. Maybe a
Nothing) Text -> m (Maybe (AuthSimpleId a))
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Text -> m (Maybe (AuthSimpleId a))
matchPasswordToken
    (Maybe Text -> m (Maybe (AuthSimpleId a)))
-> m (Maybe Text) -> m (Maybe (AuthSimpleId a))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
passwordTokenSessionKey

-- | Delete registration token from cookie and maybe callback
markRegisterTokenAsUsed :: YesodAuthSimple a => Maybe Email -> AuthHandler a ()
markRegisterTokenAsUsed :: Maybe Email -> AuthHandler a ()
markRegisterTokenAsUsed Maybe Email
mEmail = do
  Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
registrationTokenSessionKey
  case Maybe Email
mEmail of
    Just Email
email -> Email -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> m ()
onRegistrationTokenUsed Email
email
    Maybe Email
_          -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Accept registration form and send a verification link
postRegisterR :: YesodAuthSimple a => AuthHandler a TypedContent
postRegisterR :: AuthHandler a TypedContent
postRegisterR = do
  m ()
forall a. AuthHandler a ()
clearError
  (Maybe Text
honeypot, Text
email) <- FormInput m (Maybe Text, Text) -> m (Maybe Text, Text)
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost (FormInput m (Maybe Text, Text) -> m (Maybe Text, Text))
-> FormInput m (Maybe Text, Text) -> m (Maybe Text, Text)
forall a b. (a -> b) -> a -> b
$ (,)
                      (Maybe Text -> Text -> (Maybe Text, Text))
-> FormInput m (Maybe Text)
-> FormInput m (Text -> (Maybe Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Field m Text -> Text -> FormInput m (Maybe Text)
forall (m :: * -> *) a.
Monad m =>
Field m a -> Text -> FormInput m (Maybe a)
iopt Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
honeypotName
                      FormInput m (Text -> (Maybe Text, Text))
-> FormInput m Text -> FormInput m (Maybe Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"email"
  Maybe Email
mEmail <- (Text -> Email) -> Maybe Text -> Maybe Email
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Email
Email (Maybe Text -> Maybe Email) -> m (Maybe Text) -> m (Maybe Email)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> AuthHandler a (Maybe Text)
forall a. Text -> AuthHandler a (Maybe Text)
validateAndNormalizeEmail Text
email
  case Maybe Email
mEmail of
    Maybe Email
_ | Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
honeypot -> do
          m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
m ()
onBotPost
          let msg :: Text
msg = Text
"An unexpected error occurred.\
                    \ Please try again or contact support\
                    \ if the problem persists."
          AuthRoute -> Text -> AuthHandler a TypedContent
forall a. AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError AuthRoute
registerR Text
msg
    Just Email
email' -> do
      Email -> m (Maybe (AuthSimpleId a))
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> m (Maybe (AuthSimpleId a))
getUserId Email
email' m (Maybe (AuthSimpleId a))
-> (Maybe (AuthSimpleId a) -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- User with that email already exists
        Just AuthSimpleId a
_  -> m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
onEmailAlreadyExist
        Maybe (AuthSimpleId a)
Nothing -> do
          AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
          Route a -> Text
renderUrl <- m (Route a -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
          ByteString
rawToken <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
genToken
          let url :: Text
url = Route a -> Text
renderUrl (Route a -> Text) -> (Text -> Route a) -> Text -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. AuthRoute -> Route a
tp (AuthRoute -> Route a) -> (Text -> AuthRoute) -> Text -> Route a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> AuthRoute
confirmTokenR (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
encodeToken ByteString
rawToken
              hashed :: Text
hashed = ByteString -> Text
hashAndEncodeToken ByteString
rawToken
          AuthRoute
route <- AuthRoute -> AuthRoute -> Bool -> AuthRoute
forall a. a -> a -> Bool -> a
bool AuthRoute
confirmationEmailSentR AuthRoute
confirmationEmailResentR
                    (Bool -> AuthRoute) -> m Bool -> m AuthRoute
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Email -> m Bool
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> m Bool
isConfirmationPending Email
email'
          Email -> Text -> Text -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> Text -> Text -> m ()
sendVerifyEmail Email
email' Text
url Text
hashed
          Route a -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route a -> m TypedContent) -> Route a -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tp AuthRoute
route
    Maybe Email
Nothing -> do
      Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
setError Text
"Invalid email address"
      AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
      Route a -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route a -> m TypedContent) -> Route a -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tp AuthRoute
registerR

-- | Accept email and send a password reset link
postResetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent
postResetPasswordR :: AuthHandler a TypedContent
postResetPasswordR = do
  m ()
forall a. AuthHandler a ()
clearError
  Route a -> Text
ur    <- m (Route a -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
  ByteString
token <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
genToken
  Text
email <- FormInput m Text -> m Text
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost (FormInput m Text -> m Text) -> FormInput m Text -> m Text
forall a b. (a -> b) -> a -> b
$ Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"email"
  AuthRoute -> Route a
tp    <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
  let url :: Text
url = Route a -> Text
ur (Route a -> Text) -> (Text -> Route a) -> Text -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. AuthRoute -> Route a
tp (AuthRoute -> Route a) -> (Text -> AuthRoute) -> Text -> Route a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> AuthRoute
setPasswordTokenR (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
encodeToken ByteString
token
      hashed :: Text
hashed = ByteString -> Text
hashAndEncodeToken ByteString
token
  Email -> Text -> Text -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> Text -> Text -> m ()
sendResetPasswordEmail (Text -> Email
Email Text
email) Text
url Text
hashed
  Route a -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route a -> m TypedContent) -> Route a -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tp AuthRoute
resetPasswordEmailSentR

-- | Target URL reached from account confirmation email
-- Move the token into a session cookie and redirect to the
-- token-less URL (in order to avoid referrer leakage). The
-- alternative is to invalidate the token immediately and embed a
-- new one in the html form, but this has worse UX
getConfirmTokenR :: Text -> AuthHandler a TypedContent
getConfirmTokenR :: Text -> AuthHandler a TypedContent
getConfirmTokenR Text
token = do
  Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
registrationTokenSessionKey (Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Text
hashAndEncodeToken (ByteString -> Text) -> (Text -> ByteString) -> Text -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
decodeToken (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
token
  AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
  Route a -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route a -> m TypedContent) -> Route a -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tp AuthRoute
confirmR

-- | Validate registration token and present confirmation screen to continue
-- e.g. include form to set password
getConfirmR :: YesodAuthSimple a => AuthHandler a TypedContent
getConfirmR :: AuthHandler a TypedContent
getConfirmR = do
  Maybe Email
mEmail <- m (Maybe Email)
forall a. YesodAuthSimple a => AuthHandler a (Maybe Email)
verifyRegisterTokenFromSession
  case Maybe Email
mEmail of
    Maybe Email
Nothing -> do
      Maybe Email -> AuthHandler a ()
forall a. YesodAuthSimple a => Maybe Email -> AuthHandler a ()
markRegisterTokenAsUsed Maybe Email
forall a. Maybe a
Nothing
      m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
invalidRegistrationTokenHandler
    Just Email
email ->
      -- If user already registered, redirect to homepage as
      -- authenticated user. Otherwise, keep the token in the cookie
      -- and redirect to the confirm handler, checking and deleting
      -- the token only after the user sets up their password.
      Email -> m (Maybe (AuthSimpleId a))
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> m (Maybe (AuthSimpleId a))
getUserId Email
email m (Maybe (AuthSimpleId a))
-> (Maybe (AuthSimpleId a) -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m TypedContent
-> (AuthSimpleId a -> m TypedContent)
-> Maybe (AuthSimpleId a)
-> m TypedContent
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Email -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuthSimple (HandlerSite m), MonadUnliftIO m,
 SubHandlerSite m ~ Auth) =>
Email -> m TypedContent
doConfirm Email
email) (Email -> AuthSimpleId a -> m TypedContent
forall (m :: * -> *) s.
(YesodAuthSimple (HandlerSite m), MonadHandler m, MonadUnliftIO m,
 PathPiece s, SubHandlerSite m ~ Auth) =>
Email -> s -> m TypedContent
redirectToHome Email
email)
  where
    redirectToHome :: Email -> s -> m TypedContent
redirectToHome Email
email s
uid = do
      Maybe Email -> AuthHandler (HandlerSite m) ()
forall a. YesodAuthSimple a => Maybe Email -> AuthHandler a ()
markRegisterTokenAsUsed (Maybe Email -> AuthHandler (HandlerSite m) ())
-> Maybe Email -> AuthHandler (HandlerSite m) ()
forall a b. (a -> b) -> a -> b
$ Email -> Maybe Email
forall a. a -> Maybe a
Just Email
email
      Creds (HandlerSite m) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect (Creds (HandlerSite m) -> m TypedContent)
-> Creds (HandlerSite m) -> m TypedContent
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [(Text, Text)] -> Creds (HandlerSite m)
forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"simple" (s -> Text
forall s. PathPiece s => s -> Text
toPathPiece s
uid) []
    doConfirm :: Email -> m TypedContent
doConfirm Email
email = do AuthRoute -> Route (HandlerSite m)
tp <- m (AuthRoute -> Route (HandlerSite m))
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
                         Route (HandlerSite m)
-> Email -> AuthHandler (HandlerSite m) TypedContent
forall a.
YesodAuthSimple a =>
Route a -> Email -> AuthHandler a TypedContent
confirmHandler (AuthRoute -> Route (HandlerSite m)
tp AuthRoute
confirmR) Email
email

-- | Response and perhaps explanation for invalid or expired password token
invalidPasswordTokenHandler :: YesodAuthSimple a => AuthHandler a TypedContent
invalidPasswordTokenHandler :: AuthHandler a TypedContent
invalidPasswordTokenHandler = do
  Html
html <- WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m Html) -> WidgetFor a () -> m Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Invalid token"
    Text -> WidgetFor a ()
forall a. YesodAuthSimple a => Text -> WidgetFor a ()
invalidPasswordTokenTemplate Text
invalidPasswordTokenMessage
  let contentType :: [(HeaderName, ByteString)]
contentType = [(HeaderName
"Content-Type", ByteString
"text/html")]
  Html -> Builder
renderHtmlBuilder Html
html
    Builder -> (Builder -> Response) -> Response
forall a b. a -> (a -> b) -> b
& Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
badRequest400 [(HeaderName, ByteString)]
contentType
    Response -> (Response -> m TypedContent) -> m TypedContent
forall a b. a -> (a -> b) -> b
& Response -> m TypedContent
forall (m :: * -> *) b. MonadHandler m => Response -> m b
sendWaiResponse

-- | Response and perhaps explanation for invalid or expired registration token
invalidRegistrationTokenHandler :: YesodAuthSimple a => AuthHandler a TypedContent
invalidRegistrationTokenHandler :: AuthHandler a TypedContent
invalidRegistrationTokenHandler = do
  Html
html <- WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m Html) -> WidgetFor a () -> m Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Invalid token"
    Text -> WidgetFor a ()
forall a. YesodAuthSimple a => Text -> WidgetFor a ()
invalidRegistrationTokenTemplate Text
invalidRegistrationMessage
  let contentType :: [(HeaderName, ByteString)]
contentType = [(HeaderName
"Content-Type", ByteString
"text/html")]
  Html -> Builder
renderHtmlBuilder Html
html
    Builder -> (Builder -> Response) -> Response
forall a b. a -> (a -> b) -> b
& Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
badRequest400 [(HeaderName, ByteString)]
contentType
    Response -> (Response -> m TypedContent) -> m TypedContent
forall a b. a -> (a -> b) -> b
& Response -> m TypedContent
forall (m :: * -> *) b. MonadHandler m => Response -> m b
sendWaiResponse

-- | Next step after email verification, usually to set password
confirmHandler ::
     YesodAuthSimple a
  => Route a
  -> Email
  -> AuthHandler a TypedContent
confirmHandler :: Route a -> Email -> AuthHandler a TypedContent
confirmHandler Route a
registerUrl Email
email = do
  Maybe Text
mErr <- m (Maybe Text)
forall a. AuthHandler a (Maybe Text)
getError
  AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
  Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
    Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Confirm account"
    (AuthRoute -> Route a)
-> Route a -> Email -> Maybe Text -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a)
-> Route a -> Email -> Maybe Text -> WidgetFor a ()
confirmTemplate AuthRoute -> Route a
tp Route a
registerUrl Email
email Maybe Text
mErr

-- | Check registration token again, take password and try to create user
postConfirmR :: YesodAuthSimple a => AuthHandler a TypedContent
postConfirmR :: AuthHandler a TypedContent
postConfirmR = do
  m ()
forall a. AuthHandler a ()
clearError
  Bool
okCsrf <- Text -> m Bool
forall (m :: * -> *). MonadHandler m => Text -> m Bool
hasValidCsrfParamNamed Text
defaultCsrfParamName
  Maybe Email
mEmail <- m (Maybe Email)
forall a. YesodAuthSimple a => AuthHandler a (Maybe Email)
verifyRegisterTokenFromSession
  case Maybe Email
mEmail of
    Maybe Email
_ | Bool -> Bool
not Bool
okCsrf -> AuthRoute -> Text -> AuthHandler a TypedContent
forall a. AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError AuthRoute
confirmR Text
invalidCsrfMessage
    Maybe Email
Nothing -> m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
invalidRegistrationTokenHandler
    Just Email
email -> do
      Text
password <- FormInput m Text -> m Text
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost (FormInput m Text -> m Text) -> FormInput m Text -> m Text
forall a b. (a -> b) -> a -> b
$ Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"password"
      Email -> Pass -> AuthHandler a TypedContent
forall m.
YesodAuthSimple m =>
Email -> Pass -> AuthHandler m TypedContent
createUser Email
email (ByteString -> Pass
Pass (ByteString -> Pass) -> (Text -> ByteString) -> Text -> Pass
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 (Text -> Pass) -> Text -> Pass
forall a b. (a -> b) -> a -> b
$ Text
password)

-- | Create user with valid password and return success page (or redirect)
createUser :: forall m. YesodAuthSimple m
           => Email -> Pass -> AuthHandler m TypedContent
createUser :: Email -> Pass -> AuthHandler m TypedContent
createUser Email
email Pass
password = do
  Either Text Strength
check <- IO (Either Text Strength) -> m (Either Text Strength)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text Strength) -> m (Either Text Strength))
-> IO (Either Text Strength) -> m (Either Text Strength)
forall a b. (a -> b) -> a -> b
$ PasswordStrength -> Either Text Strength
strengthToEither
          (PasswordStrength -> Either Text Strength)
-> IO PasswordStrength -> IO (Either Text Strength)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PasswordCheck -> Pass -> IO PasswordStrength
checkPasswordStrength (YesodAuthSimple m => PasswordCheck
forall a. YesodAuthSimple a => PasswordCheck
passwordCheck @m) Pass
password
  case Either Text Strength
check of
    Left Text
msg -> do
      Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
setError Text
msg
      AuthRoute -> Route m
tp <- m (AuthRoute -> Route m)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
      Route m -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route m -> m TypedContent) -> Route m -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route m
tp AuthRoute
confirmR
    Right Strength
_ -> do
      Maybe Email -> AuthHandler m ()
forall a. YesodAuthSimple a => Maybe Email -> AuthHandler a ()
markRegisterTokenAsUsed (Maybe Email -> AuthHandler m ())
-> Maybe Email -> AuthHandler m ()
forall a b. (a -> b) -> a -> b
$ Email -> Maybe Email
forall a. a -> Maybe a
Just Email
email
      EncryptedPass
encrypted <- IO EncryptedPass -> m EncryptedPass
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EncryptedPass -> m EncryptedPass)
-> IO EncryptedPass -> m EncryptedPass
forall a b. (a -> b) -> a -> b
$ Pass -> IO EncryptedPass
encryptPassIO' Pass
password
      Email -> EncryptedPass -> m (Maybe (AuthSimpleId m))
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> EncryptedPass -> m (Maybe (AuthSimpleId a))
insertUser Email
email EncryptedPass
encrypted m (Maybe (AuthSimpleId m))
-> (Maybe (AuthSimpleId m) -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just AuthSimpleId m
uid -> do
          let creds :: Creds m
creds = Text -> Text -> [(Text, Text)] -> Creds m
forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"simple" (AuthSimpleId m -> Text
forall s. PathPiece s => s -> Text
toPathPiece AuthSimpleId m
uid) []
          Bool -> Creds (HandlerSite m) -> m ()
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Bool -> Creds (HandlerSite m) -> m ()
setCreds Bool
False Creds m
Creds (HandlerSite m)
creds
          m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
onRegisterSuccess
        Maybe (AuthSimpleId m)
Nothing -> do
          AuthRoute -> Route m
tp <- m (AuthRoute -> Route m)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
          Route m -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route m -> m TypedContent) -> Route m -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route m
tp AuthRoute
userExistsR

-- | Confirmation to show after sending verification email
getConfirmationEmailSentR :: YesodAuthSimple a => AuthHandler a TypedContent
getConfirmationEmailSentR :: AuthHandler a TypedContent
getConfirmationEmailSentR = Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
  Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Confirmation email sent"
  WidgetFor a ()
forall a. YesodAuthSimple a => WidgetFor a ()
confirmationEmailSentTemplate

{- | Confirmation to show after resending verification email.

  @since 1.0.0
-}
getConfirmationEmailResentR :: YesodAuthSimple a => AuthHandler a TypedContent
getConfirmationEmailResentR :: AuthHandler a TypedContent
getConfirmationEmailResentR = Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
  Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Confirmation email resent"
  WidgetFor a ()
forall a. YesodAuthSimple a => WidgetFor a ()
confirmationEmailResentTemplate

-- | Confirmation to show after sending password reset email
getResetPasswordEmailSentR :: YesodAuthSimple a => AuthHandler a TypedContent
getResetPasswordEmailSentR :: AuthHandler a TypedContent
getResetPasswordEmailSentR = Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
  Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Reset password email sent"
  WidgetFor a ()
forall a. YesodAuthSimple a => WidgetFor a ()
resetPasswordEmailSentTemplate

-- | Another option for responding on successful registration
getRegisterSuccessR :: AuthHandler a TypedContent
getRegisterSuccessR :: m TypedContent
getRegisterSuccessR = do
  Html -> m ()
forall (m :: * -> *). MonadHandler m => Html -> m ()
setMessage Html
"Account created. Welcome!"
  Text -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Text
"/" :: Text)

-- | Redirected to when `insertUser` does not return UserID
getUserExistsR :: YesodAuthSimple a => AuthHandler a TypedContent
getUserExistsR :: AuthHandler a TypedContent
getUserExistsR = Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
  Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"User already exists"
  WidgetFor a ()
forall a. YesodAuthSimple a => WidgetFor a ()
userExistsTemplate

-- | JSON endpoint for validating password
postPasswordStrengthR :: forall a. (YesodAuthSimple a) => AuthHandler a J.Value
postPasswordStrengthR :: AuthHandler a Value
postPasswordStrengthR = do
  Bool
okCsrf <- Text -> m Bool
forall (m :: * -> *). MonadHandler m => Text -> m Bool
hasValidCsrfParamNamed Text
defaultCsrfParamName
  if Bool -> Bool
not Bool
okCsrf
    then Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> m Value)
-> (PasswordStrength -> Value) -> PasswordStrength -> m Value
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PasswordStrength -> Value
forall a. ToJSON a => a -> Value
toJSON (PasswordStrength -> m Value) -> PasswordStrength -> m Value
forall a b. (a -> b) -> a -> b
$ Strength -> Maybe Text -> PasswordStrength
BadPassword Strength
PW.Risky (Maybe Text -> PasswordStrength) -> Maybe Text -> PasswordStrength
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
invalidCsrfMessage
    else do
      Text
password <- FormInput m Text -> m Text
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost (Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"password")
      let pass :: Pass
pass = ByteString -> Pass
Pass (ByteString -> Pass) -> (Text -> ByteString) -> Text -> Pass
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 (Text -> Pass) -> Text -> Pass
forall a b. (a -> b) -> a -> b
$ Text
password
      IO Value -> m Value
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Value -> m Value) -> IO Value -> m Value
forall a b. (a -> b) -> a -> b
$ PasswordStrength -> Value
forall a. ToJSON a => a -> Value
toJSON (PasswordStrength -> Value) -> IO PasswordStrength -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PasswordCheck -> Pass -> IO PasswordStrength
checkPasswordStrength (YesodAuthSimple a => PasswordCheck
forall a. YesodAuthSimple a => PasswordCheck
passwordCheck @a) Pass
pass

-- | Validate password for given parameters with Zxcvbn library
checkPassWithZxcvbn ::
     PW.Strength
  -> Vector Text
  -> Day
  -> Text
  -> PasswordStrength
checkPassWithZxcvbn :: Strength -> Vector Text -> Day -> Text -> PasswordStrength
checkPassWithZxcvbn Strength
minStrength' Vector Text
extraWords' Day
day Text
password =
  let conf :: Config
conf = Vector Text -> Config -> Config
PW.addCustomFrequencyList Vector Text
extraWords' Config
PW.en_US
      guesses :: Score
guesses = Config -> Day -> Text -> Score
PW.score Config
conf Day
day Text
password
      stren :: Strength
stren = Score -> Strength
PW.strength Score
guesses
  in if Strength
stren Strength -> Strength -> Bool
forall a. Ord a => a -> a -> Bool
>= Strength
minStrength' then Strength -> PasswordStrength
GoodPassword Strength
stren
     else Strength -> Maybe Text -> PasswordStrength
BadPassword Strength
stren (Maybe Text -> PasswordStrength) -> Maybe Text -> PasswordStrength
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"The password is not strong enough"

-- | Validate password with simple length rule
checkPassWithRules :: Int -> Text -> PasswordStrength
checkPassWithRules :: Int -> Text -> PasswordStrength
checkPassWithRules Int
minLen Text
password
  | Text -> Int
T.length Text
password Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minLen = Strength -> PasswordStrength
GoodPassword Strength
PW.Safe
  | Bool
otherwise = Strength -> Maybe Text -> PasswordStrength
BadPassword Strength
PW.Weak (Maybe Text -> PasswordStrength)
-> (String -> Maybe Text) -> String -> PasswordStrength
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> (String -> Text) -> String -> Maybe Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
T.pack
                (String -> PasswordStrength) -> String -> PasswordStrength
forall a b. (a -> b) -> a -> b
$ String
"Password must be at least " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
minLen String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" characters"

strengthToEither :: PasswordStrength -> Either Text PW.Strength
strengthToEither :: PasswordStrength -> Either Text Strength
strengthToEither (GoodPassword Strength
stren) = Strength -> Either Text Strength
forall a b. b -> Either a b
Right Strength
stren
strengthToEither (BadPassword Strength
_ (Just Text
err)) = Text -> Either Text Strength
forall a b. a -> Either a b
Left Text
err
strengthToEither (BadPassword Strength
_ Maybe Text
Nothing) =
  Text -> Either Text Strength
forall a b. a -> Either a b
Left Text
"The password is not strong enough"

getPWStrength :: PasswordStrength -> PW.Strength
getPWStrength :: PasswordStrength -> Strength
getPWStrength (GoodPassword Strength
stren)  = Strength
stren
getPWStrength (BadPassword Strength
stren Maybe Text
_) = Strength
stren

-- | Explain password strength with a given validator
checkPasswordStrength :: PasswordCheck -> Pass -> IO PasswordStrength
checkPasswordStrength :: PasswordCheck -> Pass -> IO PasswordStrength
checkPasswordStrength PasswordCheck
check Pass
pass =
  case ByteString -> Either UnicodeException Text
decodeUtf8' (Pass -> ByteString
getPass Pass
pass) of
    Left UnicodeException
_ -> PasswordStrength -> IO PasswordStrength
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PasswordStrength -> IO PasswordStrength)
-> PasswordStrength -> IO PasswordStrength
forall a b. (a -> b) -> a -> b
$ Strength -> Maybe Text -> PasswordStrength
BadPassword Strength
PW.Weak (Maybe Text -> PasswordStrength) -> Maybe Text -> PasswordStrength
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Invalid characters in password"
    Right Text
password ->
      if Bool -> Bool
not Bool
satisfiesMaxLen
      then PasswordStrength -> IO PasswordStrength
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PasswordStrength -> IO PasswordStrength)
-> (Text -> PasswordStrength) -> Text -> IO PasswordStrength
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Strength -> Maybe Text -> PasswordStrength
BadPassword Strength
PW.Weak (Maybe Text -> PasswordStrength)
-> (Text -> Maybe Text) -> Text -> PasswordStrength
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Maybe Text
forall a. a -> Maybe a
Just
           (Text -> IO PasswordStrength) -> Text -> IO PasswordStrength
forall a b. (a -> b) -> a -> b
$ Text
"Password exceeds maximum length of "
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
maxPasswordLength)
      else case PasswordCheck
check of
        RuleBased Int
minLen ->
          PasswordStrength -> IO PasswordStrength
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PasswordStrength -> IO PasswordStrength)
-> PasswordStrength -> IO PasswordStrength
forall a b. (a -> b) -> a -> b
$ Int -> Text -> PasswordStrength
checkPassWithRules (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
minLen Int
minPasswordLength) Text
password
        Zxcvbn Strength
minStren Vector Text
extraWords' -> do
          Day
today <- UTCTime -> Day
utctDay (UTCTime -> Day) -> IO UTCTime -> IO Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
          let pwstren :: PasswordStrength
pwstren = Strength -> Vector Text -> Day -> Text -> PasswordStrength
checkPassWithZxcvbn Strength
minStren Vector Text
extraWords' Day
today Text
password
          PasswordStrength -> IO PasswordStrength
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PasswordStrength -> IO PasswordStrength)
-> PasswordStrength -> IO PasswordStrength
forall a b. (a -> b) -> a -> b
$
            if Bool
satisfiesMinLen
            then PasswordStrength
pwstren
            -- Although we always prevent passwords below the minimum
            -- length, we do not score it as Weak invariably. This
            -- prevents the password meter from sticking at the lowest
            -- level until after you input a safe password of min length
            else Strength -> Maybe Text -> PasswordStrength
BadPassword (Strength -> Strength -> Strength
forall a. Ord a => a -> a -> a
min (PasswordStrength -> Strength
getPWStrength PasswordStrength
pwstren) (Strength -> Strength
forall a. Enum a => a -> a
pred Strength
minStren))
                 (Maybe Text -> PasswordStrength)
-> (Text -> Maybe Text) -> Text -> PasswordStrength
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> PasswordStrength) -> Text -> PasswordStrength
forall a b. (a -> b) -> a -> b
$ Text
"The password must be at least "
                 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
minPasswordLength) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" characters"
      where (Text
boundedPw, Text
extra) = Int -> Text -> (Text, Text)
T.splitAt Int
maxPasswordLength Text
password
            satisfiesMinLen :: Bool
satisfiesMinLen = Text -> Int
T.length Text
boundedPw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minPasswordLength
            satisfiesMaxLen :: Bool
satisfiesMaxLen = Text -> Bool
T.null Text
extra

normalizeEmail :: Text -> Text
normalizeEmail :: Text -> Text
normalizeEmail = Text -> Text
T.toLower

validateAndNormalizeEmail :: Text -> AuthHandler a (Maybe Text)
validateAndNormalizeEmail :: Text -> AuthHandler a (Maybe Text)
validateAndNormalizeEmail Text
email = case ByteString -> Maybe ByteString
canonicalizeEmail (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 Text
email of
  Just ByteString
bytes ->
      Maybe Text -> m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> m (Maybe Text)) -> Maybe Text -> m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
normalizeEmail (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
bytes
  Maybe ByteString
Nothing -> Maybe Text -> m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing

-- | Session name used for the errors.
errorSessionName :: Text
errorSessionName :: Text
errorSessionName = Text
"yesod-auth-simple-error"

-- | Session name used for the email storage.
emailSessionName :: Text
emailSessionName :: Text
emailSessionName = Text
"yesod-auth-simple-email"

{- | Get the error session (see 'errorSessionName') if present. It also clears
up the session after.
-}
getError :: AuthHandler a (Maybe Text)
getError :: m (Maybe Text)
getError = do
  Maybe Text
mErr <- Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
errorSessionName
  m ()
forall a. AuthHandler a ()
clearError
  Maybe Text -> m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
mErr

-- | Sets up the error session ('errorSessionName') to the given value.
setError :: MonadHandler m => Text -> m ()
setError :: Text -> m ()
setError = Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
errorSessionName

-- | Clears up the error session ('errorSessionName').
clearError :: AuthHandler a ()
clearError :: m ()
clearError = Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
errorSessionName

{- | Get the email session (see 'emailSessionName') if present. It also clears
up the session after.
-}
getEmail :: AuthHandler a (Maybe Text)
getEmail :: m (Maybe Text)
getEmail = do
  Maybe Text
mEmail <- Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
emailSessionName
  m ()
forall a. AuthHandler a ()
clearEmail
  Maybe Text -> m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
mEmail

-- | Sets up the email session ('emailSessionName') to the given value.
setEmail :: MonadHandler m => Text -> m ()
setEmail :: Text -> m ()
setEmail = Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
emailSessionName

-- | Clears up the email session ('emailSessionName').
clearEmail :: AuthHandler a ()
clearEmail :: m ()
clearEmail = Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
emailSessionName

-- | Accept login form, check attempts limit and authenticate or redirect user
postLoginR :: YesodAuthSimple a => AuthHandler a TypedContent
postLoginR :: AuthHandler a TypedContent
postLoginR = do
  m ()
forall a. AuthHandler a ()
clearError
  m ()
forall a. AuthHandler a ()
clearEmail
  Bool
okCsrf <- Text -> m Bool
forall (m :: * -> *). MonadHandler m => Text -> m Bool
hasValidCsrfParamNamed Text
defaultCsrfParamName
  if Bool -> Bool
not Bool
okCsrf
    then AuthRoute -> Text -> AuthHandler a TypedContent
forall a. AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError AuthRoute
loginR Text
invalidCsrfMessage
    else do
      (Text
email, Text
password') <- FormInput m (Text, Text) -> m (Text, Text)
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost (FormInput m (Text, Text) -> m (Text, Text))
-> FormInput m (Text, Text) -> m (Text, Text)
forall a b. (a -> b) -> a -> b
$ (,)
        (Text -> Text -> (Text, Text))
-> FormInput m Text -> FormInput m (Text -> (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"email"
        FormInput m (Text -> (Text, Text))
-> FormInput m Text -> FormInput m (Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"password"
      Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
setEmail Text
email
      let password :: Pass
password = ByteString -> Pass
Pass (ByteString -> Pass) -> (Text -> ByteString) -> Text -> Pass
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 (Text -> Pass) -> Text -> Pass
forall a b. (a -> b) -> a -> b
$ Text
password'
      Maybe (AuthSimpleId a)
mUid <- Email -> m (Maybe (AuthSimpleId a))
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Email -> m (Maybe (AuthSimpleId a))
getUserId (Text -> Email
Email Text
email)
      Maybe UTCTime
mLockedOut <- Maybe (AuthSimpleId a) -> m (Maybe UTCTime)
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Maybe (AuthSimpleId a) -> m (Maybe UTCTime)
shouldPreventLoginAttempt Maybe (AuthSimpleId a)
mUid
      case (Maybe UTCTime
mLockedOut, Maybe (AuthSimpleId a)
mUid) of
        (Just UTCTime
expires, Maybe (AuthSimpleId a)
_) -> UTCTime -> AuthHandler a TypedContent
forall a.
YesodAuthSimple a =>
UTCTime -> AuthHandler a TypedContent
tooManyLoginAttemptsHandler UTCTime
expires
        (Maybe UTCTime
_, Just AuthSimpleId a
uid) -> do
          EncryptedPass
storedPassword <- AuthSimpleId a -> m EncryptedPass
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
AuthSimpleId a -> m EncryptedPass
getUserPassword AuthSimpleId a
uid
          if Pass -> EncryptedPass -> Bool
verifyPass' Pass
password EncryptedPass
storedPassword
            then do
              Maybe (AuthSimpleId a) -> Bool -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Maybe (AuthSimpleId a) -> Bool -> m ()
onLoginAttempt (AuthSimpleId a -> Maybe (AuthSimpleId a)
forall a. a -> Maybe a
Just AuthSimpleId a
uid) Bool
True
              Creds (HandlerSite m) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect (Creds (HandlerSite m) -> m TypedContent)
-> Creds (HandlerSite m) -> m TypedContent
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [(Text, Text)] -> Creds a
forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"simple" (AuthSimpleId a -> Text
forall s. PathPiece s => s -> Text
toPathPiece AuthSimpleId a
uid) []
            else do
              Maybe (AuthSimpleId a) -> Bool -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Maybe (AuthSimpleId a) -> Bool -> m ()
onLoginAttempt (AuthSimpleId a -> Maybe (AuthSimpleId a)
forall a. a -> Maybe a
Just AuthSimpleId a
uid) Bool
False
              m TypedContent
forall a. AuthHandler a TypedContent
wrongEmailOrPasswordRedirect
        (Maybe UTCTime, Maybe (AuthSimpleId a))
_ -> do
          Maybe (AuthSimpleId a) -> Bool -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
Maybe (AuthSimpleId a) -> Bool -> m ()
onLoginAttempt Maybe (AuthSimpleId a)
forall a. Maybe a
Nothing Bool
False
          m TypedContent
forall a. AuthHandler a TypedContent
wrongEmailOrPasswordRedirect

tooManyLoginAttemptsHandler ::
     YesodAuthSimple a
  => UTCTime
  -> AuthHandler a TypedContent
tooManyLoginAttemptsHandler :: UTCTime -> AuthHandler a TypedContent
tooManyLoginAttemptsHandler UTCTime
expires = do
  Html
html <- WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m Html) -> WidgetFor a () -> m Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Too many login attempts"
    UTCTime -> WidgetFor a ()
forall a. YesodAuthSimple a => UTCTime -> WidgetFor a ()
tooManyLoginAttemptsTemplate UTCTime
expires
  let contentType :: [(HeaderName, ByteString)]
contentType = [(HeaderName
"Content-Type", ByteString
"text/html")]
  Html -> Builder
renderHtmlBuilder Html
html
    Builder -> (Builder -> Response) -> Response
forall a b. a -> (a -> b) -> b
& Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
tooManyRequests429 [(HeaderName, ByteString)]
contentType
    Response -> (Response -> m TypedContent) -> m TypedContent
forall a b. a -> (a -> b) -> b
& Response -> m TypedContent
forall (m :: * -> *) b. MonadHandler m => Response -> m b
sendWaiResponse

redirectTo :: AuthRoute -> AuthHandler a b
redirectTo :: AuthRoute -> AuthHandler a b
redirectTo AuthRoute
route = do
  AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
  Route a -> m b
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route a -> m b) -> Route a -> m b
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tp AuthRoute
route

redirectWithError :: AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError :: AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError AuthRoute
route Text
err = do
  Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
setError Text
err
  AuthRoute -> AuthHandler a TypedContent
forall a b. AuthRoute -> AuthHandler a b
redirectTo AuthRoute
route

wrongEmailOrPasswordRedirect :: AuthHandler a TypedContent
wrongEmailOrPasswordRedirect :: m TypedContent
wrongEmailOrPasswordRedirect =
  AuthRoute -> Text -> AuthHandler a TypedContent
forall a. AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError AuthRoute
loginR Text
"Wrong email or password"

invalidCsrfMessage :: Text
invalidCsrfMessage :: Text
invalidCsrfMessage =
  Text
"Invalid anti-forgery token. \
  \Please try again in a new browser tab or window. \
  \Contact support if the problem persists."

invalidRegistrationMessage :: Text
invalidRegistrationMessage :: Text
invalidRegistrationMessage =
  Text
"Invalid registration link. \
  \Please try registering again and contact support if the problem persists"

invalidPasswordTokenMessage :: Text
invalidPasswordTokenMessage :: Text
invalidPasswordTokenMessage =
  Text
"Invalid password reset token. \
  \Please try again and contact support if the problem persists."

-- | Target URL reached from password reset email
-- Move the token into a session cookie and redirect to the
-- token-less URL (in order to avoid referrer leakage). The
-- alternative is to invalidate the token immediately and embed a
-- new one in the html form, but this has worse UX
getSetPasswordTokenR :: Text -> AuthHandler a TypedContent
getSetPasswordTokenR :: Text -> AuthHandler a TypedContent
getSetPasswordTokenR Text
token = do
  Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
passwordTokenSessionKey (Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Text
hashAndEncodeToken (ByteString -> Text) -> (Text -> ByteString) -> Text -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
decodeToken (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
token
  AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
  Route a -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route a -> m TypedContent) -> Route a -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tp AuthRoute
setPasswordR

-- | Validate password token and prompt for new password
getSetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent
getSetPasswordR :: AuthHandler a TypedContent
getSetPasswordR = do
  Maybe (AuthSimpleId a)
mUid <- m (Maybe (AuthSimpleId a))
forall a.
YesodAuthSimple a =>
AuthHandler a (Maybe (AuthSimpleId a))
verifyPasswordTokenFromSession
  case Maybe (AuthSimpleId a)
mUid of
    Maybe (AuthSimpleId a)
Nothing -> m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
invalidPasswordTokenHandler
    Just AuthSimpleId a
_ -> do
      AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
      Maybe Text
mErr <- m (Maybe Text)
forall a. AuthHandler a (Maybe Text)
getError
      Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor a () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor a ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor a () -> m Html)
-> WidgetFor a ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor a () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor a () -> m TypedContent)
-> WidgetFor a () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
        Html -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Set password"
        (AuthRoute -> Route a) -> Route a -> Maybe Text -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a) -> Route a -> Maybe Text -> WidgetFor a ()
setPasswordTemplate AuthRoute -> Route a
tp (AuthRoute -> Route a
tp AuthRoute
setPasswordR) Maybe Text
mErr

-- | Set a new password for the user
postSetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent
postSetPasswordR :: AuthHandler a TypedContent
postSetPasswordR = do
  m ()
forall a. AuthHandler a ()
clearError
  Bool
okCsrf <- Text -> m Bool
forall (m :: * -> *). MonadHandler m => Text -> m Bool
hasValidCsrfParamNamed Text
defaultCsrfParamName
  Maybe (AuthSimpleId a)
mUid <- m (Maybe (AuthSimpleId a))
forall a.
YesodAuthSimple a =>
AuthHandler a (Maybe (AuthSimpleId a))
verifyPasswordTokenFromSession
  case Maybe (AuthSimpleId a)
mUid of
    Maybe (AuthSimpleId a)
_ | Bool -> Bool
not Bool
okCsrf -> AuthRoute -> Text -> AuthHandler a TypedContent
forall a. AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError AuthRoute
setPasswordR Text
invalidCsrfMessage
    Maybe (AuthSimpleId a)
Nothing -> do
      Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
passwordTokenSessionKey
      m TypedContent
forall a. YesodAuthSimple a => AuthHandler a TypedContent
invalidPasswordTokenHandler
    Just AuthSimpleId a
uid -> do
      Text
password <- FormInput m Text -> m Text
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost (FormInput m Text -> m Text) -> FormInput m Text -> m Text
forall a b. (a -> b) -> a -> b
$ Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"password"
      AuthSimpleId a -> Pass -> AuthHandler a TypedContent
forall a.
YesodAuthSimple a =>
AuthSimpleId a -> Pass -> AuthHandler a TypedContent
setPass AuthSimpleId a
uid (ByteString -> Pass
Pass (ByteString -> Pass) -> (Text -> ByteString) -> Text -> Pass
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 (Text -> Pass) -> Text -> Pass
forall a b. (a -> b) -> a -> b
$ Text
password)

-- | Check and update password, callback, then redirect to user page
setPass :: forall a. YesodAuthSimple a
  => AuthSimpleId a
  -> Pass
  -> AuthHandler a TypedContent
setPass :: AuthSimpleId a -> Pass -> AuthHandler a TypedContent
setPass AuthSimpleId a
uid Pass
password = do
  Either Text Strength
check <- IO (Either Text Strength) -> m (Either Text Strength)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text Strength) -> m (Either Text Strength))
-> IO (Either Text Strength) -> m (Either Text Strength)
forall a b. (a -> b) -> a -> b
$ PasswordStrength -> Either Text Strength
strengthToEither
          (PasswordStrength -> Either Text Strength)
-> IO PasswordStrength -> IO (Either Text Strength)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PasswordCheck -> Pass -> IO PasswordStrength
checkPasswordStrength (YesodAuthSimple a => PasswordCheck
forall a. YesodAuthSimple a => PasswordCheck
passwordCheck @a) Pass
password
  case Either Text Strength
check of
    Left Text
msg -> do
      Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
setError Text
msg
      AuthRoute -> Route a
tp <- m (AuthRoute -> Route a)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
      Route a -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (Route a -> m TypedContent) -> Route a -> m TypedContent
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route a
tp AuthRoute
setPasswordR
    Right Strength
_ -> do
      EncryptedPass
encrypted <- IO EncryptedPass -> m EncryptedPass
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EncryptedPass -> m EncryptedPass)
-> IO EncryptedPass -> m EncryptedPass
forall a b. (a -> b) -> a -> b
$ Pass -> IO EncryptedPass
encryptPassIO' Pass
password
      ()
_         <- AuthSimpleId a -> EncryptedPass -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
AuthSimpleId a -> EncryptedPass -> m ()
updateUserPassword AuthSimpleId a
uid EncryptedPass
encrypted
      AuthSimpleId a -> m ()
forall a (m :: * -> *).
(YesodAuthSimple a, MonadAuthHandler a m) =>
AuthSimpleId a -> m ()
onPasswordUpdated AuthSimpleId a
uid
      Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
passwordTokenSessionKey
      Creds (HandlerSite m) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect (Creds (HandlerSite m) -> m TypedContent)
-> Creds (HandlerSite m) -> m TypedContent
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [(Text, Text)] -> Creds a
forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"simple" (AuthSimpleId a -> Text
forall s. PathPiece s => s -> Text
toPathPiece AuthSimpleId a
uid) []

redirectTemplate :: Route a -> WidgetFor a ()
redirectTemplate :: Route a -> WidgetFor a ()
redirectTemplate Route a
destUrl = do
  WidgetFor a () -> WidgetFor a ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget $(whamletFile "templates/redirect.hamlet")
  JavascriptUrl (Route a) -> WidgetFor a ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [julius|window.location = "@{destUrl}";|]

csrfTokenTemplate :: WidgetFor a ()
csrfTokenTemplate :: WidgetFor a ()
csrfTokenTemplate = do
  YesodRequest
request <- WidgetFor a YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
  $(whamletFile "templates/csrf-token.hamlet")

loginTemplateDef ::
     (AuthRoute -> Route a)
  -> Maybe Text
  -> Maybe Text
  -> WidgetFor a ()
loginTemplateDef :: (AuthRoute -> Route a)
-> Maybe Text -> Maybe Text -> WidgetFor a ()
loginTemplateDef AuthRoute -> Route a
toParent Maybe Text
mErr Maybe Text
mEmail = $(whamletFile "templates/login.hamlet")

passwordFieldTemplateBasic :: WidgetFor a ()
passwordFieldTemplateBasic :: WidgetFor a ()
passwordFieldTemplateBasic =
  $(whamletFile "templates/password-field-basic.hamlet")

zxcvbnJsUrl :: Text
zxcvbnJsUrl :: Text
zxcvbnJsUrl = Text
"https://cdn.jsdelivr.net/npm/zxcvbn@4.4.2/dist/zxcvbn.js"

passwordFieldTemplateZxcvbn ::
     (AuthRoute -> Route a)
  -> PW.Strength
  -> Vector Text
  -> WidgetFor a ()
passwordFieldTemplateZxcvbn :: (AuthRoute -> Route a) -> Strength -> Vector Text -> WidgetFor a ()
passwordFieldTemplateZxcvbn AuthRoute -> Route a
toParent Strength
minStren Vector Text
extraWords' = do
  let extraWordsStr :: Text
extraWordsStr = Texts -> Text
T.unwords (Texts -> Text) -> (Vector Text -> Texts) -> Vector Text -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Vector Text -> Texts
forall mono. MonoFoldable mono => mono -> [Element mono]
toList (Vector Text -> Text) -> Vector Text -> Text
forall a b. (a -> b) -> a -> b
$ Vector Text
extraWords'
      blankPasswordScore :: PasswordStrength
blankPasswordScore = Strength -> Maybe Text -> PasswordStrength
BadPassword Strength
PW.Risky Maybe Text
forall a. Maybe a
Nothing
  Maybe Text
mCsrfToken <- YesodRequest -> Maybe Text
reqToken (YesodRequest -> Maybe Text)
-> WidgetFor a YesodRequest -> WidgetFor a (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WidgetFor a YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
  Text -> WidgetFor a ()
forall (m :: * -> *). MonadWidget m => Text -> m ()
addScriptRemote Text
zxcvbnJsUrl
  (RY a -> Html) -> WidgetFor a ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget $(hamletFile "templates/password-field-zxcvbn.hamlet")
  (RY a -> Css) -> WidgetFor a ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget $(luciusFile "templates/password-field-zxcvbn.lucius")
  JavascriptUrl (Route a) -> WidgetFor a ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget $(juliusFile "templates/password-field-zxcvbn.julius")

setPasswordTemplateDef ::
     forall a. YesodAuthSimple a
  => (AuthRoute -> Route a)
  -> Route a
  -> Maybe Text
  -> WidgetFor a ()
setPasswordTemplateDef :: (AuthRoute -> Route a) -> Route a -> Maybe Text -> WidgetFor a ()
setPasswordTemplateDef AuthRoute -> Route a
toParent Route a
url Maybe Text
mErr =
  let pwField :: WidgetFor a ()
pwField = (AuthRoute -> Route a) -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a) -> WidgetFor a ()
passwordFieldTemplate @a AuthRoute -> Route a
toParent
   in $(whamletFile "templates/set-password.hamlet")

invalidTokenTemplateDef :: Text -> WidgetFor a ()
invalidTokenTemplateDef :: Text -> WidgetFor a ()
invalidTokenTemplateDef Text
msg = $(whamletFile "templates/invalid-token.hamlet")

tooManyLoginAttemptsTemplateDef :: UTCTime -> WidgetFor a ()
tooManyLoginAttemptsTemplateDef :: UTCTime -> WidgetFor a ()
tooManyLoginAttemptsTemplateDef UTCTime
expires =
  let formatted :: String
formatted = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%d/%m/%_Y %T" UTCTime
expires
   in $(whamletFile "templates/too-many-login-attempts.hamlet")

userExistsTemplateDef :: WidgetFor a ()
userExistsTemplateDef :: WidgetFor a ()
userExistsTemplateDef = $(whamletFile "templates/user-exists.hamlet")

registerSuccessTemplateDef :: WidgetFor a ()
registerSuccessTemplateDef :: WidgetFor a ()
registerSuccessTemplateDef = $(whamletFile "templates/register-success.hamlet")

resetPasswordEmailSentTemplateDef :: WidgetFor a ()
resetPasswordEmailSentTemplateDef :: WidgetFor a ()
resetPasswordEmailSentTemplateDef =
  $(whamletFile "templates/reset-password-email-sent.hamlet")

confirmationEmailSentTemplateDef :: WidgetFor a ()
confirmationEmailSentTemplateDef :: WidgetFor a ()
confirmationEmailSentTemplateDef =
  $(whamletFile "templates/confirmation-email-sent.hamlet")

confirmTemplateDef ::
     forall a. YesodAuthSimple a
  => (AuthRoute -> Route a)
  -> Route a
  -> Email
  -> Maybe Text
  -> WidgetFor a ()
confirmTemplateDef :: (AuthRoute -> Route a)
-> Route a -> Email -> Maybe Text -> WidgetFor a ()
confirmTemplateDef AuthRoute -> Route a
toParent Route a
confirmUrl (Email Text
email) Maybe Text
mErr =
  let pwField :: WidgetFor a ()
pwField = (AuthRoute -> Route a) -> WidgetFor a ()
forall a.
YesodAuthSimple a =>
(AuthRoute -> Route a) -> WidgetFor a ()
passwordFieldTemplate @a AuthRoute -> Route a
toParent
   in $(whamletFile "templates/confirm.hamlet")

resetPasswordTemplateDef ::
     (AuthRoute -> Route a)
  -> Maybe Text
  -> WidgetFor a ()
resetPasswordTemplateDef :: (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
resetPasswordTemplateDef AuthRoute -> Route a
toParent Maybe Text
mErr =
  $(whamletFile "templates/reset-password.hamlet")

honeypotName :: Text
honeypotName :: Text
honeypotName = Text
"yas-password-backup"

honeypotFieldTemplate :: WidgetFor a ()
honeypotFieldTemplate :: WidgetFor a ()
honeypotFieldTemplate = do
  (RY a -> Css) -> WidgetFor a ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [lucius| .#{honeypotName} { display:none !important; } |]
  (RY a -> Html) -> WidgetFor a ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget $(hamletFile "templates/honeypot-field.hamlet")

registerTemplateDef :: (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
registerTemplateDef :: (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
registerTemplateDef AuthRoute -> Route a
toParent Maybe Text
mErr = $(whamletFile "templates/register.hamlet")