diff --git a/yesod-core/Yesod/Core/Class/Yesod.hs b/yesod-core/Yesod/Core/Class/Yesod.hs index f98a8b2b..1e9d2e87 100644 --- a/yesod-core/Yesod/Core/Class/Yesod.hs +++ b/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
#{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
#{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" diff --git a/yesod-core/test/YesodCoreTest/Auth.hs b/yesod-core/test/YesodCoreTest/Auth.hs index 17dfc880..813d8575 100644 --- a/yesod-core/test/YesodCoreTest/Auth.hs +++ b/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 diff --git a/yesod-core/test/YesodCoreTest/Reps.hs b/yesod-core/test/YesodCoreTest/Reps.hs index e2496b61..c16f3749 100644 --- a/yesod-core/test/YesodCoreTest/Reps.hs +++ b/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\"}"