diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index 35eaa6ec..e16487d0 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/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|

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|

_{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|

_{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) diff --git a/yesod-auth/Yesod/Auth/Message.hs b/yesod-auth/Yesod/Auth/Message.hs index 6f19b770..abfa4f9b 100644 --- a/yesod-auth/Yesod/Auth/Message.hs +++ b/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