Merge pull request #523 from yesodweb/content-negotiation2

accept header content negotiation

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'.

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
 

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"

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
 

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"