selectRep chooses first rep if no matches found.

The `selectRep` documentation indicates that it choose the first
representation provided if no representation matches.

This was only partially correct, as `selectRep` required that no
representation matched **and** that the `Content-Type` header of the
response was empty.

This led to a problem because `defaultErrorhandler` relies on
`selectRep`, and when `selectRep` was unable to find a suitable
representation, it would "swallow" the original error that resulted in
`defaultErrorhandler` being called, and set a status 406 for all cases.

yesod-core/ChangeLog.md

@@ -1,3 +1,9 @@
+## 1.6.7
+
+* If no matches are found, `selectRep` chooses first representation regardless
+    of the presence or absence of a `Content-Type` header in the request
+    [#1540](https://github.com/yesodweb/yesod/pull/1540)
+
 ## 1.6.6
 
 * `defaultErrorHandler` handles text/plain requests [#1522](https://github.com/yesodweb/yesod/pull/1520)

yesod-core/Yesod/Core/Handler.hs

@@ -1289,15 +1289,9 @@ selectRep w = do
         [] ->
             case reps of
                 [] -> sendResponseStatus H.status500 ("No reps provided to selectRep" :: Text)
-                rep:_ ->
+                rep:_ -> returnRep rep
-                  if null cts
-                    then returnRep rep
-                    else sendResponseStatus H.status406 explainUnaccepted
         rep:_ -> returnRep rep
   where
-    explainUnaccepted :: Text
-    explainUnaccepted = "no match found for accept header"
-
     returnRep (ProvidedRep ct mcontent) = fmap (TypedContent ct) mcontent
 
     reps = appEndo (Writer.execWriter w) []

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -40,6 +40,11 @@ mkYesod "App" [parseRoutes|
 /file-bad-name FileBadNameR GET
 
 /good-builder GoodBuilderR GET
+
+/auth-not-accepted AuthNotAcceptedR GET
+/auth-not-adequate AuthNotAdequateR GET
+/args-not-valid ArgsNotValidR POST
+/only-plain-text OnlyPlainTextR GET
 |]
 
 overrideStatus :: Status
@@ -119,6 +124,18 @@ getErrorR 9 = setUltDest (undefined :: Text)
 getErrorR 10 = setMessage undefined
 getErrorR x = error $ "getErrorR: " ++ show x
 
+getAuthNotAcceptedR :: Handler TypedContent
+getAuthNotAcceptedR = notAuthenticated
+
+getAuthNotAdequateR :: Handler TypedContent
+getAuthNotAdequateR = permissionDenied "That doesn't belong to you. "
+
+postArgsNotValidR :: Handler TypedContent
+postArgsNotValidR = invalidArgs ["Doesn't matter.", "Don't want it."]
+
+getOnlyPlainTextR :: Handler TypedContent
+getOnlyPlainTextR = selectRep $ provideRepType "text/plain" $ return ("Only plain text." :: Text)
+
 errorHandlingTest :: Spec
 errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "says not found" caseNotFound
@@ -132,6 +149,11 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "file with bad name" caseFileBadName
       it "builder includes content-length" caseGoodBuilder
       forM_ [1..10] $ \i -> it ("error case " ++ show i) (caseError i)
+      it "accept DVI file, invalid args -> 400" caseDviInvalidArgs
+      it "accept audio, not authenticated -> 401" caseAudioNotAuthenticated
+      it "accept CSS, permission denied -> 403" caseCssPermissionDenied
+      it "accept image, non-existent path -> 404" caseImageNotFound
+      it "accept video, bad method -> 405" caseVideoBadMethod
 
 runner :: Session a -> IO a
 runner f = toWaiApp App >>= runSession f
@@ -222,3 +244,50 @@ caseError i = runner $ do
     ReaderT $ \r -> StateT $ \s -> runStateT (runReaderT (assertStatus 500 res) r) s `E.catch` \e -> do
         liftIO $ print res
         E.throwIO (e :: E.SomeException)
+
+caseDviInvalidArgs :: IO ()
+caseDviInvalidArgs = runner $ do
+    res <- request defaultRequest
+            { pathInfo = ["args-not-valid"]
+            , requestMethod = "POST"
+            , requestHeaders =
+                ("accept", "application/x-dvi") : requestHeaders defaultRequest
+            }
+    assertStatus 400 res
+
+caseAudioNotAuthenticated :: IO ()
+caseAudioNotAuthenticated = runner $ do
+    res <- request defaultRequest
+            { pathInfo = ["auth-not-accepted"]
+            , requestHeaders =
+                ("accept", "audio/mpeg") : requestHeaders defaultRequest
+            }
+    assertStatus 401 res
+
+caseCssPermissionDenied :: IO ()
+caseCssPermissionDenied = runner $ do
+    res <- request defaultRequest
+            { pathInfo = ["auth-not-adequate"]
+            , requestHeaders =
+                ("accept", "text/css") : requestHeaders defaultRequest
+            }
+    assertStatus 403 res
+
+caseImageNotFound :: IO ()
+caseImageNotFound = runner $ do
+    res <- request defaultRequest
+            { pathInfo = ["not_a_path"]
+            , requestHeaders =
+                ("accept", "image/jpeg") : requestHeaders defaultRequest
+            }
+    assertStatus 404 res
+
+caseVideoBadMethod :: IO ()
+caseVideoBadMethod = runner $ do
+    res <- request defaultRequest
+            { pathInfo = ["good-builder"]
+            , requestMethod = "DELETE"
+            , requestHeaders =
+                ("accept", "video/webm") : requestHeaders defaultRequest
+            }
+    assertStatus 405 res

yesod-core/test/YesodCoreTest/Reps.hs

@@ -85,7 +85,6 @@ specs = do
     test "text/html" "HTML"
     test specialHtml "HTMLSPECIAL"
     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"
   describe "routeAttrs" $ do

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.6.6
+version:         1.6.7
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>