diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index b39980b7..503443b5 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -165,6 +165,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage => HandlerT master IO (Maybe (AuthId master)) maybeAuthId = defaultMaybeAuthId + -- | Called on login error for HTTP requests. By default, calls + -- @setMessage@ and redirects to @dest@. + onErrorHtml :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html + onErrorHtml dest msg = do + setMessage $ toHtml msg + fmap asHtml $ redirect dest + where + asHtml :: Html -> Html + asHtml = id + -- | Internal session key used to hold the authentication information. -- -- Since 1.2.3 @@ -233,21 +243,17 @@ loginErrorMessageMasterI dest msg = do -- | For HTML, set the message and redirect to the route. -- For JSON, send the message and a 401 status -loginErrorMessage :: MonadResourceBase m - => Route site +loginErrorMessage :: (YesodAuth master, MonadResourceBase m) + => Route master -> Text - -> HandlerT site m a + -> HandlerT master m a loginErrorMessage dest msg = sendResponseStatus unauthorized401 =<< ( selectRep $ do provideRep $ do - setMessage $ toHtml msg - fmap asHtml $ redirect dest + onErrorHtml dest msg provideJsonMessage msg ) - where - asHtml :: Html -> Html - asHtml = id provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) () provideJsonMessage msg = provideRep $ return $ object ["message" .= msg] diff --git a/yesod-auth/Yesod/Auth/BrowserId.hs b/yesod-auth/Yesod/Auth/BrowserId.hs index 032de003..ee7617b9 100644 --- a/yesod-auth/Yesod/Auth/BrowserId.hs +++ b/yesod-auth/Yesod/Auth/BrowserId.hs @@ -75,7 +75,8 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin case memail of Nothing -> do $logErrorS "yesod-auth" "BrowserID assertion failure" - loginErrorMessage LoginR "BrowserID login error." + tm <- getRouteToParent + lift $ loginErrorMessage (tm 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 654f85be..9cdb3061 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -393,15 +393,19 @@ postPasswordR = do Nothing -> loginErrorMessageI LoginR Msg.BadSetPass Just aid -> return aid + tm <- getRouteToParent + needOld <- lift $ needOldPassword aid when needOld $ do current <- lift $ runInputPost $ ireq textField "current" mrealpass <- lift $ getPassword aid case mrealpass of - Nothing -> loginErrorMessage setpassR "You do not currently have a password set on your account" + Nothing -> + lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account" Just realpass | isValidPass current realpass -> return () - | otherwise -> loginErrorMessage setpassR "Invalid current password, please try again" + | otherwise -> + lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again" (new, confirm) <- lift $ runInputPost $ (,) <$> ireq textField "new" @@ -411,7 +415,7 @@ postPasswordR = do isSecure <- lift $ checkPasswordSecurity aid new case isSecure of - Left e -> loginErrorMessage setpassR e + Left e -> lift $ loginErrorMessage (tm setpassR) e Right () -> return () salted <- liftIO $ saltPass new diff --git a/yesod-auth/Yesod/Auth/GoogleEmail.hs b/yesod-auth/Yesod/Auth/GoogleEmail.hs index 036ae3f5..93a592e4 100644 --- a/yesod-auth/Yesod/Auth/GoogleEmail.hs +++ b/yesod-auth/Yesod/Auth/GoogleEmail.hs @@ -54,7 +54,9 @@ authGoogleEmail = , ("openid.ui.icon", "true") ] (authHttpManager master) either - (\err -> loginErrorMessage LoginR $ T.pack $ show (err :: SomeException)) + (\err -> do + tm <- getRouteToParent + lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException)) redirect eres dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues @@ -71,13 +73,15 @@ completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master () completeHelper gets' = do master <- lift getYesod eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master) - either onFailure onSuccess eres + tm <- getRouteToParent + either (onFailure tm) (onSuccess tm) eres where - onFailure err = loginErrorMessage LoginR $ T.pack $ show (err :: SomeException) - onSuccess oir = do + onFailure tm err = do + lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException) + onSuccess tm 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" + (_, False) -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported" + (Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided" diff --git a/yesod-auth/Yesod/Auth/HashDB.hs b/yesod-auth/Yesod/Auth/HashDB.hs index e0a2629c..d0509f26 100644 --- a/yesod-auth/Yesod/Auth/HashDB.hs +++ b/yesod-auth/Yesod/Auth/HashDB.hs @@ -177,7 +177,9 @@ postLoginR uniq = do (validateUser <$> (uniq =<< mu) <*> mp) if isValid then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) [] - else loginErrorMessage LoginR "Invalid username/password" + else do + tm <- getRouteToParent + lift $ loginErrorMessage (tm LoginR) "Invalid username/password" -- | A drop in for the getAuthId method of your YesodAuth instance which diff --git a/yesod-auth/Yesod/Auth/OpenId.hs b/yesod-auth/Yesod/Auth/OpenId.hs index a7f9d10f..0f57c065 100644 --- a/yesod-auth/Yesod/Auth/OpenId.hs +++ b/yesod-auth/Yesod/Auth/OpenId.hs @@ -69,8 +69,10 @@ $newline never master <- lift getYesod eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master) case eres of - Left err -> loginErrorMessage LoginR $ T.pack $ - show (err :: SomeException) + Left err -> do + tm <- getRouteToParent + lift $ loginErrorMessage (tm LoginR) $ T.pack $ + show (err :: SomeException) Right x -> redirect x Nothing -> loginErrorMessageI LoginR Msg.NoOpenID dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues @@ -89,8 +91,10 @@ completeHelper idType gets' = do eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master) either onFailure onSuccess eres where - onFailure err = loginErrorMessage LoginR $ T.pack $ - show (err :: SomeException) + onFailure err = do + tm <- getRouteToParent + lift $ loginErrorMessage (tm LoginR) $ T.pack $ + show (err :: SomeException) onSuccess oir = do let claimed = case OpenId.oirClaimed oir of