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

10
test/Servant/ServerSpec.hs
View file

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