{-# 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 = 8 -- min length required in NIST SP 800-63B
maxPasswordLength :: Int
maxPasswordLength = 150 -- zxcvbn takes too long after this point
confirmTokenR :: Text -> AuthRoute
confirmTokenR token = PluginR "simple" ["confirm", token]
confirmR :: AuthRoute
confirmR = PluginR "simple" ["confirm"]
confirmationEmailSentR :: AuthRoute
confirmationEmailSentR = PluginR "simple" ["confirmation-email-sent"]
confirmationEmailResentR :: AuthRoute
confirmationEmailResentR = PluginR "simple" ["confirmation-email-resent"]
loginR :: AuthRoute
loginR = PluginR "simple" ["login"]
registerR :: AuthRoute
registerR = PluginR "simple" ["register"]
registerSuccessR :: AuthRoute
registerSuccessR = PluginR "simple" ["register-success"]
resetPasswordEmailSentR :: AuthRoute
resetPasswordEmailSentR = PluginR "simple" ["reset-password-email-sent"]
resetPasswordR :: AuthRoute
resetPasswordR = PluginR "simple" ["reset-password"]
setPasswordR :: AuthRoute
setPasswordR = PluginR "simple" ["set-password"]
setPasswordTokenR :: Text -> AuthRoute
setPasswordTokenR token = PluginR "simple" ["set-password", token]
userExistsR :: AuthRoute
userExistsR = PluginR "simple" ["user-exists"]
passwordStrengthR :: AuthRoute
passwordStrengthR = PluginR "simple" ["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 _ = pure 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 _ _ = 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 _ url _ = liftIO . print $ url
-- | Like 'sendVerifyEmail' but for password resets.
sendResetPasswordEmail :: MonadAuthHandler a m => Email -> VerUrl -> Text -> m ()
sendResetPasswordEmail _ url _ = liftIO . print $ 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 _ = pure 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 _ = 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 = "This email address is already in use. Please login to your existing account."
redirectWithError registerR msg
-- | Password field widget for a chosen PasswordCheck algorithm
passwordFieldTemplate :: (AuthRoute -> Route a) -> WidgetFor a ()
passwordFieldTemplate tp =
case passwordCheck @a of
Zxcvbn minStren extraWords' ->
passwordFieldTemplateZxcvbn tp minStren extraWords'
RuleBased _ -> 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 = loginTemplateDef
registerTemplate :: (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
registerTemplate = registerTemplateDef
resetPasswordTemplate ::
(AuthRoute -> Route a)
-> Maybe Text
-> WidgetFor a ()
resetPasswordTemplate = resetPasswordTemplateDef
confirmTemplate ::
(AuthRoute -> Route a)
-> Route a
-> Email
-> Maybe Text
-> WidgetFor a ()
confirmTemplate = confirmTemplateDef
confirmationEmailSentTemplate :: WidgetFor a ()
confirmationEmailSentTemplate = confirmationEmailSentTemplateDef
{- | Template to notify user that a confirmation email has been resent.
@since 1.0.0
-}
confirmationEmailResentTemplate :: WidgetFor a ()
confirmationEmailResentTemplate = confirmationEmailSentTemplate
resetPasswordEmailSentTemplate :: WidgetFor a ()
resetPasswordEmailSentTemplate = resetPasswordEmailSentTemplateDef
registerSuccessTemplate :: WidgetFor a ()
registerSuccessTemplate = registerSuccessTemplateDef
userExistsTemplate :: WidgetFor a ()
userExistsTemplate = userExistsTemplateDef
invalidPasswordTokenTemplate :: Text -> WidgetFor a ()
invalidPasswordTokenTemplate = invalidTokenTemplateDef
invalidRegistrationTokenTemplate :: Text -> WidgetFor a ()
invalidRegistrationTokenTemplate = invalidTokenTemplateDef
tooManyLoginAttemptsTemplate :: UTCTime -> WidgetFor a ()
tooManyLoginAttemptsTemplate = tooManyLoginAttemptsTemplateDef
setPasswordTemplate ::
(AuthRoute -> Route a)
-> Route a
-> Maybe Text
-> WidgetFor a ()
setPasswordTemplate = 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 _ = setMessage "Password has been updated"
-- | Action called when a bot is detected
onBotPost :: MonadAuthHandler a m => m ()
onBotPost = pure ()
-- | Provide suitable constructor e.g. `RuleBased 8`
passwordCheck :: PasswordCheck
passwordCheck = Zxcvbn PW.Safe Vec.empty
-- | This instance of AuthPlugin for inserting into `authPlugins` of YesodAuth
authSimple :: YesodAuthSimple m => AuthPlugin m
authSimple = AuthPlugin "simple" dispatch loginHandlerRedirect
loginHandlerRedirect :: (Route Auth -> Route a) -> WidgetFor a ()
loginHandlerRedirect tm = redirectTemplate $ tm loginR
dispatch :: YesodAuthSimple a => Text -> [Text] -> AuthHandler a TypedContent
dispatch method path = case (method, path) of
("GET", ["register"]) -> sr getRegisterR
("POST", ["register"]) -> sr postRegisterR
("GET", ["confirm", token]) -> sr $ getConfirmTokenR token
("GET", ["confirm"]) -> sr getConfirmR
("POST", ["confirm"]) -> sr postConfirmR
("GET", ["confirmation-email-sent"]) -> sr getConfirmationEmailSentR
-- @since 1.0.0
("GET", ["confirmation-email-resent"]) -> sr getConfirmationEmailResentR
("GET", ["register-success"]) -> sr getRegisterSuccessR
("GET", ["user-exists"]) -> sr getUserExistsR
("GET", ["login"]) -> sr getLoginR
("POST", ["login"]) -> sr postLoginR
("GET", ["set-password", token]) -> sr $ getSetPasswordTokenR token
("GET", ["set-password"]) -> sr getSetPasswordR
("POST", ["set-password"]) -> sr postSetPasswordR
("GET", ["reset-password"]) -> sr getResetPasswordR
("POST", ["reset-password"]) -> sr postResetPasswordR
("GET", ["reset-password-email-sent"]) -> sr getResetPasswordEmailSentR
-- NB: We use a POST instead of GET so that we don't send the password
-- in the URL query string
("POST", ["password-strength"]) -> sr postPasswordStrengthR
_ -> notFound
where sr r = r >>= sendResponse
-- | Registration page
getRegisterR :: YesodAuthSimple a => AuthHandler a TypedContent
getRegisterR = do
mErr <- getError
muid <- maybeAuthId
tp <- getRouteToParent
case muid of
Nothing -> selectRep . provideRep . authLayout $ do
setTitle "Register a new account"
registerTemplate tp mErr
Just _ -> redirect $ toPathPiece ("/" :: String)
-- | Reset password page
getResetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent
getResetPasswordR = do
mErr <- getError
tp <- getRouteToParent
selectRep . provideRep . authLayout $ do
setTitle "Reset password"
resetPasswordTemplate tp mErr
-- | Login page
getLoginR :: YesodAuthSimple a => AuthHandler a TypedContent
getLoginR = do
mErr <- getError
mEmail <- getEmail
muid <- maybeAuthId
tp <- getRouteToParent
case muid of
Nothing -> selectRep . provideRep . authLayout $ do
setTitle "Login"
loginTemplate tp mErr mEmail
Just _ -> redirect $ toPathPiece ("/" :: 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 = "yas-set-password-token"
-- | Another key for registration tokens
registrationTokenSessionKey :: Text
registrationTokenSessionKey = "yas-registration-token"
genToken :: IO ByteString
genToken = getRandomBytes 24
-- | Hashes input via SHA256 and returns the hash encoded as base64 text
hashAndEncodeToken :: ByteString -> Text
hashAndEncodeToken bs = decodeUtf8 . B64.encode
$ ByteArray.convert (C.hash bs :: Digest SHA256)
-- | encode to base64url form
encodeToken :: ByteString -> Text
encodeToken = decodeUtf8With lenientDecode . 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 = B64Url.decodeLenient . encodeUtf8
-- | Lookup and verify registration token
verifyRegisterTokenFromSession :: YesodAuthSimple a
=> AuthHandler a (Maybe Email)
verifyRegisterTokenFromSession =
maybe (pure Nothing) matchRegistrationToken
=<< lookupSession registrationTokenSessionKey
-- | Lookup and verify password token
verifyPasswordTokenFromSession :: YesodAuthSimple a
=> AuthHandler a (Maybe (AuthSimpleId a))
verifyPasswordTokenFromSession =
maybe (pure Nothing) matchPasswordToken
=<< lookupSession passwordTokenSessionKey
-- | Delete registration token from cookie and maybe callback
markRegisterTokenAsUsed :: YesodAuthSimple a => Maybe Email -> AuthHandler a ()
markRegisterTokenAsUsed mEmail = do
deleteSession registrationTokenSessionKey
case mEmail of
Just email -> onRegistrationTokenUsed email
_ -> pure ()
-- | Accept registration form and send a verification link
postRegisterR :: YesodAuthSimple a => AuthHandler a TypedContent
postRegisterR = do
clearError
(honeypot, email) <- runInputPost $ (,)
<$> iopt textField honeypotName
<*> ireq textField "email"
mEmail <- fmap Email <$> validateAndNormalizeEmail email
case mEmail of
_ | isJust honeypot -> do
onBotPost
let msg = "An unexpected error occurred.\
\ Please try again or contact support\
\ if the problem persists."
redirectWithError registerR msg
Just email' -> do
getUserId email' >>= \case
-- User with that email already exists
Just _ -> onEmailAlreadyExist
Nothing -> do
tp <- getRouteToParent
renderUrl <- getUrlRender
rawToken <- liftIO genToken
let url = renderUrl . tp . confirmTokenR $ encodeToken rawToken
hashed = hashAndEncodeToken rawToken
route <- bool confirmationEmailSentR confirmationEmailResentR
<$> isConfirmationPending email'
sendVerifyEmail email' url hashed
redirect $ tp route
Nothing -> do
setError "Invalid email address"
tp <- getRouteToParent
redirect $ tp registerR
-- | Accept email and send a password reset link
postResetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent
postResetPasswordR = do
clearError
ur <- getUrlRender
token <- liftIO genToken
email <- runInputPost $ ireq textField "email"
tp <- getRouteToParent
let url = ur . tp . setPasswordTokenR $ encodeToken token
hashed = hashAndEncodeToken token
sendResetPasswordEmail (Email email) url hashed
redirect $ tp 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 token = do
setSession registrationTokenSessionKey . hashAndEncodeToken . decodeToken $ token
tp <- getRouteToParent
redirect $ tp confirmR
-- | Validate registration token and present confirmation screen to continue
-- e.g. include form to set password
getConfirmR :: YesodAuthSimple a => AuthHandler a TypedContent
getConfirmR = do
mEmail <- verifyRegisterTokenFromSession
case mEmail of
Nothing -> do
markRegisterTokenAsUsed Nothing
invalidRegistrationTokenHandler
Just 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.
getUserId email >>= maybe (doConfirm email) (redirectToHome email)
where
redirectToHome email uid = do
markRegisterTokenAsUsed $ Just email
setCredsRedirect $ Creds "simple" (toPathPiece uid) []
doConfirm email = do tp <- getRouteToParent
confirmHandler (tp confirmR) email
-- | Response and perhaps explanation for invalid or expired password token
invalidPasswordTokenHandler :: YesodAuthSimple a => AuthHandler a TypedContent
invalidPasswordTokenHandler = do
html <- authLayout $ do
setTitle "Invalid token"
invalidPasswordTokenTemplate invalidPasswordTokenMessage
let contentType = [("Content-Type", "text/html")]
renderHtmlBuilder html
& responseBuilder badRequest400 contentType
& sendWaiResponse
-- | Response and perhaps explanation for invalid or expired registration token
invalidRegistrationTokenHandler :: YesodAuthSimple a => AuthHandler a TypedContent
invalidRegistrationTokenHandler = do
html <- authLayout $ do
setTitle "Invalid token"
invalidRegistrationTokenTemplate invalidRegistrationMessage
let contentType = [("Content-Type", "text/html")]
renderHtmlBuilder html
& responseBuilder badRequest400 contentType
& sendWaiResponse
-- | Next step after email verification, usually to set password
confirmHandler ::
YesodAuthSimple a
=> Route a
-> Email
-> AuthHandler a TypedContent
confirmHandler registerUrl email = do
mErr <- getError
tp <- getRouteToParent
selectRep . provideRep . authLayout $ do
setTitle "Confirm account"
confirmTemplate tp registerUrl email mErr
-- | Check registration token again, take password and try to create user
postConfirmR :: YesodAuthSimple a => AuthHandler a TypedContent
postConfirmR = do
clearError
okCsrf <- hasValidCsrfParamNamed defaultCsrfParamName
mEmail <- verifyRegisterTokenFromSession
case mEmail of
_ | not okCsrf -> redirectWithError confirmR invalidCsrfMessage
Nothing -> invalidRegistrationTokenHandler
Just email -> do
password <- runInputPost $ ireq textField "password"
createUser email (Pass . encodeUtf8 $ password)
-- | Create user with valid password and return success page (or redirect)
createUser :: forall m. YesodAuthSimple m
=> Email -> Pass -> AuthHandler m TypedContent
createUser email password = do
check <- liftIO $ strengthToEither
<$> checkPasswordStrength (passwordCheck @m) password
case check of
Left msg -> do
setError msg
tp <- getRouteToParent
redirect $ tp confirmR
Right _ -> do
markRegisterTokenAsUsed $ Just email
encrypted <- liftIO $ encryptPassIO' password
insertUser email encrypted >>= \case
Just uid -> do
let creds = Creds "simple" (toPathPiece uid) []
setCreds False creds
onRegisterSuccess
Nothing -> do
tp <- getRouteToParent
redirect $ tp userExistsR
-- | Confirmation to show after sending verification email
getConfirmationEmailSentR :: YesodAuthSimple a => AuthHandler a TypedContent
getConfirmationEmailSentR = selectRep . provideRep . authLayout $ do
setTitle "Confirmation email sent"
confirmationEmailSentTemplate
{- | Confirmation to show after resending verification email.
@since 1.0.0
-}
getConfirmationEmailResentR :: YesodAuthSimple a => AuthHandler a TypedContent
getConfirmationEmailResentR = selectRep . provideRep . authLayout $ do
setTitle "Confirmation email resent"
confirmationEmailResentTemplate
-- | Confirmation to show after sending password reset email
getResetPasswordEmailSentR :: YesodAuthSimple a => AuthHandler a TypedContent
getResetPasswordEmailSentR = selectRep . provideRep . authLayout $ do
setTitle "Reset password email sent"
resetPasswordEmailSentTemplate
-- | Another option for responding on successful registration
getRegisterSuccessR :: AuthHandler a TypedContent
getRegisterSuccessR = do
setMessage "Account created. Welcome!"
redirect ("/" :: Text)
-- | Redirected to when `insertUser` does not return UserID
getUserExistsR :: YesodAuthSimple a => AuthHandler a TypedContent
getUserExistsR = selectRep . provideRep . authLayout $ do
setTitle "User already exists"
userExistsTemplate
-- | JSON endpoint for validating password
postPasswordStrengthR :: forall a. (YesodAuthSimple a) => AuthHandler a J.Value
postPasswordStrengthR = do
okCsrf <- hasValidCsrfParamNamed defaultCsrfParamName
if not okCsrf
then pure . toJSON $ BadPassword PW.Risky $ Just invalidCsrfMessage
else do
password <- runInputPost (ireq textField "password")
let pass = Pass . encodeUtf8 $ password
liftIO $ toJSON <$> checkPasswordStrength (passwordCheck @a) pass
-- | Validate password for given parameters with Zxcvbn library
checkPassWithZxcvbn ::
PW.Strength
-> Vector Text
-> Day
-> Text
-> PasswordStrength
checkPassWithZxcvbn minStrength' extraWords' day password =
let conf = PW.addCustomFrequencyList extraWords' PW.en_US
guesses = PW.score conf day password
stren = PW.strength guesses
in if stren >= minStrength' then GoodPassword stren
else BadPassword stren $ Just "The password is not strong enough"
-- | Validate password with simple length rule
checkPassWithRules :: Int -> Text -> PasswordStrength
checkPassWithRules minLen password
| T.length password >= minLen = GoodPassword PW.Safe
| otherwise = BadPassword PW.Weak . Just . T.pack
$ "Password must be at least " <> show minLen <> " characters"
strengthToEither :: PasswordStrength -> Either Text PW.Strength
strengthToEither (GoodPassword stren) = Right stren
strengthToEither (BadPassword _ (Just err)) = Left err
strengthToEither (BadPassword _ Nothing) =
Left "The password is not strong enough"
getPWStrength :: PasswordStrength -> PW.Strength
getPWStrength (GoodPassword stren) = stren
getPWStrength (BadPassword stren _) = stren
-- | Explain password strength with a given validator
checkPasswordStrength :: PasswordCheck -> Pass -> IO PasswordStrength
checkPasswordStrength check pass =
case decodeUtf8' (getPass pass) of
Left _ -> pure $ BadPassword PW.Weak $ Just "Invalid characters in password"
Right password ->
if not satisfiesMaxLen
then pure . BadPassword PW.Weak . Just
$ "Password exceeds maximum length of "
<> T.pack (show maxPasswordLength)
else case check of
RuleBased minLen ->
pure $ checkPassWithRules (max minLen minPasswordLength) password
Zxcvbn minStren extraWords' -> do
today <- utctDay <$> getCurrentTime
let pwstren = checkPassWithZxcvbn minStren extraWords' today password
pure $
if satisfiesMinLen
then 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 BadPassword (min (getPWStrength pwstren) (pred minStren))
. Just $ "The password must be at least "
<> T.pack (show minPasswordLength) <> " characters"
where (boundedPw, extra) = T.splitAt maxPasswordLength password
satisfiesMinLen = T.length boundedPw >= minPasswordLength
satisfiesMaxLen = T.null extra
normalizeEmail :: Text -> Text
normalizeEmail = T.toLower
validateAndNormalizeEmail :: Text -> AuthHandler a (Maybe Text)
validateAndNormalizeEmail email = case canonicalizeEmail $ encodeUtf8 email of
Just bytes ->
return $ Just $ normalizeEmail $ decodeUtf8With lenientDecode bytes
Nothing -> return Nothing
-- | Session name used for the errors.
errorSessionName :: Text
errorSessionName = "yesod-auth-simple-error"
-- | Session name used for the email storage.
emailSessionName :: Text
emailSessionName = "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 = do
mErr <- lookupSession errorSessionName
clearError
return mErr
-- | Sets up the error session ('errorSessionName') to the given value.
setError :: MonadHandler m => Text -> m ()
setError = setSession errorSessionName
-- | Clears up the error session ('errorSessionName').
clearError :: AuthHandler a ()
clearError = deleteSession errorSessionName
{- | Get the email session (see 'emailSessionName') if present. It also clears
up the session after.
-}
getEmail :: AuthHandler a (Maybe Text)
getEmail = do
mEmail <- lookupSession emailSessionName
clearEmail
return mEmail
-- | Sets up the email session ('emailSessionName') to the given value.
setEmail :: MonadHandler m => Text -> m ()
setEmail = setSession emailSessionName
-- | Clears up the email session ('emailSessionName').
clearEmail :: AuthHandler a ()
clearEmail = deleteSession emailSessionName
-- | Accept login form, check attempts limit and authenticate or redirect user
postLoginR :: YesodAuthSimple a => AuthHandler a TypedContent
postLoginR = do
clearError
clearEmail
okCsrf <- hasValidCsrfParamNamed defaultCsrfParamName
if not okCsrf
then redirectWithError loginR invalidCsrfMessage
else do
(email, password') <- runInputPost $ (,)
<$> ireq textField "email"
<*> ireq textField "password"
setEmail email
let password = Pass . encodeUtf8 $ password'
mUid <- getUserId (Email email)
mLockedOut <- shouldPreventLoginAttempt mUid
case (mLockedOut, mUid) of
(Just expires, _) -> tooManyLoginAttemptsHandler expires
(_, Just uid) -> do
storedPassword <- getUserPassword uid
if verifyPass' password storedPassword
then do
onLoginAttempt (Just uid) True
setCredsRedirect $ Creds "simple" (toPathPiece uid) []
else do
onLoginAttempt (Just uid) False
wrongEmailOrPasswordRedirect
_ -> do
onLoginAttempt Nothing False
wrongEmailOrPasswordRedirect
tooManyLoginAttemptsHandler ::
YesodAuthSimple a
=> UTCTime
-> AuthHandler a TypedContent
tooManyLoginAttemptsHandler expires = do
html <- authLayout $ do
setTitle "Too many login attempts"
tooManyLoginAttemptsTemplate expires
let contentType = [("Content-Type", "text/html")]
renderHtmlBuilder html
& responseBuilder tooManyRequests429 contentType
& sendWaiResponse
redirectTo :: AuthRoute -> AuthHandler a b
redirectTo route = do
tp <- getRouteToParent
redirect $ tp route
redirectWithError :: AuthRoute -> Text -> AuthHandler a TypedContent
redirectWithError route err = do
setError err
redirectTo route
wrongEmailOrPasswordRedirect :: AuthHandler a TypedContent
wrongEmailOrPasswordRedirect =
redirectWithError loginR "Wrong email or password"
invalidCsrfMessage :: Text
invalidCsrfMessage =
"Invalid anti-forgery token. \
\Please try again in a new browser tab or window. \
\Contact support if the problem persists."
invalidRegistrationMessage :: Text
invalidRegistrationMessage =
"Invalid registration link. \
\Please try registering again and contact support if the problem persists"
invalidPasswordTokenMessage :: Text
invalidPasswordTokenMessage =
"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 token = do
setSession passwordTokenSessionKey . hashAndEncodeToken . decodeToken $ token
tp <- getRouteToParent
redirect $ tp setPasswordR
-- | Validate password token and prompt for new password
getSetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent
getSetPasswordR = do
mUid <- verifyPasswordTokenFromSession
case mUid of
Nothing -> invalidPasswordTokenHandler
Just _ -> do
tp <- getRouteToParent
mErr <- getError
selectRep . provideRep . authLayout $ do
setTitle "Set password"
setPasswordTemplate tp (tp setPasswordR) mErr
-- | Set a new password for the user
postSetPasswordR :: YesodAuthSimple a => AuthHandler a TypedContent
postSetPasswordR = do
clearError
okCsrf <- hasValidCsrfParamNamed defaultCsrfParamName
mUid <- verifyPasswordTokenFromSession
case mUid of
_ | not okCsrf -> redirectWithError setPasswordR invalidCsrfMessage
Nothing -> do
deleteSession passwordTokenSessionKey
invalidPasswordTokenHandler
Just uid -> do
password <- runInputPost $ ireq textField "password"
setPass uid (Pass . encodeUtf8 $ password)
-- | Check and update password, callback, then redirect to user page
setPass :: forall a. YesodAuthSimple a
=> AuthSimpleId a
-> Pass
-> AuthHandler a TypedContent
setPass uid password = do
check <- liftIO $ strengthToEither
<$> checkPasswordStrength (passwordCheck @a) password
case check of
Left msg -> do
setError msg
tp <- getRouteToParent
redirect $ tp setPasswordR
Right _ -> do
encrypted <- liftIO $ encryptPassIO' password
_ <- updateUserPassword uid encrypted
onPasswordUpdated uid
deleteSession passwordTokenSessionKey
setCredsRedirect $ Creds "simple" (toPathPiece uid) []
redirectTemplate :: Route a -> WidgetFor a ()
redirectTemplate destUrl = do
toWidget $(whamletFile "templates/redirect.hamlet")
toWidget [julius|window.location = "@{destUrl}";|]
csrfTokenTemplate :: WidgetFor a ()
csrfTokenTemplate = do
request <- getRequest
$(whamletFile "templates/csrf-token.hamlet")
loginTemplateDef ::
(AuthRoute -> Route a)
-> Maybe Text
-> Maybe Text
-> WidgetFor a ()
loginTemplateDef toParent mErr mEmail = $(whamletFile "templates/login.hamlet")
passwordFieldTemplateBasic :: WidgetFor a ()
passwordFieldTemplateBasic =
$(whamletFile "templates/password-field-basic.hamlet")
zxcvbnJsUrl :: Text
zxcvbnJsUrl = "https://cdn.jsdelivr.net/npm/zxcvbn@4.4.2/dist/zxcvbn.js"
passwordFieldTemplateZxcvbn ::
(AuthRoute -> Route a)
-> PW.Strength
-> Vector Text
-> WidgetFor a ()
passwordFieldTemplateZxcvbn toParent minStren extraWords' = do
let extraWordsStr = T.unwords . toList $ extraWords'
blankPasswordScore = BadPassword PW.Risky Nothing
mCsrfToken <- reqToken <$> getRequest
addScriptRemote zxcvbnJsUrl
toWidget $(hamletFile "templates/password-field-zxcvbn.hamlet")
toWidget $(luciusFile "templates/password-field-zxcvbn.lucius")
toWidget $(juliusFile "templates/password-field-zxcvbn.julius")
setPasswordTemplateDef ::
forall a. YesodAuthSimple a
=> (AuthRoute -> Route a)
-> Route a
-> Maybe Text
-> WidgetFor a ()
setPasswordTemplateDef toParent url mErr =
let pwField = passwordFieldTemplate @a toParent
in $(whamletFile "templates/set-password.hamlet")
invalidTokenTemplateDef :: Text -> WidgetFor a ()
invalidTokenTemplateDef msg = $(whamletFile "templates/invalid-token.hamlet")
tooManyLoginAttemptsTemplateDef :: UTCTime -> WidgetFor a ()
tooManyLoginAttemptsTemplateDef expires =
let formatted = formatTime defaultTimeLocale "%d/%m/%_Y %T" expires
in $(whamletFile "templates/too-many-login-attempts.hamlet")
userExistsTemplateDef :: WidgetFor a ()
userExistsTemplateDef = $(whamletFile "templates/user-exists.hamlet")
registerSuccessTemplateDef :: WidgetFor a ()
registerSuccessTemplateDef = $(whamletFile "templates/register-success.hamlet")
resetPasswordEmailSentTemplateDef :: WidgetFor a ()
resetPasswordEmailSentTemplateDef =
$(whamletFile "templates/reset-password-email-sent.hamlet")
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 toParent confirmUrl (Email email) mErr =
let pwField = passwordFieldTemplate @a toParent
in $(whamletFile "templates/confirm.hamlet")
resetPasswordTemplateDef ::
(AuthRoute -> Route a)
-> Maybe Text
-> WidgetFor a ()
resetPasswordTemplateDef toParent mErr =
$(whamletFile "templates/reset-password.hamlet")
honeypotName :: Text
honeypotName = "yas-password-backup"
honeypotFieldTemplate :: WidgetFor a ()
honeypotFieldTemplate = do
toWidget [lucius| .#{honeypotName} { display:none !important; } |]
toWidget $(hamletFile "templates/honeypot-field.hamlet")
registerTemplateDef :: (AuthRoute -> Route a) -> Maybe Text -> WidgetFor a ()
registerTemplateDef toParent mErr = $(whamletFile "templates/register.hamlet")