diff --git a/Yesod/Auth.hs b/Yesod/Auth.hs --- a/Yesod/Auth.hs +++ b/Yesod/Auth.hs @@ -165,6 +165,16 @@ => 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 @@ -- | 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/BrowserId.hs b/Yesod/Auth/BrowserId.hs --- a/Yesod/Auth/BrowserId.hs +++ b/Yesod/Auth/BrowserId.hs @@ -75,7 +75,8 @@ 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/Email.hs b/Yesod/Auth/Email.hs --- a/Yesod/Auth/Email.hs +++ b/Yesod/Auth/Email.hs @@ -393,15 +393,19 @@ 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 @@ 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/GoogleEmail.hs b/Yesod/Auth/GoogleEmail.hs --- a/Yesod/Auth/GoogleEmail.hs +++ b/Yesod/Auth/GoogleEmail.hs @@ -54,7 +54,9 @@ , ("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 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/HashDB.hs b/Yesod/Auth/HashDB.hs --- a/Yesod/Auth/HashDB.hs +++ b/Yesod/Auth/HashDB.hs @@ -177,7 +177,9 @@ (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/OpenId.hs b/Yesod/Auth/OpenId.hs --- a/Yesod/Auth/OpenId.hs +++ b/Yesod/Auth/OpenId.hs @@ -69,8 +69,10 @@ 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 @@ 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 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.5.1 +version: 1.2.5.2 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin @@ -34,8 +34,8 @@ , unordered-containers , yesod-form >= 1.3 && < 1.4 , transformers >= 0.2.2 - , persistent >= 1.2 && < 1.3 - , persistent-template >= 1.2 && < 1.3 + , persistent >= 1.2 && < 1.4 + , persistent-template >= 1.2 && < 1.4 , SHA >= 1.4.1.3 , http-conduit >= 1.5 , aeson >= 0.5