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

Merge pull request #38 from haskell-servant/jkarni/fix-406

Browse source 
Don't succeedWith when response content-type is unacceptable.
This commit is contained in:
Julian Arni 2015-04-07 16:40:19 +02:00
commit 1eaed73794
2 changed files with 55 additions and 29 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

44
test/Servant/ServerSpec.hs
View file

@ -15,8 +15,10 @@ 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,
import Network.HTTP.Types (hAccept, hContentType,
methodDelete, methodGet,
methodPatch, methodPost, methodPut,
ok200, parseQuery, status409)
import Network.Wai (Application, Request, pathInfo,
@ -31,8 +33,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 (..))
@ -41,7 +44,7 @@ import Servant.Server.Internal (RouteMismatch (..))
data Person = Person {
name :: String,
age :: Integer
age :: Integer
}
deriving (Eq, Show, Generic)
@ -52,7 +55,7 @@ alice :: Person
alice = Person "Alice" 42
data Animal = Animal {
species :: String,
species :: String,
numberOfLegs :: Integer
}
deriving (Eq, Show, Generic)
@ -97,10 +100,13 @@ captureSpec :: Spec
captureSpec = do
describe "Servant.API.Capture" $ do
with (return (serve captureApi captureServer)) $ do
it "can capture parts of the 'pathInfo'" $ do
response <- get "/2"
liftIO $ do
decode' (simpleBody response) `shouldBe` Just tweety
liftIO $ decode' (simpleBody response) `shouldBe` Just tweety
it "returns 404 if the decoding fails" $ do
get "/notAnInt" `shouldRespondWith` 404
with (return (serve
(Proxy :: Proxy (Capture "captured" String :> Raw))
@ -120,18 +126,23 @@ getSpec = do
describe "Servant.API.Get" $ do
let server = return alice :<|> return ()
with (return $ serve getApi server) $ do
it "allows to GET a Person" $ do
response <- get "/"
return response `shouldRespondWith` 200
liftIO $ do
decode' (simpleBody response) `shouldBe` Just alice
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
it "throws 405 (wrong method) on POSTs" $ do
post "/" "" `shouldRespondWith` 405
post "/empty" "" `shouldRespondWith` 405
it "returns 204 if the type is '()'" $ do
get "empty" `shouldRespondWith` ""{ matchStatus = 204 }
it "returns 415 if the Accept header is not supported" $ do
Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 415
type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
@ -483,6 +494,10 @@ rawSpec = do
type AlternativeApi =
"foo" :> Get '[JSON] Person
:<|> "bar" :> Get '[JSON] Animal
:<|> "foo" :> Get '[PlainText] T.Text
:<|> "bar" :> Post '[JSON] Animal
:<|> "bar" :> Put '[JSON] Animal
:<|> "bar" :> Delete
unionApi :: Proxy AlternativeApi
unionApi = Proxy
@ -490,11 +505,16 @@ unionServer :: Server AlternativeApi
unionServer =
return alice
:<|> return jerry
:<|> return "a string"
:<|> return jerry
:<|> return jerry
:<|> return ()
unionSpec :: Spec
unionSpec = do
describe "Servant.API.Alternative" $ do
with (return $ serve unionApi unionServer) $ do
it "unions endpoints" $ do
response <- get "/foo"
liftIO $ do
@ -505,6 +525,12 @@ unionSpec = do
decode' (simpleBody response_) `shouldBe`
Just jerry
it "checks all endpoints before returning 415" $ do
get "/foo" `shouldRespondWith` 200
it "returns 404 if the path does not exist" $ do
get "/nonexistent" `shouldRespondWith` 404
-- | Test server error functionality.
errorsSpec :: Spec
errorsSpec = do