Add AuthenticationResult and authenticate function

- getAuthId returns Maybe AuthId with no useful information in the
  Nothing case.
- AuthenticationResult includes whether it was a User or Server error
  (with an accompanying message) in the failure case.
- User errors are displayed back to the user and have a 401 status in
  JSON responses. Server errors are logged and a generic error message
  is presented to the user, with a 500 status in JSON responses.

Resolves #956

yesod-auth/Yesod/Auth.hs

@@ -28,6 +28,7 @@ module Yesod.Auth
     , loginErrorMessage
     , loginErrorMessageI
       -- * User functions
+    , AuthenticationResult (..)
     , defaultMaybeAuthId
     , maybeAuthPair
     , maybeAuth
@@ -67,7 +68,7 @@ import qualified Yesod.Auth.Message as Msg
 import Yesod.Form (FormMessage)
 import Data.Typeable (Typeable)
 import Control.Exception (Exception)
-import Network.HTTP.Types          (unauthorized401)
+import Network.HTTP.Types (Status, internalServerError500, unauthorized401)
 import Control.Monad.Trans.Resource (MonadResourceBase)
 import qualified Control.Monad.Trans.Writer    as Writer
 import Control.Monad (void)
@@ -79,6 +80,12 @@ type AuthHandler master a = YesodAuth master => HandlerT Auth (HandlerT master I
 type Method = Text
 type Piece = Text
 
+-- | The result of an authentication based on credentials
+data AuthenticationResult master
+    = Authenticated (AuthId master) -- ^ Authenticated successfully
+    | UserError AuthMessage         -- ^ Invalid credentials provided by user
+    | ServerError Text              -- ^ Some other error
+
 data AuthPlugin master = AuthPlugin
     { apName :: Text
     , apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
@@ -110,8 +117,27 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     -- destination exists.
     logoutDest :: master -> Route master
 
+    -- | Perform authentication based on the given credentials.
+    --
+    -- Default implementation is in terms of @'getAuthId'@
+    --
+    authenticate :: Creds master -> HandlerT master IO (AuthenticationResult master)
+    authenticate creds = do
+        muid <- getAuthId creds
+
+        return $ maybe (UserError Msg.InvalidLogin) Authenticated muid
+
     -- | Determine the ID associated with the set of credentials.
+    --
+    -- Default implementation is in terms of @'authenticate'@
+    --
     getAuthId :: Creds master -> HandlerT master IO (Maybe (AuthId master))
+    getAuthId creds = do
+        auth <- authenticate creds
+
+        return $ case auth of
+            Authenticated auid -> Just auid
+            _ -> Nothing
 
     -- | Which authentication backends to use.
     authPlugins :: master -> [AuthPlugin master]
@@ -175,6 +201,10 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
         setMessage $ toHtml msg
         fmap asHtml $ redirect dest
 
+    {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins, authHttpManager #-}
+
+{-# DEPRECATED getAuthId "Define 'authenticate' instead; 'getAuthId' will be removed in the next major version" #-}
+
 -- | Internal session key used to hold the authentication information.
 --
 -- Since 1.2.3
@@ -232,11 +262,21 @@ loginErrorMessage :: (YesodAuth master, MonadResourceBase m)
 loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
 
 messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent
-messageJson401 msg html = selectRep $ do
+messageJson401 = messageJsonStatus unauthorized401
+
+messageJson500 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent
+messageJson500 = messageJsonStatus internalServerError500
+
+messageJsonStatus :: MonadResourceBase m
+                  => Status
+                  -> Text
+                  -> HandlerT master m Html
+                  -> HandlerT master m TypedContent
+messageJsonStatus status msg html = selectRep $ do
     provideRep html
     provideRep $ do
         let obj = object ["message" .= msg]
-        void $ sendResponseStatus unauthorized401 obj
+        void $ sendResponseStatus status obj
         return obj
 
 provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) ()
@@ -248,15 +288,9 @@ setCredsRedirect :: YesodAuth master
          -> HandlerT master IO TypedContent
 setCredsRedirect creds = do
     y    <- getYesod
-    maid <- getAuthId creds
-    case maid of
-        Nothing ->
-            case authRoute y of
-                Nothing -> do
-                    messageJson401 "Invalid Login" $ authLayout $
-                        toWidget [shamlet|<h1>Invalid login|]
-                Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin
-        Just aid -> do
+    auth <- authenticate creds
+    case auth of
+        Authenticated aid -> do
             setSession credsKey $ toPathPiece aid
             onLogin
             res <- selectRep $ do
@@ -265,6 +299,30 @@ setCredsRedirect creds = do
                 provideJsonMessage "Login Successful"
             sendResponse res
 
+        UserError msg ->
+            case authRoute y of
+                Nothing -> do
+                    msg' <- renderMessage' msg
+                    messageJson401 msg' $ authLayout $ -- TODO
+                        toWidget [whamlet|<h1>_{msg}|]
+                Just ar -> loginErrorMessageMasterI ar msg
+
+        ServerError msg -> do
+            $(logError) msg
+
+            case authRoute y of
+                Nothing -> do
+                    msg' <- renderMessage' Msg.AuthError
+                    messageJson500 msg' $ authLayout $
+                        toWidget [whamlet|<h1>_{Msg.AuthError}|]
+                Just ar -> loginErrorMessageMasterI ar Msg.AuthError
+
+  where
+    renderMessage' msg = do
+        langs <- languages
+        master <- getYesod
+        return $ renderAuthMessage master langs msg
+
 -- | Sets user credentials for the session after checking them with authentication backends.
 setCreds :: YesodAuth master
          => Bool         -- ^ if HTTP redirects should be done
@@ -273,10 +331,10 @@ setCreds :: YesodAuth master
 setCreds doRedirects creds =
     if doRedirects
       then void $ setCredsRedirect creds
-      else do maid <- getAuthId creds
-              case maid of
-                  Nothing -> return ()
-                  Just aid -> setSession credsKey $ toPathPiece aid
+      else do auth <- authenticate creds
+              case auth of
+                  Authenticated aid -> setSession credsKey $ toPathPiece aid
+                  _ -> return ()
 
 -- | same as defaultLayoutJson, but uses authLayout
 authLayoutJson :: (YesodAuth site, ToJSON j)

yesod-auth/Yesod/Auth/Message.hs

@@ -61,6 +61,7 @@ data AuthMessage =
     | PasswordResetPrompt
     | InvalidUsernamePass
     | Logout
+    | AuthError
 
 -- | Defaults to 'englishMessage'.
 defaultMessage :: AuthMessage -> Text
@@ -108,6 +109,7 @@ englishMessage PasswordResetPrompt = "Enter your e-mail address or username belo
 englishMessage InvalidUsernamePass = "Invalid username/password combination"
 englishMessage (IdentifierNotFound ident) = "Login not found: " `mappend` ident
 englishMessage Logout = "Logout"
+englishMessage AuthError = "Authentication Error" -- FIXME by Google Translate
 
 portugueseMessage :: AuthMessage -> Text
 portugueseMessage NoOpenID = "Nenhum identificador OpenID encontrado"
@@ -152,6 +154,7 @@ portugueseMessage InvalidUsernamePass = "Nome de usuário ou senha inválidos"
 -- TODO
 portugueseMessage i@(IdentifierNotFound _) = englishMessage i
 portugueseMessage Logout = "Sair" -- FIXME by Google Translate
+portugueseMessage AuthError = "Erro de autenticação" -- FIXME by Google Translate
 
 spanishMessage :: AuthMessage -> Text
 spanishMessage NoOpenID = "No se encuentra el identificador OpenID"
@@ -196,6 +199,7 @@ spanishMessage InvalidUsernamePass = "Combinación de nombre de usuario/contrase
 -- TODO
 spanishMessage i@(IdentifierNotFound _) = englishMessage i
 spanishMessage Logout = "Finalizar la sesión" -- FIXME by Google Translate
+spanishMessage AuthError = "Error de autenticación" -- FIXME by Google Translate
 
 swedishMessage :: AuthMessage -> Text
 swedishMessage NoOpenID = "Fann ej OpenID identifierare"
@@ -241,6 +245,7 @@ swedishMessage InvalidUsernamePass = "Ogiltig kombination av användarnamn och l
 -- TODO
 swedishMessage i@(IdentifierNotFound _) = englishMessage i
 swedishMessage Logout = "Loggar ut" -- FIXME by Google Translate
+swedishMessage AuthError = "Autentisering Fel" -- FIXME by Google Translate
 
 germanMessage :: AuthMessage -> Text
 germanMessage NoOpenID = "Kein OpenID-Identifier gefunden"
@@ -285,6 +290,7 @@ germanMessage InvalidUsernamePass = "Ungültige Kombination aus Nutzername und P
 -- TODO
 germanMessage i@(IdentifierNotFound _) = englishMessage i
 germanMessage Logout = "Ausloggen" -- FIXME by Google Translate
+germanMessage AuthError = "Authorisierungsfehler" -- FIXME by Google Translate
 
 frenchMessage :: AuthMessage -> Text
 frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"
@@ -328,6 +334,7 @@ frenchMessage PasswordResetPrompt = "Entrez votre courriel ou votre nom d'utilis
 frenchMessage InvalidUsernamePass = "La combinaison de ce mot de passe et de ce nom d'utilisateur n'existe pas."
 frenchMessage (IdentifierNotFound ident) = "Nom d'utilisateur introuvable: " `mappend` ident
 frenchMessage Logout = "Déconnexion"
+frenchMessage AuthError = "Erreur d'authentification" -- FIXME by Google Translate
 
 norwegianBokmålMessage :: AuthMessage -> Text
 norwegianBokmålMessage NoOpenID = "Ingen OpenID-identifiserer funnet"
@@ -372,6 +379,7 @@ norwegianBokmålMessage InvalidUsernamePass = "Invalid username/password combina
 -- TODO
 norwegianBokmålMessage i@(IdentifierNotFound _) = englishMessage i
 norwegianBokmålMessage Logout = "Logge ut" -- FIXME by Google Translate
+norwegianBokmålMessage AuthError = "Godkjenningsfeil" -- FIXME by Google Translate
 
 japaneseMessage :: AuthMessage -> Text
 japaneseMessage NoOpenID = "OpenID識別子がありません"
@@ -416,6 +424,7 @@ japaneseMessage InvalidUsernamePass = "ユーザ名とパスワードの組み
 japaneseMessage (IdentifierNotFound ident) =
   ident `mappend` "は登録されていません"
 japaneseMessage Logout = "ログアウト" -- FIXME by Google Translate
+japaneseMessage AuthError = "認証エラー" -- FIXME by Google Translate
 
 finnishMessage :: AuthMessage -> Text
 finnishMessage NoOpenID = "OpenID-tunnistetta ei löydy"
@@ -461,6 +470,7 @@ finnishMessage InvalidUsernamePass = "Virheellinen käyttäjänimi tai salasana.
 -- TODO
 finnishMessage i@(IdentifierNotFound _) = englishMessage i
 finnishMessage Logout = "Kirjaudu ulos" -- FIXME by Google Translate
+finnishMessage AuthError = "Authentication Error" -- FIXME by Google Translate
 
 chineseMessage :: AuthMessage -> Text
 chineseMessage NoOpenID = "无效的OpenID"
@@ -505,6 +515,7 @@ chineseMessage InvalidUsernamePass = "无效的用户名/密码组合"
 -- TODO
 chineseMessage i@(IdentifierNotFound _) = englishMessage i
 chineseMessage Logout = "註銷" -- FIXME by Google Translate
+chineseMessage AuthError = "验证错误" -- FIXME by Google Translate
 
 czechMessage :: AuthMessage -> Text
 czechMessage NoOpenID = "Nebyl nalezen identifikátor OpenID"
@@ -547,6 +558,7 @@ czechMessage InvalidUsernamePass = "Neplatná kombinace uživatelského jména a
 -- TODO
 czechMessage i@(IdentifierNotFound _) = englishMessage i
 czechMessage Logout = "Odhlásit" -- FIXME by Google Translate
+czechMessage AuthError = "Chyba ověřování" -- FIXME by Google Translate
 
 -- Так как e-mail – это фактическое сокращение словосочетания electronic mail,
 -- для русского перевода так же использовано сокращение: эл.почта
@@ -592,6 +604,7 @@ russianMessage PasswordResetPrompt = "Введите адрес эл.почты
 russianMessage InvalidUsernamePass = "Неверное сочетание имени пользователя и пароля"
 russianMessage (IdentifierNotFound ident) = "Логин не найден: " `mappend` ident
 russianMessage Logout = "Выйти"
+russianMessage AuthError = "Ошибка аутентификации"
 
 dutchMessage :: AuthMessage -> Text
 dutchMessage NoOpenID = "Geen OpenID identificator gevonden"
@@ -635,3 +648,4 @@ dutchMessage PasswordResetPrompt = "Voer uw e-mailadres of gebruikersnaam hieron
 dutchMessage InvalidUsernamePass = "Ongeldige gebruikersnaam/wachtwoord combinatie"
 dutchMessage (IdentifierNotFound ident) = "Inloggegevens niet gevonden: " `mappend` ident
 dutchMessage Logout = "Logout" -- FIXME NOT TRANSLATED
+dutchMessage AuthError = "Verificatiefout" -- FIXME by Google Translate