1eaed73 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

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

1eaed73Julian Arni12 years ago

src/Servant/Server/Internal.hs+20−20

compare with master

unifiedsplit

@@ -273,14 +273,14 @@ instance ( AllCTRender ctypes a

273 route Proxy action request respond

274 | pathIsEmpty request && requestMethod request == methodGet = do

275 e <- runEitherT action

276− respond . succeedWith $ case e of

276+ respond $ case e of

277 Right output -> do

278 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request

279 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

280− Nothing -> responseLBS (mkStatus 406 "Not Acceptable") [] ""

280+ Nothing -> failWith UnsupportedMediaType

281+ Just (contentT, body) -> succeedWith $

281− Just (contentT, body) -> responseLBS ok200 [ ("Content-Type"

282+ responseLBS ok200 [ ("Content-Type" , cs contentT)] body

282− , cs contentT)] body

283− Left (status, message) ->

283+ Left (status, message) -> succeedWith $

284 responseLBS (mkStatus status (cs message)) [] (cs message)

285 | pathIsEmpty request && requestMethod request /= methodGet =

286 respond $ failWith WrongMethod

@@ -351,14 +351,14 @@ instance ( AllCTRender ctypes a

351 route Proxy action request respond

352 | pathIsEmpty request && requestMethod request == methodPost = do

353 e <- runEitherT action

354− respond . succeedWith $ case e of

354+ respond $ case e of

355 Right output -> do

356 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request

357 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

358− Nothing -> responseLBS (mkStatus 406 "") [] ""

358+ Nothing -> failWith UnsupportedMediaType

359+ Just (contentT, body) -> succeedWith $

359− Just (contentT, body) -> responseLBS status201 [ ("Content-Type"

360+ responseLBS status201 [ ("Content-Type" , cs contentT)] body

360− , cs contentT)] body

361− Left (status, message) ->

361+ Left (status, message) -> succeedWith $

362 responseLBS (mkStatus status (cs message)) [] (cs message)

363 | pathIsEmpty request && requestMethod request /= methodPost =

364 respond $ failWith WrongMethod

@@ -397,14 +397,14 @@ instance ( AllCTRender ctypes a

397 route Proxy action request respond

398 | pathIsEmpty request && requestMethod request == methodPut = do

399 e <- runEitherT action

400− respond . succeedWith $ case e of

400+ respond $ case e of

401 Right output -> do

402 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request

403 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

404− Nothing -> responseLBS (mkStatus 406 "") [] ""

404+ Nothing -> failWith UnsupportedMediaType

405+ Just (contentT, body) -> succeedWith $

405− Just (contentT, body) -> responseLBS status200 [ ("Content-Type"

406+ responseLBS status200 [ ("Content-Type" , cs contentT)] body

406− , cs contentT)] body

407− Left (status, message) ->

407+ Left (status, message) -> succeedWith $

408 responseLBS (mkStatus status (cs message)) [] (cs message)

409 | pathIsEmpty request && requestMethod request /= methodPut =

410 respond $ failWith WrongMethod

@@ -441,14 +441,14 @@ instance ( AllCTRender ctypes a

441 route Proxy action request respond

442 | pathIsEmpty request && requestMethod request == methodPatch = do

443 e <- runEitherT action

444− respond . succeedWith $ case e of

444+ respond $ case e of

445 Right output -> do

446 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request

447 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

448− Nothing -> responseLBS (mkStatus 406 "") [] ""

448+ Nothing -> failWith UnsupportedMediaType

449+ Just (contentT, body) -> succeedWith $

449− Just (contentT, body) -> responseLBS status200 [ ("Content-Type"

450+ responseLBS status200 [ ("Content-Type" , cs contentT)] body

450− , cs contentT)] body

451− Left (status, message) ->

451+ Left (status, message) -> succeedWith $

452 responseLBS (mkStatus status (cs message)) [] (cs message)

453 | pathIsEmpty request && requestMethod request /= methodPatch =

454 respond $ failWith WrongMethod

test/Servant/ServerSpec.hs+35−9

@@ -15,8 +15,10 @@ import Data.Monoid ((<>))

15import Data.Proxy (Proxy (Proxy))

16import Data.String (fromString)

17import Data.String.Conversions (cs)

18+import qualified Data.Text as T

18import GHC.Generics (Generic)

19import GHC.Generics (Generic)

19−import Network.HTTP.Types (hContentType, methodDelete,

20+import Network.HTTP.Types (hAccept, hContentType,

21+ methodDelete, methodGet,

20 methodPatch, methodPost, methodPut,

22 methodPatch, methodPost, methodPut,

21 ok200, parseQuery, status409)

23 ok200, parseQuery, status409)

22import Network.Wai (Application, Request, pathInfo,

24import Network.Wai (Application, Request, pathInfo,

@@ -31,8 +33,9 @@ import Test.Hspec.Wai (get, liftIO, matchStatus, post,

31import Servant.API ((:<|>) (..), (:>), Capture, Delete,

33import Servant.API ((:<|>) (..), (:>), Capture, Delete,

32 Get, Header, JSON, MatrixFlag,

34 Get, Header, JSON, MatrixFlag,

33 MatrixParam, MatrixParams, Patch,

35 MatrixParam, MatrixParams, Patch,

34− Post, Put, QueryFlag, QueryParam,

36+ PlainText, Post, Put, QueryFlag,

35− QueryParams, Raw, ReqBody)

37+ QueryParam, QueryParams, Raw,

38+ ReqBody)

36import Servant.Server (Server, serve)

39import Servant.Server (Server, serve)

37import Servant.Server.Internal (RouteMismatch (..))

40import Servant.Server.Internal (RouteMismatch (..))

@@ -41,7 +44,7 @@ import Servant.Server.Internal (RouteMismatch (..))

42data Person = Person {

45data Person = Person {

43 name :: String,

46 name :: String,

44− age :: Integer

47+ age :: Integer

45 }

48 }

46 deriving (Eq, Show, Generic)

49 deriving (Eq, Show, Generic)

@@ -52,7 +55,7 @@ alice :: Person

52alice = Person "Alice" 42

55alice = Person "Alice" 42

54data Animal = Animal {

57data Animal = Animal {

55− species :: String,

58+ species :: String,

56 numberOfLegs :: Integer

59 numberOfLegs :: Integer

57 }

60 }

58 deriving (Eq, Show, Generic)

61 deriving (Eq, Show, Generic)

@@ -97,10 +100,13 @@ captureSpec :: Spec

97captureSpec = do

100captureSpec = do

98 describe "Servant.API.Capture" $ do

101 describe "Servant.API.Capture" $ do

99 with (return (serve captureApi captureServer)) $ do

102 with (return (serve captureApi captureServer)) $ do

103+

100 it "can capture parts of the 'pathInfo'" $ do

104 it "can capture parts of the 'pathInfo'" $ do

101 response <- get "/2"

105 response <- get "/2"

102− liftIO $ do

103− decode' (simpleBody response) `shouldBe` Just tweety

106+ liftIO $ decode' (simpleBody response) `shouldBe` Just tweety

107+

108+ it "returns 404 if the decoding fails" $ do

109+ get "/notAnInt" `shouldRespondWith` 404

104

110

105 with (return (serve

111 with (return (serve

106 (Proxy :: Proxy (Capture "captured" String :> Raw))

112 (Proxy :: Proxy (Capture "captured" String :> Raw))

@@ -120,18 +126,23 @@ getSpec = do

120 describe "Servant.API.Get" $ do

126 describe "Servant.API.Get" $ do

121 let server = return alice :<|> return ()

127 let server = return alice :<|> return ()

122 with (return $ serve getApi server) $ do

128 with (return $ serve getApi server) $ do

129+

123 it "allows to GET a Person" $ do

130 it "allows to GET a Person" $ do

124 response <- get "/"

131 response <- get "/"

125 return response `shouldRespondWith` 200

132 return response `shouldRespondWith` 200

126− liftIO $ do

127− decode' (simpleBody response) `shouldBe` Just alice

133+ liftIO $ decode' (simpleBody response) `shouldBe` Just alice

128

134

129 it "throws 405 (wrong method) on POSTs" $ do

135 it "throws 405 (wrong method) on POSTs" $ do

130 post "/" "" `shouldRespondWith` 405

136 post "/" "" `shouldRespondWith` 405

137+ post "/empty" "" `shouldRespondWith` 405

131

138

132 it "returns 204 if the type is '()'" $ do

139 it "returns 204 if the type is '()'" $ do

133 get "empty" `shouldRespondWith` ""{ matchStatus = 204 }

140 get "empty" `shouldRespondWith` ""{ matchStatus = 204 }

134

141

142+ it "returns 415 if the Accept header is not supported" $ do

143+ Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""

144+ `shouldRespondWith` 415

145+

135

146

136

147

137type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person

148type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person

@@ -483,6 +494,10 @@ rawSpec = do

483type AlternativeApi =

494type AlternativeApi =

484 "foo" :> Get '[JSON] Person

495 "foo" :> Get '[JSON] Person

485 :<|> "bar" :> Get '[JSON] Animal

496 :<|> "bar" :> Get '[JSON] Animal

497+ :<|> "foo" :> Get '[PlainText] T.Text

498+ :<|> "bar" :> Post '[JSON] Animal

499+ :<|> "bar" :> Put '[JSON] Animal

500+ :<|> "bar" :> Delete

486unionApi :: Proxy AlternativeApi

501unionApi :: Proxy AlternativeApi

487unionApi = Proxy

502unionApi = Proxy

488

503

@@ -490,11 +505,16 @@ unionServer :: Server AlternativeApi

490unionServer =

505unionServer =

491 return alice

506 return alice

492 :<|> return jerry

507 :<|> return jerry

508+ :<|> return "a string"

509+ :<|> return jerry

510+ :<|> return jerry

511+ :<|> return ()

493

512

494unionSpec :: Spec

513unionSpec :: Spec

495unionSpec = do

514unionSpec = do

496 describe "Servant.API.Alternative" $ do

515 describe "Servant.API.Alternative" $ do

497 with (return $ serve unionApi unionServer) $ do

516 with (return $ serve unionApi unionServer) $ do

517+

498 it "unions endpoints" $ do

518 it "unions endpoints" $ do

499 response <- get "/foo"

519 response <- get "/foo"

500 liftIO $ do

520 liftIO $ do

@@ -505,6 +525,12 @@ unionSpec = do

505 decode' (simpleBody response_) `shouldBe`

525 decode' (simpleBody response_) `shouldBe`

506 Just jerry

526 Just jerry

507

527

528+ it "checks all endpoints before returning 415" $ do

529+ get "/foo" `shouldRespondWith` 200

530+

531+ it "returns 404 if the path does not exist" $ do

532+ get "/nonexistent" `shouldRespondWith` 404

533+

508-- | Test server error functionality.

534-- | Test server error functionality.

509errorsSpec :: Spec

535errorsSpec :: Spec

510errorsSpec = do

536errorsSpec = do