Merge pull request #638 from jprider63/master

Add the function onHtmlError to the auth typeclass so users can customize behavior on authentication errors.

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
+loginErrorMessage :: (YesodAuth master, MonadResourceBase m)
-         => Route site
+         => Route master
          -> Text
-         -> HandlerT site m a
+         -> HandlerT master m a
 loginErrorMessage dest msg =
   sendResponseStatus unauthorized401 =<< (
     selectRep $ do
       provideRep $ do
-          setMessage $ toHtml msg
+          onErrorHtml dest 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]

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

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

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)
+      onFailure tm err = do
-      onSuccess oir = 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"
+                  (_, False)   -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported"
-                  (Nothing, _) -> loginErrorMessage LoginR "No email address provided"
+                  (Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided"

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

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 $
+                    Left err -> do
-                                 show (err :: SomeException)
+                        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 $
+    onFailure err = do 
-                      show (err :: SomeException)
+        tm <- getRouteToParent
+        lift $ loginErrorMessage (tm LoginR) $ T.pack $
+                show (err :: SomeException)
     onSuccess oir = do
             let claimed =
                     case OpenId.oirClaimed oir of