Merge pull request #937 from potomak/subserver-content-types

Update request content-type handling

Author: phadej

servant-server/src/Servant/Server/Internal.hs

@@ -603,7 +603,7 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
         let contentTypeH = fromMaybe "application/octet-stream"
                          $ lookup hContentType $ requestHeaders request
         case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of
-          Nothing -> delayedFailFatal err415
+          Nothing -> delayedFail err415
           Just f  -> return f
 
       -- Body check, we get a body parsing functions as the first argument.

servant-server/test/Servant/Server/ErrorSpec.hs

@@ -247,6 +247,8 @@ type ErrorChoiceApi
   :<|> "path3" :> ReqBody '[JSON] Int :> Post '[PlainText] Int        -- 3
   :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int  -- 4
              :<|>  ReqBody '[PlainText] Int :> Post '[JSON] Int)      -- 5
+  :<|> "path5" :> (ReqBody '[JSON] Int      :> Post '[PlainText] Int  -- 6
+             :<|>  ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- 7
 
 errorChoiceApi :: Proxy ErrorChoiceApi
 errorChoiceApi = Proxy
@@ -256,8 +258,8 @@ errorChoiceServer = return 0
                :<|> return 1
                :<|> return 2
                :<|> (\_ -> return 3)
-               :<|> (\_ -> return 4)
-               :<|> (\_ -> return 5)
+               :<|> ((\_ -> return 4) :<|> (\_ -> return 5))
+               :<|> ((\_ -> return 6) :<|> (\_ -> return 7))
 
 
 errorChoiceSpec :: Spec
@@ -278,6 +280,13 @@ errorChoiceSpec = describe "Multiple handlers return errors"
     request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"),
                                 (hAccept, "blah")] "5"
       `shouldRespondWith` 406
+  it "should respond with 415 only if none of the subservers supports the request's content type" $ do
+    request methodPost "path5" [(hContentType, "text/plain;charset=utf-8")] "1"
+      `shouldRespondWith` 200
+    request methodPost "path5" [(hContentType, "application/json")] "1"
+      `shouldRespondWith` 200
+    request methodPost "path5" [(hContentType, "application/not-supported")] ""
+      `shouldRespondWith` 415
 
 
 -- }}}