diff --git a/Yesod/Auth.hs b/Yesod/Auth.hs --- a/Yesod/Auth.hs +++ b/Yesod/Auth.hs @@ -23,6 +23,8 @@ , Creds (..) , setCreds , clearCreds + , loginErrorMessage + , loginErrorMessageI -- * User functions , defaultMaybeAuthId , maybeAuth @@ -44,6 +46,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.HashMap.Lazy as Map +import Data.Monoid (Endo) import Network.HTTP.Conduit (Manager) import qualified Network.Wai as W @@ -56,6 +59,9 @@ import Yesod.Form (FormMessage) import Data.Typeable (Typeable) import Control.Exception (Exception) +import Network.HTTP.Types (unauthorized401) +import Control.Monad.Trans.Resource (MonadResourceBase) +import qualified Control.Monad.Trans.Writer as Writer type AuthRoute = Route Auth @@ -202,6 +208,46 @@ $ get aid return $ Entity aid a + +loginErrorMessageI :: (MonadResourceBase m, YesodAuth master) + => Route child + -> AuthMessage + -> HandlerT child (HandlerT master m) a +loginErrorMessageI dest msg = do + toParent <- getRouteToParent + lift $ loginErrorMessageMasterI (toParent dest) msg + + +loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage) + => Route master + -> AuthMessage + -> HandlerT master m a +loginErrorMessageMasterI dest msg = do + mr <- getMessageRender + loginErrorMessage dest (mr msg) + +-- | For HTML, set the message and redirect to the route. +-- For JSON, send the message and a 401 status +loginErrorMessage :: MonadResourceBase m + => Route site + -> Text + -> HandlerT site m a +loginErrorMessage dest msg = + sendResponseStatus unauthorized401 =<< ( + selectRep $ do + provideRep $ do + setMessage $ toHtml msg + fmap asHtml $ redirect dest + provideJsonMessage msg + ) + where + asHtml :: Html -> Html + asHtml = id + +provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) () +provideJsonMessage msg = provideRep $ return $ object ["message" .= msg] + + -- | Sets user credentials for the session after checking them with authentication backends. setCreds :: YesodAuth master => Bool -- ^ if HTTP redirects should be done @@ -214,18 +260,12 @@ Nothing -> when doRedirects $ do case authRoute y of Nothing -> do - res <- selectRep $ do + sendResponseStatus unauthorized401 =<< ( + selectRep $ do provideRep $ defaultLayout $ toWidget [shamlet|

Invalid login|] - provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)] - sendResponse res - Just ar -> do - res <- selectRep $ do - provideRepType typeHtml $ do - setMessageI Msg.InvalidLogin - _ <- redirect ar - return () - provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)] - sendResponse res + provideJsonMessage "Invalid Login" + ) + Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin Just aid -> do setSession credsKey $ toPathPiece aid when doRedirects $ do @@ -234,7 +274,7 @@ provideRepType typeHtml $ do _ <- redirectUltDest $ loginDest y return () - provideRep $ return $ object ["message" .= ("Login Successful" :: Text)] + provideJsonMessage "Login Successful" sendResponse res -- | Clears current user credentials for the session. @@ -357,8 +397,7 @@ instance YesodAuth master => RenderMessage master AuthMessage where renderMessage = renderAuthMessage -data AuthException = InvalidBrowserIDAssertion - | InvalidFacebookResponse +data AuthException = InvalidFacebookResponse deriving (Show, Typeable) instance Exception AuthException diff --git a/Yesod/Auth/BrowserId.hs b/Yesod/Auth/BrowserId.hs --- a/Yesod/Auth/BrowserId.hs +++ b/Yesod/Auth/BrowserId.hs @@ -19,7 +19,6 @@ import qualified Data.Text as T import Data.Maybe (fromMaybe) import Control.Monad (when, unless) -import Control.Exception (throwIO) import Text.Julius (julius, rawJS) import Network.URI (uriPath, parseURI) import Data.FileEmbed (embedFile) @@ -74,7 +73,9 @@ return $ T.takeWhile (/= '/') $ stripScheme $ r LoginR memail <- lift $ checkAssertion audience assertion (authHttpManager master) case memail of - Nothing -> liftIO $ throwIO InvalidBrowserIDAssertion + Nothing -> do + $logErrorS "yesod-auth" "BrowserID assertion failure" + loginErrorMessage LoginR "BrowserID login error." Just email -> lift $ setCreds True Creds { credsPlugin = pid , credsIdent = email diff --git a/Yesod/Auth/Email.hs b/Yesod/Auth/Email.hs --- a/Yesod/Auth/Email.hs +++ b/Yesod/Auth/Email.hs @@ -195,15 +195,13 @@ identifier <- case midentifier of Nothing -> do - lift $ setMessageI Msg.NoIdentifierProvided - redirect dest + loginErrorMessageI dest Msg.NoIdentifierProvided 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 + loginErrorMessageI dest Msg.InvalidEmailAddress mecreds <- lift $ getEmailCreds identifier (lid, verKey, email) <- case mecreds of @@ -298,11 +296,10 @@ email [("verifiedEmail", email)] Nothing -> do - lift $ setMessageI $ + loginErrorMessageI LoginR $ if isEmail then Msg.InvalidEmailPass else Msg.InvalidUsernamePass - redirect LoginR getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html getPasswordR = do @@ -311,9 +308,7 @@ pass2 <- newIdent case maid of Just _ -> return () - Nothing -> do - lift $ setMessageI Msg.BadSetPass - redirect LoginR + Nothing -> loginErrorMessageI LoginR Msg.BadSetPass tp <- getRouteToParent lift $ defaultLayout $ do setTitleI Msg.SetPassTitle @@ -342,14 +337,11 @@ (new, confirm) <- lift $ runInputPost $ (,) <$> ireq textField "new" <*> ireq textField "confirm" - when (new /= confirm) $ do - lift $ setMessageI Msg.PassMismatch - redirect setpassR + when (new /= confirm) $ + loginErrorMessageI setpassR Msg.PassMismatch maid <- lift maybeAuthId aid <- case maid of - Nothing -> do - lift $ setMessageI Msg.BadSetPass - redirect LoginR + Nothing -> loginErrorMessageI LoginR Msg.BadSetPass Just aid -> return aid salted <- liftIO $ saltPass new lift $ do diff --git a/Yesod/Auth/GoogleEmail.hs b/Yesod/Auth/GoogleEmail.hs --- a/Yesod/Auth/GoogleEmail.hs +++ b/Yesod/Auth/GoogleEmail.hs @@ -54,10 +54,7 @@ , ("openid.ui.icon", "true") ] (authHttpManager master) either - (\err -> do - setMessage $ toHtml $ show (err :: SomeException) - redirect LoginR - ) + (\err -> loginErrorMessage LoginR $ T.pack $ show (err :: SomeException)) redirect eres dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues @@ -72,20 +69,15 @@ completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master () completeHelper gets' = do - master <- lift getYesod - eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master) - let onFailure err = do - setMessage $ toHtml $ show (err :: SomeException) - redirect LoginR - let onSuccess oir = do - let OpenId.Identifier ident = OpenId.oirOpLocal oir - memail <- lookupGetParam "openid.ext1.value.email" - case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of - (Just email, True) -> lift $ setCreds True $ Creds pid email [] - (_, False) -> do - setMessage "Only Google login is supported" - redirect LoginR - (Nothing, _) -> do - setMessage "No email address provided" - redirect LoginR - either onFailure onSuccess eres + master <- lift getYesod + eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master) + either onFailure onSuccess eres + where + onFailure err = loginErrorMessage LoginR $ T.pack $ show (err :: SomeException) + onSuccess oir = do + let OpenId.Identifier ident = OpenId.oirOpLocal oir + memail <- lookupGetParam "openid.ext1.value.email" + case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of + (Just email, True) -> lift $ setCreds True $ Creds pid email [] + (_, False) -> loginErrorMessage LoginR "Only Google login is supported" + (Nothing, _) -> loginErrorMessage LoginR "No email address provided" diff --git a/Yesod/Auth/HashDB.hs b/Yesod/Auth/HashDB.hs --- a/Yesod/Auth/HashDB.hs +++ b/Yesod/Auth/HashDB.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -87,7 +88,6 @@ import Data.Text (Text, pack, unpack, append) import Data.Maybe (fromMaybe) import System.Random (randomRIO) - -- | Interface for data type which holds user info. It's just a -- collection of getters and setters class HashDBUser user where @@ -175,8 +175,7 @@ (validateUser <$> (uniq =<< mu) <*> mp) if isValid then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) [] - else do setMessage "Invalid username/password" - redirect LoginR + else loginErrorMessage LoginR "Invalid username/password" -- | A drop in for the getAuthId method of your YesodAuth instance which @@ -204,9 +203,7 @@ case x of -- user exists Just (Entity uid _) -> return $ Just uid - Nothing -> do - setMessage "User not found" - redirect $ authR LoginR + Nothing -> loginErrorMessage (authR LoginR) "User not found" -- | Prompt for username and password, validate that against a database -- which holds the username and a hash of the password diff --git a/Yesod/Auth/OpenId.hs b/Yesod/Auth/OpenId.hs --- a/Yesod/Auth/OpenId.hs +++ b/Yesod/Auth/OpenId.hs @@ -21,16 +21,17 @@ import qualified Yesod.Auth.Message as Msg import Control.Exception.Lifted (SomeException, try) import Data.Maybe (fromMaybe) +import qualified Data.Text as T forwardUrl :: AuthRoute forwardUrl = PluginR "openid" ["forward"] data IdentifierType = Claimed | OPLocal -authOpenId :: YesodAuth m +authOpenId :: YesodAuth master => IdentifierType -> [(Text, Text)] -- ^ extension fields - -> AuthPlugin m + -> AuthPlugin master authOpenId idType extensionFields = AuthPlugin "openid" dispatch login where @@ -68,13 +69,10 @@ master <- lift getYesod eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master) case eres of - Left err -> do - setMessage $ toHtml $ show (err :: SomeException) - redirect LoginR + Left err -> loginErrorMessage LoginR $ T.pack $ + show (err :: SomeException) Right x -> redirect x - Nothing -> do - lift $ setMessageI Msg.NoOpenID - redirect LoginR + Nothing -> loginErrorMessageI LoginR Msg.NoOpenID dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues dispatch "GET" ["complete"] = do rr <- getRequest @@ -87,26 +85,26 @@ completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master () completeHelper idType gets' = do - master <- lift getYesod - eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master) - let onFailure err = do - setMessage $ toHtml $ show (err :: SomeException) - redirect LoginR - let onSuccess oir = do - let claimed = - case OpenId.oirClaimed oir of - Nothing -> id - Just (OpenId.Identifier i') -> ((claimedKey, i'):) - oplocal = - case OpenId.oirOpLocal oir of - OpenId.Identifier i' -> ((opLocalKey, i'):) - gets'' = oplocal $ claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets' - i = OpenId.identifier $ - case idType of - OPLocal -> OpenId.oirOpLocal oir - Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir - lift $ setCreds True $ Creds "openid" i gets'' - either onFailure onSuccess eres + master <- lift getYesod + eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master) + either onFailure onSuccess eres + where + onFailure err = loginErrorMessage LoginR $ T.pack $ + show (err :: SomeException) + onSuccess oir = do + let claimed = + case OpenId.oirClaimed oir of + Nothing -> id + Just (OpenId.Identifier i') -> ((claimedKey, i'):) + oplocal = + case OpenId.oirOpLocal oir of + OpenId.Identifier i' -> ((opLocalKey, i'):) + gets'' = oplocal $ claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets' + i = OpenId.identifier $ + case idType of + OPLocal -> OpenId.oirOpLocal oir + Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir + lift $ setCreds True $ Creds "openid" i gets'' -- | The main identifier provided by the OpenID authentication plugin is the -- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier 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.2.0 +version: 1.2.0.1 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin @@ -48,6 +48,7 @@ , file-embed , email-validate >= 1.0 , data-default + , resourcet exposed-modules: Yesod.Auth Yesod.Auth.BrowserId