yesod-auth 1.4.3.1 → 1.4.4
raw patch · 4 files changed
+96/−17 lines, 4 files
Files
- ChangeLog.md +4/−0
- Yesod/Auth.hs +77/−16
- Yesod/Auth/Message.hs +14/−0
- yesod-auth.cabal +1/−1
ChangeLog.md view
@@ -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)
Yesod/Auth.hs view
@@ -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|<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 +302,30 @@ 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 +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)
Yesod/Auth/Message.hs view
@@ -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
yesod-auth.cabal view
@@ -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