Allow username logins for Yesod.Auth.Email (fixes #532)

yesod-auth/Yesod/Auth/Email.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PatternGuards #-}
 module Yesod.Auth.Email
     ( -- * Plugin
       authEmail
@@ -10,31 +11,40 @@ module Yesod.Auth.Email
       -- * Routes
     , loginR
     , registerR
+    , forgotPasswordR
     , setpassR
     , isValidPass
+      -- * Types
+    , Email
+    , VerKey
+    , VerUrl
+    , SaltedPass
+    , VerStatus
+    , Identifier
     ) where
 
 import Network.Mail.Mime (randomString)
 import Yesod.Auth
 import System.Random
-import Control.Monad (when)
-import Control.Applicative ((<$>), (<*>))
 import Data.Digest.Pure.MD5
-import qualified Data.Text.Lazy as T
 import qualified Data.Text as TS
-import Data.Text.Lazy.Encoding (encodeUtf8)
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TLE
+import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
+import Data.Text.Encoding.Error (lenientDecode)
 import Data.Text (Text)
-import qualified Crypto.PasswordStore as PS
-import qualified Data.Text.Encoding as DTE
-import Control.Monad.Trans.Class
-
-import Yesod.Form
 import Yesod.Core
+import qualified Crypto.PasswordStore as PS
+import qualified Text.Email.Validate
 import qualified Yesod.Auth.Message as Msg
+import Control.Applicative ((<$>), (<*>))
+import Yesod.Form
+import Control.Monad (when)
 
-loginR, registerR, setpassR :: AuthRoute
+loginR, registerR, forgotPasswordR, setpassR :: AuthRoute
 loginR = PluginR "email" ["login"]
 registerR = PluginR "email" ["register"]
+forgotPasswordR = PluginR "email" ["forgot-password"]
 setpassR = PluginR "email" ["set-password"]
 
 verify :: Text -> Text -> AuthRoute -- FIXME
@@ -46,33 +56,86 @@ type VerUrl = Text
 type SaltedPass = Text
 type VerStatus = Bool
 
+-- | An Identifier generalizes an email address to allow users to log in with
+-- some other form of credentials (e.g., username).
+--
+-- Note that any of these other identifiers must not be valid email addresses.
+--
+-- Since 1.2.0
+type Identifier = Text
+
 -- | Data stored in a database for each e-mail address.
-data EmailCreds m = EmailCreds
+data EmailCreds site = EmailCreds
-    { emailCredsId :: AuthEmailId m
+    { emailCredsId :: AuthEmailId site
-    , emailCredsAuthId :: Maybe (AuthId m)
+    , emailCredsAuthId :: Maybe (AuthId site)
     , emailCredsStatus :: VerStatus
     , emailCredsVerkey :: Maybe VerKey
+    , emailCredsEmail :: Email
     }
 
 class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site where
     type AuthEmailId site
 
+    -- | Add a new email address to the database, but indicate that the address
+    -- has not yet been verified.
+    --
+    -- Since 1.1.0
     addUnverified :: Email -> VerKey -> HandlerT site IO (AuthEmailId site)
+
+    -- | Send an email to the given address to verify ownership.
+    --
+    -- Since 1.1.0
     sendVerifyEmail :: Email -> VerKey -> VerUrl -> HandlerT site IO ()
+
+    -- | Get the verification key for the given email ID.
+    --
+    -- Since 1.1.0
     getVerifyKey :: AuthEmailId site -> HandlerT site IO (Maybe VerKey)
+
+    -- | Set the verification key for the given email ID.
+    --
+    -- Since 1.1.0
     setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO ()
+
+    -- | Verify the email address on the given account.
+    --
+    -- Since 1.1.0
     verifyAccount :: AuthEmailId site -> HandlerT site IO (Maybe (AuthId site))
+
+    -- | Get the salted password for the given account.
+    --
+    -- Since 1.1.0
     getPassword :: AuthId site -> HandlerT site IO (Maybe SaltedPass)
+
+    -- | Set the salted password for the given account.
+    --
+    -- Since 1.1.0
     setPassword :: AuthId site -> SaltedPass -> HandlerT site IO ()
-    getEmailCreds :: Email -> HandlerT site IO (Maybe (EmailCreds site))
+
+    -- | Get the credentials for the given @Identifier@, which may be either an
+    -- email address or some other identification (e.g., username).
+    --
+    -- Since 1.2.0
+    getEmailCreds :: Identifier -> HandlerT site IO (Maybe (EmailCreds site))
+
+    -- | Get the email address for the given email ID.
+    --
+    -- Since 1.1.0
     getEmail :: AuthEmailId site -> HandlerT site IO (Maybe Email)
 
     -- | Generate a random alphanumeric string.
+    --
+    -- Since 1.1.0
     randomKey :: site -> IO Text
     randomKey _ = do
         stdgen <- newStdGen
         return $ TS.pack $ fst $ randomString 10 stdgen
 
+    -- | Route to send user to after password has been set correctly.
+    --
+    -- Since 1.2.0
+    afterPasswordRoute :: site -> Route site
+
 authEmail :: YesodAuthEmail m => AuthPlugin m
 authEmail =
     AuthPlugin "email" dispatch $ \tm ->
@@ -96,6 +159,8 @@ $newline never
   where
     dispatch "GET" ["register"] = getRegisterR >>= sendResponse
     dispatch "POST" ["register"] = postRegisterR >>= sendResponse
+    dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse
+    dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse
     dispatch "GET" ["verify", eid, verkey] =
         case fromPathPiece eid of
             Nothing -> notFound
@@ -105,7 +170,7 @@ $newline never
     dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse
     dispatch _ _ = notFound
 
-getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) RepHtml
+getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
 getRegisterR = do
     email <- newIdent
     tp <- getRouteToParent
@@ -114,38 +179,77 @@ getRegisterR = do
         [whamlet|
             <p>_{Msg.EnterEmail}
             <form method="post" action="@{tp registerR}">
-                <label for=#{email}>_{Msg.Email}
+                <div id="registerForm">
-                <input ##{email} type="email" name="email" width="150">
+                    <label for=#{email}>_{Msg.Email}:
-                <input type="submit" value=_{Msg.Register}>
+                    <input ##{email} type="email" name="email" width="150">
+                <button .btn>_{Msg.Register}
         |]
 
-postRegisterR :: YesodAuthEmail master => AuthHandler master RepHtml
+registerHelper :: YesodAuthEmail master
-postRegisterR = do
+               => Bool -- ^ allow usernames?
+               -> Route Auth
+               -> HandlerT Auth (HandlerT master IO) Html
+registerHelper allowUsername dest = do
     y <- lift getYesod
-    email <- lift $ runInputPost $ ireq emailField "email"
+    midentifier <- lookupPostParam "email"
-    mecreds <- lift $ getEmailCreds email
+    identifier <-
-    (lid, verKey) <-
+        case midentifier of
+            Nothing -> do
+                lift $ setMessageI Msg.NoIdentifierProvided
+                redirect dest
+            Just x
+                | Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) ->
+                    return $ decodeUtf8With lenientDecode x'
+                | allowUsername -> return $ TS.strip x
+                | otherwise -> do
+                    lift $ setMessageI Msg.InvalidEmailAddress
+                    redirect dest
+    mecreds <- lift $ getEmailCreds identifier
+    (lid, verKey, email) <-
         case mecreds of
-            Just (EmailCreds lid _ _ (Just key)) -> return (lid, key)
+            Just (EmailCreds lid _ _ (Just key) email) -> return (lid, key, email)
-            Just (EmailCreds lid _ _ Nothing) -> do
+            Just (EmailCreds lid _ _ Nothing email) -> do
                 key <- liftIO $ randomKey y
                 lift $ setVerifyKey lid key
-                return (lid, key)
+                return (lid, key, email)
-            Nothing -> do
+            Nothing
-                key <- liftIO $ randomKey y
+                | allowUsername -> do
-                lid <- lift $ addUnverified email key
+                    setMessage $ toHtml $ "No record for that identifier in our database: " `TS.append` identifier
-                return (lid, key)
+                    redirect dest
+                | otherwise -> do
+                    key <- liftIO $ randomKey y
+                    lid <- lift $ addUnverified identifier key
+                    return (lid, key, identifier)
     render <- getUrlRender
     let verUrl = render $ verify (toPathPiece lid) verKey
     lift $ sendVerifyEmail email verKey verUrl
     lift $ defaultLayout $ do
         setTitleI Msg.ConfirmationEmailSentTitle
-        [whamlet|<p>_{Msg.ConfirmationEmailSent email}|]
+        [whamlet|<p>_{Msg.ConfirmationEmailSent identifier}|]
+
+postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+postRegisterR = registerHelper False registerR
+
+getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+getForgotPasswordR = do
+    tp <- getRouteToParent
+    email <- newIdent
+    lift $ defaultLayout $ do
+        setTitleI Msg.PasswordResetTitle
+        [whamlet|
+            <p>_{Msg.PasswordResetPrompt}
+            <form method="post" action="@{tp forgotPasswordR}">
+                <div id="registerForm">
+                    <label for=#{email}>_{Msg.ProvideIdentifier}
+                    <input ##{email} type=text name="email" width="150">
+                <button .btn>_{Msg.SendPasswordResetEmail}
+        |]
+
+postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+postForgotPasswordR = registerHelper True forgotPasswordR
 
 getVerifyR :: YesodAuthEmail m
-           => AuthEmailId m
+           => AuthEmailId m -> Text -> HandlerT Auth (HandlerT m IO) Html
-           -> Text
-           -> HandlerT Auth (HandlerT m IO) RepHtml
 getVerifyR lid key = do
     realKey <- lift $ getVerifyKey lid
     memail <- lift $ getEmail lid
@@ -155,39 +259,52 @@ getVerifyR lid key = do
             case muid of
                 Nothing -> return ()
                 Just _uid -> do
-                    lift $ setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid?
+                    lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
                     lift $ setMessageI Msg.AddressVerified
                     redirect setpassR
         _ -> return ()
     lift $ defaultLayout $ do
         setTitleI Msg.InvalidKey
-        [whamlet|<p>_{Msg.InvalidKey}|]
+        [whamlet|
+$newline never
+<p>_{Msg.InvalidKey}
+|]
 
-postLoginR :: YesodAuthEmail master => AuthHandler master ()
+postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()
 postLoginR = do
-    (email, pass) <- lift $ runInputPost $ (,)
+    (identifier, pass) <- lift $ runInputPost $ (,)
-        <$> ireq emailField "email"
+        <$> ireq textField "email"
         <*> ireq textField "password"
-    mecreds <- lift $ getEmailCreds email
+    mecreds <- lift $ getEmailCreds identifier
     maid <-
-        case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of
+        case ( mecreds >>= emailCredsAuthId
-            (Just aid, Just True) -> do
+             , emailCredsEmail <$> mecreds
+             , emailCredsStatus <$> mecreds
+             ) of
+            (Just aid, Just email, Just True) -> do
                 mrealpass <- lift $ getPassword aid
                 case mrealpass of
                     Nothing -> return Nothing
                     Just realpass -> return $
                         if isValidPass pass realpass
-                            then Just aid
+                            then Just email
                             else Nothing
             _ -> return Nothing
+    let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
     case maid of
-        Just _aid ->
+        Just email ->
-            lift $ setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid?
+            lift $ setCreds True $ Creds
+                (if isEmail then "email" else "username")
+                email
+                [("verifiedEmail", email)]
         Nothing -> do
-            lift $ setMessageI Msg.InvalidEmailPass
+            lift $ setMessageI $
+                if isEmail
+                    then Msg.InvalidEmailPass
+                    else Msg.InvalidUsernamePass
             redirect LoginR
 
-getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) RepHtml
+getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
 getPasswordR = do
     maid <- lift maybeAuthId
     pass1 <- newIdent
@@ -239,28 +356,25 @@ postPasswordR = do
         y <- getYesod
         setPassword aid salted
         setMessageI Msg.PassUpdated
-        redirect $ loginDest y
+        redirect $ afterPasswordRoute y
 
 saltLength :: Int
 saltLength = 5
 
 -- | Salt a password with a randomly generated salt.
 saltPass :: Text -> IO Text
-saltPass = fmap DTE.decodeUtf8
+saltPass = fmap (decodeUtf8With lenientDecode)
          . flip PS.makePassword 12
-         . DTE.encodeUtf8
+         . encodeUtf8
 
 saltPass' :: String -> String -> String
-saltPass' salt pass =
+saltPass' salt pass = salt ++ show (md5 $ TLE.encodeUtf8 $ TL.pack $ salt ++ pass)
-    salt ++ show (md5 $ fromString $ salt ++ pass)
-  where
-    fromString = encodeUtf8 . T.pack
 
 isValidPass :: Text -- ^ cleartext password
             -> SaltedPass -- ^ salted password
             -> Bool
 isValidPass ct salted =
-    PS.verifyPassword (DTE.encodeUtf8 ct) (DTE.encodeUtf8 salted) || isValidPass' ct salted
+    PS.verifyPassword (encodeUtf8 ct) (encodeUtf8 salted) || isValidPass' ct salted
 
 isValidPass' :: Text -- ^ cleartext password
             -> SaltedPass -- ^ salted password

yesod-auth/Yesod/Auth/Message.hs

@@ -47,6 +47,13 @@ data AuthMessage =
     | LoginTitle
     | PleaseProvideUsername
     | PleaseProvidePassword
+    | NoIdentifierProvided
+    | InvalidEmailAddress
+    | PasswordResetTitle
+    | ProvideIdentifier
+    | SendPasswordResetEmail
+    | PasswordResetPrompt
+    | InvalidUsernamePass
 
 -- | Defaults to 'englishMessage'.
 defaultMessage :: AuthMessage -> Text
@@ -85,6 +92,13 @@ englishMessage NowLoggedIn = "You are now logged in"
 englishMessage LoginTitle = "Login"
 englishMessage PleaseProvideUsername = "Please fill in your username"
 englishMessage PleaseProvidePassword = "Please fill in your password"
+englishMessage NoIdentifierProvided = "No email/username provided"
+englishMessage InvalidEmailAddress = "Invalid email address provided"
+englishMessage PasswordResetTitle = "Password Reset"
+englishMessage ProvideIdentifier = "Email or Username"
+englishMessage SendPasswordResetEmail = "Send password reset email"
+englishMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
+englishMessage InvalidUsernamePass = "Invalid username/password combination"
 
 portugueseMessage :: AuthMessage -> Text
 portugueseMessage NoOpenID = "Nenhum identificador OpenID encontrado"
@@ -119,6 +133,13 @@ portugueseMessage NowLoggedIn = "Você acaba de entrar no site com sucesso!"
 portugueseMessage LoginTitle = "Entrar no site"
 portugueseMessage PleaseProvideUsername = "Por favor digite seu nome de usuário"
 portugueseMessage PleaseProvidePassword = "Por favor digite sua senha"
+portugueseMessage NoIdentifierProvided = "No email/username provided"
+portugueseMessage InvalidEmailAddress = "Invalid email address provided"
+portugueseMessage PasswordResetTitle = "Password Reset"
+portugueseMessage ProvideIdentifier = "Email or Username"
+portugueseMessage SendPasswordResetEmail = "Send password reset email"
+portugueseMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
+portugueseMessage InvalidUsernamePass = "Invalid username/password combination"
 
 swedishMessage :: AuthMessage -> Text
 swedishMessage NoOpenID = "Fann ej OpenID identifierare"
@@ -153,6 +174,13 @@ swedishMessage NowLoggedIn = "Du är nu inloggad"
 swedishMessage LoginTitle = "Logga in"
 swedishMessage PleaseProvideUsername = "Vänligen fyll i användarnamn"
 swedishMessage PleaseProvidePassword = "Vänligen fyll i lösenord"
+swedishMessage NoIdentifierProvided = "No email/username provided"
+swedishMessage InvalidEmailAddress = "Invalid email address provided"
+swedishMessage PasswordResetTitle = "Password Reset"
+swedishMessage ProvideIdentifier = "Email or Username"
+swedishMessage SendPasswordResetEmail = "Send password reset email"
+swedishMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
+swedishMessage InvalidUsernamePass = "Invalid username/password combination"
 
 germanMessage :: AuthMessage -> Text
 germanMessage NoOpenID = "Kein OpenID-Identifier gefunden"
@@ -187,6 +215,13 @@ germanMessage NowLoggedIn = "Login erfolgreich"
 germanMessage LoginTitle = "Login"
 germanMessage PleaseProvideUsername = "Bitte Nutzername angeben"
 germanMessage PleaseProvidePassword = "Bitte Passwort angeben"
+germanMessage NoIdentifierProvided = "No email/username provided"
+germanMessage InvalidEmailAddress = "Invalid email address provided"
+germanMessage PasswordResetTitle = "Password Reset"
+germanMessage ProvideIdentifier = "Email or Username"
+germanMessage SendPasswordResetEmail = "Send password reset email"
+germanMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
+germanMessage InvalidUsernamePass = "Invalid username/password combination"
 
 
 
@@ -223,6 +258,13 @@ frenchMessage NowLoggedIn = "Vous êtes maintenant connecté"
 frenchMessage LoginTitle = "Se connecter"
 frenchMessage PleaseProvideUsername = "Merci de renseigner votre nom d'utilisateur"
 frenchMessage PleaseProvidePassword = "Merci de spécifier un mot de passe"
+frenchMessage NoIdentifierProvided = "No email/username provided"
+frenchMessage InvalidEmailAddress = "Invalid email address provided"
+frenchMessage PasswordResetTitle = "Password Reset"
+frenchMessage ProvideIdentifier = "Email or Username"
+frenchMessage SendPasswordResetEmail = "Send password reset email"
+frenchMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
+frenchMessage InvalidUsernamePass = "Invalid username/password combination"
 
 norwegianBokmålMessage :: AuthMessage -> Text
 norwegianBokmålMessage NoOpenID = "Ingen OpenID-identifiserer funnet"
@@ -257,6 +299,13 @@ norwegianBokmålMessage NowLoggedIn = "Du er nå logget inn"
 norwegianBokmålMessage LoginTitle = "Logg inn"
 norwegianBokmålMessage PleaseProvideUsername = "Vennligst fyll inn ditt brukernavn"
 norwegianBokmålMessage PleaseProvidePassword = "Vennligst fyll inn ditt passord"
+norwegianBokmålMessage NoIdentifierProvided = "No email/username provided"
+norwegianBokmålMessage InvalidEmailAddress = "Invalid email address provided"
+norwegianBokmålMessage PasswordResetTitle = "Password Reset"
+norwegianBokmålMessage ProvideIdentifier = "Email or Username"
+norwegianBokmålMessage SendPasswordResetEmail = "Send password reset email"
+norwegianBokmålMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
+norwegianBokmålMessage InvalidUsernamePass = "Invalid username/password combination"
 
 japaneseMessage :: AuthMessage -> Text
 japaneseMessage NoOpenID = "OpenID識別子がありません"
@@ -291,6 +340,13 @@ japaneseMessage NowLoggedIn = "ログインしました"
 japaneseMessage LoginTitle = "ログイン"
 japaneseMessage PleaseProvideUsername = "ユーザ名を入力してください"
 japaneseMessage PleaseProvidePassword = "パスワードを入力してください"
+japaneseMessage NoIdentifierProvided = "No email/username provided"
+japaneseMessage InvalidEmailAddress = "Invalid email address provided"
+japaneseMessage PasswordResetTitle = "Password Reset"
+japaneseMessage ProvideIdentifier = "Email or Username"
+japaneseMessage SendPasswordResetEmail = "Send password reset email"
+japaneseMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
+japaneseMessage InvalidUsernamePass = "Invalid username/password combination"
 
 finnishMessage :: AuthMessage -> Text
 finnishMessage NoOpenID = "OpenID-tunnistetta ei löydy"
@@ -325,5 +381,12 @@ finnishMessage NowLoggedIn = "Olet nyt kirjautunut sisään"
 finnishMessage LoginTitle = "Kirjautuminen"
 finnishMessage PleaseProvideUsername = "Käyttäjänimi puuttuu"
 finnishMessage PleaseProvidePassword = "Salasana puuttuu"
+finnishMessage NoIdentifierProvided = "No email/username provided"
+finnishMessage InvalidEmailAddress = "Invalid email address provided"
+finnishMessage PasswordResetTitle = "Password Reset"
+finnishMessage ProvideIdentifier = "Email or Username"
+finnishMessage SendPasswordResetEmail = "Send password reset email"
+finnishMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
+finnishMessage InvalidUsernamePass = "Invalid username/password combination"
 
 

yesod-auth/yesod-auth.cabal

@@ -44,6 +44,7 @@ library
                    , network
                    , http-types
                    , file-embed
+                   , email-validate          >= 1.0
 
     exposed-modules: Yesod.Auth
                      Yesod.Auth.BrowserId