eeva/servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Don't succeedWith when response content-type is unacceptable.

Browse Source
This commit is contained in:
Julian K. Arni 2015-04-06 16:12:28 +02:00
parent 25d1e466e9
commit 622c77251e
2 changed files with 28 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
src/Servant/Server/Internal.hs
View File

@ -273,14 +273,14 @@ instance ( AllCTRender ctypes a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond . succeedWith $ case e of
respond $ case e of
Right output -> do
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> responseLBS (mkStatus 406 "Not Acceptable") [] ""
Just (contentT, body) -> responseLBS ok200 [ ("Content-Type"
, cs contentT)] body
Left (status, message) ->
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS ok200 [ ("Content-Type" , cs contentT)] body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
@ -351,14 +351,14 @@ instance ( AllCTRender ctypes a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond . succeedWith $ case e of
respond $ case e of
Right output -> do
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> responseLBS (mkStatus 406 "") [] ""
Just (contentT, body) -> responseLBS status201 [ ("Content-Type"
, cs contentT)] body
Left (status, message) ->
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status201 [ ("Content-Type" , cs contentT)] body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
@ -397,14 +397,14 @@ instance ( AllCTRender ctypes a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond . succeedWith $ case e of
respond $ case e of
Right output -> do
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> responseLBS (mkStatus 406 "") [] ""
Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
, cs contentT)] body
Left (status, message) ->
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
@ -441,14 +441,14 @@ instance ( AllCTRender ctypes a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond . succeedWith $ case e of
respond $ case e of
Right output -> do
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> responseLBS (mkStatus 406 "") [] ""
Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
, cs contentT)] body
Left (status, message) ->
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod

10
test/Servant/ServerSpec.hs
View File

@ -15,6 +15,7 @@ import Data.Monoid ((<>))
import Data.Proxy (Proxy (Proxy))
import Data.String (fromString)
import Data.String.Conversions (cs)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Network.HTTP.Types (hContentType, methodDelete,
methodPatch, methodPost, methodPut,
@ -31,8 +32,9 @@ import Test.Hspec.Wai (get, liftIO, matchStatus, post,
import Servant.API ((:<|>) (..), (:>), Capture, Delete,
Get, Header, JSON, MatrixFlag,
MatrixParam, MatrixParams, Patch,
Post, Put, QueryFlag, QueryParam,
QueryParams, Raw, ReqBody)
PlainText, Post, Put, QueryFlag,
QueryParam, QueryParams, Raw,
ReqBody)
import Servant.Server (Server, serve)
import Servant.Server.Internal (RouteMismatch (..))
@ -483,6 +485,7 @@ rawSpec = do
type AlternativeApi =
"foo" :> Get '[JSON] Person
:<|> "bar" :> Get '[JSON] Animal
:<|> "foo" :> Get '[PlainText] T.Text
unionApi :: Proxy AlternativeApi
unionApi = Proxy
@ -490,6 +493,7 @@ unionServer :: Server AlternativeApi
unionServer =
return alice
:<|> return jerry
:<|> return "a string"
unionSpec :: Spec
unionSpec = do
@ -504,6 +508,8 @@ unionSpec = do
liftIO $ do
decode' (simpleBody response_) `shouldBe`
Just jerry
it "checks all endpoints before returning 406" $ do
get "/foo" `shouldRespondWith` 200
-- | Test server error functionality.
errorsSpec :: Spec