diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index 186d32f8..a54f5dfd 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -23,6 +23,8 @@ module Yesod.Auth , Creds (..) , setCreds , clearCreds + , loginErrorMessage + , loginErrorMessageI -- * User functions , defaultMaybeAuthId , maybeAuth @@ -44,6 +46,7 @@ import Data.Text.Encoding.Error (lenientDecode) 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 qualified Yesod.Auth.Message as Msg 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 @@ cachedAuth aid = runMaybeT $ do $ 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 @@ setCreds doRedirects creds = do 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 @@ setCreds doRedirects creds = do 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 @@ redirectLogin = do 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/Yesod/Auth/BrowserId.hs b/yesod-auth/Yesod/Auth/BrowserId.hs index 402453b4..032de003 100644 --- a/yesod-auth/Yesod/Auth/BrowserId.hs +++ b/yesod-auth/Yesod/Auth/BrowserId.hs @@ -19,7 +19,6 @@ import Text.Hamlet (hamlet) 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 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin 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/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 5b383cc3..043cb94f 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -195,15 +195,13 @@ registerHelper allowUsername dest = do 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 @@ postLoginR = do 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 @@ getPasswordR = do 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 @@ postPasswordR = do (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/Yesod/Auth/GoogleEmail.hs b/yesod-auth/Yesod/Auth/GoogleEmail.hs index d9ce98fe..036ae3f5 100644 --- a/yesod-auth/Yesod/Auth/GoogleEmail.hs +++ b/yesod-auth/Yesod/Auth/GoogleEmail.hs @@ -54,10 +54,7 @@ authGoogleEmail = , ("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 @@ authGoogleEmail = 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/Yesod/Auth/HashDB.hs b/yesod-auth/Yesod/Auth/HashDB.hs index 80990a8d..ad9fac72 100644 --- a/yesod-auth/Yesod/Auth/HashDB.hs +++ b/yesod-auth/Yesod/Auth/HashDB.hs @@ -82,14 +82,12 @@ import Text.Hamlet (hamlet) import Control.Applicative ((<$>), (<*>)) import Control.Monad (replicateM,liftM) -import Control.Monad.Trans.Resource (MonadResourceBase) import qualified Data.ByteString.Lazy.Char8 as BS (pack) import Data.Digest.Pure.SHA (sha1, showDigest) import Data.Text (Text, pack, unpack, append) import Data.Maybe (fromMaybe) import System.Random (randomRIO) -import Network.HTTP.Types (unauthorized401) -- | Interface for data type which holds user info. It's just a -- collection of getters and setters class HashDBUser user where @@ -177,22 +175,8 @@ postLoginR uniq = do (validateUser <$> (uniq =<< mu) <*> mp) if isValid then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) [] - else loginMsg LoginR "Invalid username/password" + else loginErrorMessage LoginR "Invalid username/password" -loginMsg :: MonadResourceBase m - => Route site - -> Text - -> HandlerT site m a -loginMsg dest msg = selectRep (do - provideRep $ do - setMessage $ toHtml msg - fmap asHtml $ redirect dest - provideRep $ return $ object - [ "message" .= msg - ]) >>= sendResponseStatus unauthorized401 - where - asHtml :: Html -> Html - asHtml = id -- | A drop in for the getAuthId method of your YesodAuth instance which -- can be used if authHashDB is the only plugin in use. @@ -219,7 +203,7 @@ getAuthIdHashDB authR uniq creds = do case x of -- user exists Just (Entity uid _) -> return $ Just uid - Nothing -> loginMsg (authR LoginR) "User not found" + 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/Yesod/Auth/OpenId.hs b/yesod-auth/Yesod/Auth/OpenId.hs index d2e20c5b..a7f9d10f 100644 --- a/yesod-auth/Yesod/Auth/OpenId.hs +++ b/yesod-auth/Yesod/Auth/OpenId.hs @@ -21,16 +21,17 @@ import Data.Text (Text, isPrefixOf) 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 @@ $newline never 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 @@ $newline never 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