Added type constraint to onHtmlError. Modified plugins to support this

changed type
yesodweb · Dec 22, 2013 · b57ac44 · b57ac44
1 parent e17523b
commit b57ac44
Show file tree

Hide file tree

Showing 6 changed files with 42 additions and 27 deletions.
diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs
@@ -165,15 +165,15 @@ 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
-onError :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html
-onError dest msg = do
-    setMessage $ toHtml msg
-    fmap asHtml $ redirect dest
-    where
-      asHtml :: Html -> Html
-      asHtml = id
+    -- | Called on login error for HTTP requests. By default, calls
+    -- @setMessage
+    onError :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html
+    onError 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.
 --
@@ -243,10 +243,10 @@ 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

diff --git 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
@@ -395,15 +395,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"
@@ -413,7 +417,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
@@ -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
@@ -175,7 +175,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
@@ -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