From 18be9bc206174e5c2c5e6d202b56dc86beacf93e Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Fri, 29 Mar 2013 14:01:30 -0700 Subject: [PATCH] accept header content negotiation * look at wildcards */* and main/* * return a 406 when nothing matches the accept header --- yesod-core/Yesod/Core/Class/Yesod.hs | 4 +-- yesod-core/Yesod/Core/Content.hs | 12 ++++++++ yesod-core/Yesod/Core/Handler.hs | 43 +++++++++++++++++++++------ yesod-core/test/YesodCoreTest/Auth.hs | 4 +++ yesod-core/test/YesodCoreTest/Reps.hs | 15 ++++++---- 5 files changed, 61 insertions(+), 17 deletions(-) diff --git a/yesod-core/Yesod/Core/Class/Yesod.hs b/yesod-core/Yesod/Core/Class/Yesod.hs index 1e9d2e87e..f126e1afd 100644 --- a/yesod-core/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/Yesod/Core/Class/Yesod.hs @@ -294,11 +294,11 @@ authorizationCheck = do void $ permissionDenied "Authentication required" Just url' -> do void $ selectRep $ do - provideRepType typeJson $ do - void $ permissionDenied "Authentication required" provideRepType typeHtml $ do setUltDestCurrent void $ redirect url' + provideRepType typeJson $ do + void $ permissionDenied "Authentication required" Unauthorized s' -> permissionDenied s' -- | Convert a widget to a 'PageContent'. diff --git a/yesod-core/Yesod/Core/Content.hs b/yesod-core/Yesod/Core/Content.hs index b7268e00d..2a9e5d9d1 100644 --- a/yesod-core/Yesod/Core/Content.hs +++ b/yesod-core/Yesod/Core/Content.hs @@ -31,6 +31,7 @@ module Yesod.Core.Content , typeOctet -- * Utilities , simpleContentType + , contentTypeTypes -- * Evaluation strategy , DontFullyEvaluate (..) -- * Representations @@ -209,6 +210,17 @@ typeOctet = "application/octet-stream" simpleContentType :: ContentType -> ContentType simpleContentType = fst . B.breakByte 59 -- 59 == ; +-- Give just the media types as a pair. +-- For example, \"text/html; charset=utf-8\" returns ("text", "html") +contentTypeTypes :: ContentType -> (B.ByteString, B.ByteString) +contentTypeTypes ct = (main, fst $ B.breakByte semicolon (tailEmpty sub)) + where + tailEmpty x = if B.null x then "" else B.tail x + (main, sub) = B.breakByte slash ct + slash = 47 + semicolon = 59 + + instance HasContentType a => HasContentType (DontFullyEvaluate a) where getContentType = getContentType . liftM unDontFullyEvaluate diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 147e07460..f7b9c482e 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -172,7 +172,7 @@ import Data.Text (Text) import qualified Network.Wai.Parse as NWP import Text.Shakespeare.I18N (RenderMessage (..)) import Web.Cookie (SetCookie (..)) -import Yesod.Core.Content (ToTypedContent (..), simpleContentType, HasContentType (..), ToContent (..), ToFlushBuilder (..)) +import Yesod.Core.Content (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..)) import Yesod.Core.Internal.Util (formatRFC1123) import Text.Blaze.Html (preEscapedToMarkup, toHtml) @@ -186,6 +186,7 @@ import Yesod.Core.Types import Yesod.Routes.Class (Route) import Control.Failure (failure) import Blaze.ByteString.Builder (Builder) +import Safe (headMay) get :: MonadHandler m => m GHState get = liftHandlerT $ HandlerT $ I.readIORef . handlerState @@ -849,27 +850,51 @@ selectRep :: MonadHandler m => Writer.Writer (Endo [ProvidedRep m]) () -> m TypedContent selectRep w = do + -- the content types are already sorted by q values + -- which have been stripped cts <- liftM reqAccept getRequest + case mapMaybe tryAccept cts of [] -> case reps of - [] -> return $ toTypedContent ("No reps provided to selectRep" :: Text) - rep:_ -> returnRep rep + [] -> sendResponseStatus H.status500 ("No reps provided to selectRep" :: Text) + rep:_ -> + if null cts + then returnRep rep + else sendResponseStatus H.status406 explainUnaccepted rep:_ -> returnRep rep where - returnRep (ProvidedRep ct mcontent) = do - content <- mcontent - return $ TypedContent ct content + explainUnaccepted :: Text + explainUnaccepted = "no match found for accept header" + + returnRep (ProvidedRep ct mcontent) = + mcontent >>= return . TypedContent ct reps = appEndo (Writer.execWriter w) [] + repMap = Map.unions $ map (\v@(ProvidedRep k _) -> Map.fromList [ (k, v) , (noSpace k, v) , (simpleContentType k, v) ]) reps - tryAccept ct = Map.lookup ct repMap <|> - Map.lookup (noSpace ct) repMap <|> - Map.lookup (simpleContentType ct) repMap + + -- match on the type for sub-type wildcards. + -- If the accept is text/* it should match a provided text/html + mainTypeMap = Map.fromList $ reverse $ map + (\v@(ProvidedRep ct _) -> (fst $ contentTypeTypes ct, v)) reps + + tryAccept ct = + if subType == "*" + then if mainType == "*" + then headMay reps + else Map.lookup mainType mainTypeMap + else lookupAccept ct + where + (mainType, subType) = contentTypeTypes ct + + lookupAccept ct = Map.lookup ct repMap <|> + Map.lookup (noSpace ct) repMap <|> + Map.lookup (simpleContentType ct) repMap -- Mime types such as "text/html; charset=foo" get converted to -- "text/html;charset=foo" diff --git a/yesod-core/test/YesodCoreTest/Auth.hs b/yesod-core/test/YesodCoreTest/Auth.hs index 813d85759..7750e5dfa 100644 --- a/yesod-core/test/YesodCoreTest/Auth.hs +++ b/yesod-core/test/YesodCoreTest/Auth.hs @@ -7,6 +7,7 @@ import Network.Wai.Test import Network.Wai import qualified Data.ByteString.Char8 as S8 import qualified Data.Text as T +import Data.List (isSuffixOf) data App = App @@ -47,6 +48,9 @@ test method path f = it (method ++ " " ++ path) $ do sres <- request defaultRequest { requestMethod = S8.pack method , pathInfo = [T.pack path] + , requestHeaders = + if not $ isSuffixOf "json" path then [] else + [("Accept", S8.pack "application/json")] } f sres diff --git a/yesod-core/test/YesodCoreTest/Reps.hs b/yesod-core/test/YesodCoreTest/Reps.hs index c16f37496..3c3e61e66 100644 --- a/yesod-core/test/YesodCoreTest/Reps.hs +++ b/yesod-core/test/YesodCoreTest/Reps.hs @@ -40,21 +40,22 @@ getJsonR = selectRep $ do rep typeHtml "HTML" provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)] -testRequest :: Request +testRequest :: Int -- ^ http status code + -> Request -> ByteString -- ^ expected body -> Spec -testRequest req expected = it (S8.unpack $ fromJust $ lookup "Accept" $ requestHeaders req) $ do +testRequest status req expected = it (S8.unpack $ fromJust $ lookup "Accept" $ requestHeaders req) $ do app <- toWaiApp App flip runSession app $ do sres <- request req + assertStatus status sres assertBody expected sres - assertStatus 200 sres test :: String -- ^ accept header -> ByteString -- ^ expected body -> Spec test accept expected = - testRequest (acceptRequest accept) expected + testRequest 200 (acceptRequest accept) expected acceptRequest :: String -> Request acceptRequest accept = defaultRequest @@ -68,9 +69,11 @@ specs = describe "selectRep" $ do test "text/xml" "XML" test (S8.unpack typeXml) "XML" test "text/xml,application/json" "XML" - test "text/foo" "HTML" test "text/xml;q=0.9,application/json;q=1.0" "JSON" test (S8.unpack typeHtml) "HTML" test "text/html" "HTML" test specialHtml "HTMLSPECIAL" - testRequest (acceptRequest "application/json") { pathInfo = ["json"] } "{\"message\":\"Invalid Login\"}" + testRequest 200 (acceptRequest "application/json") { pathInfo = ["json"] } "{\"message\":\"Invalid Login\"}" + testRequest 406 (acceptRequest "text/foo") "no match found for accept header" + test "text/*" "HTML" + test "*/*" "HTML"