Merge branch 'yesod1.2' of https://github.com/yesodweb/yesod into yesod1.2

yesod-core/Yesod/Core/Class/Yesod.hs

@@ -13,7 +13,7 @@ import           Yesod.Routes.Class
 import           Blaze.ByteString.Builder           (Builder)
 import           Blaze.ByteString.Builder.Char.Utf8 (fromText)
 import           Control.Arrow                      ((***))
-import           Control.Monad                      (forM, when)
+import           Control.Monad                      (forM, when, void)
 import           Control.Monad.IO.Class             (MonadIO (liftIO))
 import           Control.Monad.Logger               (LogLevel (LevelInfo, LevelOther),
                                                      LogSource)
@@ -291,10 +291,14 @@ authorizationCheck = do
                 master <- getYesod
                 case authRoute master of
                     Nothing ->
-                        permissionDenied "Authentication required"
+                        void $ permissionDenied "Authentication required"
                     Just url' -> do
-                        setUltDestCurrent
-                        redirect url'
+                      void $ selectRep $ do
+                          provideRepType typeJson $ do
+                              void $ permissionDenied "Authentication required"
+                          provideRepType typeHtml $ do
+                              setUltDestCurrent
+                              void $ redirect url'
             Unauthorized s' -> permissionDenied s'
 
 -- | Convert a widget to a 'PageContent'.
@@ -407,6 +411,7 @@ defaultErrorHandler NotFound = selectRep $ do
             <p>#{path'}
         |]
     provideRep $ return $ object ["message" .= ("Not Found" :: Text)]
+
 defaultErrorHandler (PermissionDenied msg) = selectRep $ do
     provideRep $ defaultLayout $ do
         setTitle "Permission Denied"
@@ -414,7 +419,15 @@ defaultErrorHandler (PermissionDenied msg) = selectRep $ do
             <h1>Permission denied
             <p>#{msg}
         |]
-    provideRep $ return $ object ["message" .= ("Permission Denied" :: Text)]
+    provideRep $ do
+        site <- getYesod
+        rend <- getUrlRender
+        return $ object $ [
+          "message" .= ("Permission Denied. " <> msg)
+          ] ++ case authRoute site of
+              Nothing -> []
+              Just url -> ["auth_url" .= rend url]
+
 defaultErrorHandler (InvalidArgs ia) = selectRep $ do
     provideRep $ defaultLayout $ do
         setTitle "Invalid Arguments"

yesod-core/test/YesodCoreTest/Auth.hs

@@ -12,24 +12,30 @@ data App = App
 
 mkYesod "App" [parseRoutes|
 /no-auth NoAuthR
-/needs-login NeedsLoginR
+/needs-login-json NeedsLoginJsonR
+/needs-login-html NeedsLoginHtmlR
 /read-only ReadOnlyR
 /forbidden ForbiddenR
 |]
 
 instance Yesod App where
     isAuthorized NoAuthR _ = return Authorized
-    isAuthorized NeedsLoginR _ = return AuthenticationRequired
+    isAuthorized NeedsLoginJsonR _ = return AuthenticationRequired
+    isAuthorized NeedsLoginHtmlR _ = return AuthenticationRequired
     isAuthorized ReadOnlyR False = return Authorized
     isAuthorized ReadOnlyR True = return $ Unauthorized "Read only"
     isAuthorized ForbiddenR _ = return $ Unauthorized "Forbidden"
     authRoute _ = Just NoAuthR
 
-handleNoAuthR, handleNeedsLoginR, handleReadOnlyR, handleForbiddenR :: Handler ()
-handleNoAuthR = return ()
-handleNeedsLoginR = return ()
-handleReadOnlyR = return ()
-handleForbiddenR = return ()
+handleNoAuthR, handleReadOnlyR, handleForbiddenR :: Handler ()
+handleNoAuthR     = return ()
+handleReadOnlyR   = return ()
+handleForbiddenR  = return ()
+
+handleNeedsLoginJsonR :: Handler RepJson
+handleNeedsLoginJsonR = return $ repJson $ object []
+handleNeedsLoginHtmlR :: Handler RepHtml
+handleNeedsLoginHtmlR = return ""
 
 test :: String -- ^ method
      -> String -- ^ path
@@ -48,8 +54,10 @@ specs :: Spec
 specs = describe "Auth" $ do
     test "GET" "no-auth" $ \sres -> assertStatus 200 sres
     test "POST" "no-auth" $ \sres -> assertStatus 200 sres
-    test "GET" "needs-login" $ \sres -> assertStatus 303 sres
-    test "POST" "needs-login" $ \sres -> assertStatus 303 sres
+    test "GET" "needs-login-html" $ \sres -> assertStatus 303 sres
+    test "POST" "needs-login-html" $ \sres -> assertStatus 303 sres
+    test "GET" "needs-login-json" $ \sres -> assertStatus 403 sres
+    test "POST" "needs-login-json" $ \sres -> assertStatus 403 sres
     test "GET" "read-only" $ \sres -> assertStatus 200 sres
     test "POST" "read-only" $ \sres -> assertStatus 403 sres
     test "GET" "forbidden" $ \sres -> assertStatus 403 sres

yesod-core/test/YesodCoreTest/Reps.hs

@@ -9,11 +9,15 @@ import Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString.Char8 as S8
 import Data.String (IsString)
 import Data.Text (Text)
+import Data.Maybe (fromJust)
+import Data.Monoid (Endo (..))
+import qualified Control.Monad.Trans.Writer    as Writer
 
 data App = App
 
 mkYesod "App" [parseRoutes|
-/ HomeR GET
+/     HomeR GET
+/json JsonR GET
 |]
 
 instance Yesod App
@@ -23,23 +27,39 @@ specialHtml = "text/html; charset=special"
 
 getHomeR :: Handler TypedContent
 getHomeR = selectRep $ do
-    let go ct t = provideRepType ct $ return (t :: Text)
-    go typeHtml "HTML"
-    go specialHtml "HTMLSPECIAL"
-    go typeJson "JSON"
-    go typeXml "XML"
+    rep typeHtml "HTML"
+    rep specialHtml "HTMLSPECIAL"
+    rep typeXml "XML"
+    rep typeJson "JSON"
+
+rep :: Monad m => ContentType -> Text -> Writer.Writer (Data.Monoid.Endo [ProvidedRep m]) ()
+rep ct t = provideRepType ct $ return (t :: Text)
+
+getJsonR :: Handler TypedContent
+getJsonR = selectRep $ do
+  rep typeHtml "HTML"
+  provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)]
+
+testRequest :: Request
+            -> ByteString -- ^ expected body
+            -> Spec
+testRequest req expected = it (S8.unpack $ fromJust $ lookup "Accept" $ requestHeaders req) $ do
+    app <- toWaiApp App
+    flip runSession app $ do
+        sres <- request req
+        assertBody expected sres
+        assertStatus 200 sres
 
 test :: String -- ^ accept header
      -> ByteString -- ^ expected body
      -> Spec
-test accept expected = it accept $ do
-    app <- toWaiApp App
-    flip runSession app $ do
-        sres <- request defaultRequest
+test accept expected =
+    testRequest (acceptRequest accept) expected
+
+acceptRequest :: String -> Request
+acceptRequest accept = defaultRequest
             { requestHeaders = [("Accept", S8.pack accept)]
             }
-        assertBody expected sres
-        assertStatus 200 sres
 
 specs :: Spec
 specs = describe "selectRep" $ do
@@ -53,3 +73,4 @@ specs = describe "selectRep" $ do
     test (S8.unpack typeHtml) "HTML"
     test "text/html" "HTML"
     test specialHtml "HTMLSPECIAL"
+    testRequest (acceptRequest "application/json") { pathInfo = ["json"] } "{\"message\":\"Invalid Login\"}"