diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.4 + +* Add AuthenticationResult and authenticate function [#959](https://github.com/yesodweb/yesod/pull/959) + ## 1.4.3 * Added means to fetch user's Google profile [#936](https://github.com/yesodweb/yesod/pull/936) diff --git a/Yesod/Auth.hs b/Yesod/Auth.hs --- a/Yesod/Auth.hs +++ b/Yesod/Auth.hs @@ -28,6 +28,7 @@ , loginErrorMessage , loginErrorMessageI -- * User functions + , AuthenticationResult (..) , defaultMaybeAuthId , maybeAuthPair , maybeAuth @@ -67,7 +68,7 @@ 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,14 @@ type Method = Text type Piece = Text +-- | The result of an authentication based on credentials +-- +-- Since 1.4.4 +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,9 +119,29 @@ -- destination exists. logoutDest :: master -> Route master + -- | Perform authentication based on the given credentials. + -- + -- Default implementation is in terms of @'getAuthId'@ + -- + -- Since: 1.4.4 + 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 +204,10 @@ 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 +265,21 @@ 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 +291,9 @@ -> 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 +302,30 @@ 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 +334,10 @@ 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/Message.hs b/Yesod/Auth/Message.hs --- a/Yesod/Auth/Message.hs +++ b/Yesod/Auth/Message.hs @@ -61,6 +61,7 @@ | PasswordResetPrompt | InvalidUsernamePass | Logout + | AuthError -- | Defaults to 'englishMessage'. defaultMessage :: AuthMessage -> Text @@ -108,6 +109,7 @@ 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 @@ -- 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 @@ -- 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 @@ -- 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 @@ -- 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 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 @@ -- 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 (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 @@ -- 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 @@ -- 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 @@ -- 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 InvalidUsernamePass = "Неверное сочетание имени пользователя и пароля" russianMessage (IdentifierNotFound ident) = "Логин не найден: " `mappend` ident russianMessage Logout = "Выйти" +russianMessage AuthError = "Ошибка аутентификации" dutchMessage :: AuthMessage -> Text dutchMessage NoOpenID = "Geen OpenID identificator gevonden" @@ -635,3 +648,4 @@ 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 diff --git a/yesod-auth.cabal b/yesod-auth.cabal --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 1.4.3.1 +version: 1.4.4 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin