Merge remote-tracking branch 'origin/master' into shahn/config
Conflicts: servant-server/test/Servant/ServerSpec.hs
This commit is contained in:
Sönke Hahn
commit
33cc9958ed
9 changed files with 328 additions and 307 deletions
79
CONTRIBUTING.md
Normal file
79
CONTRIBUTING.md
Normal file
|
|
@ -0,0 +1,79 @@
|
|||
# Contributing Guidelines
|
||||
|
||||
Contributions are very welcome! To hack on the github version, clone the
|
||||
repository. You can use `cabal`:
|
||||
|
||||
```shell
|
||||
./scripts/start-sandbox.sh # Initialize the sandbox and add-source the packages
|
||||
./scripts/test-all.sh # Run all the tests
|
||||
```
|
||||
|
||||
`stack`:
|
||||
|
||||
```shell
|
||||
stack build # Install and build packages
|
||||
stack test # Run all the tests
|
||||
```
|
||||
|
||||
Or `nix`:
|
||||
```shell
|
||||
./scripts/generate-nix-files.sh # Get up-to-date shell.nix files
|
||||
```
|
||||
|
||||
|
||||
## General
|
||||
|
||||
Some things we like:
|
||||
|
||||
- Explicit imports
|
||||
- Upper and lower bounds for packages
|
||||
- Few dependencies
|
||||
- -Werror-compatible (for both 7.8 and 7.10)
|
||||
|
||||
Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs`
|
||||
files in the repository provide a good baseline for consistency.
|
||||
|
||||
Please include a description of the changes in your PR in the `CHANGELOG.md` of
|
||||
the packages you've changed. And of course, write tests!
|
||||
|
||||
## PR process
|
||||
|
||||
We try to give timely reviews to PRs that pass CI. If CI for your PR fails, we
|
||||
may close the PR if it has been open for too long (though you should feel free
|
||||
to reopen when the issues have been fixed).
|
||||
|
||||
We require two +1 from the maintainers of the repo. If you feel like there has
|
||||
not been a timely response to a PR, you can ping the Maintainers group (with
|
||||
`@Maintainers`).
|
||||
|
||||
## New combinators
|
||||
|
||||
We encourage people to experiment with new combinators and instances - it is
|
||||
one of the most powerful ways of using `servant`, and a wonderful way of
|
||||
getting to know it better. If you do write a new combinator, we would love to
|
||||
know about it! Either hop on #servant on freenode and let us know, or open an
|
||||
issue with the `news` tag (which we will close when we read it).
|
||||
|
||||
As for adding them to the main repo: maintaining combinators can be expensive,
|
||||
since official combinators must have instances for all classes (and new classes
|
||||
come along fairly frequently). We therefore have to be quite selective about
|
||||
those that we accept. If you're considering writing a new combinator, open an
|
||||
issue to discuss it first! (You could release your combinator as a separate
|
||||
package, of course.)
|
||||
|
||||
|
||||
## New classes
|
||||
|
||||
The main benefit of having a new class and package in the main servant repo is
|
||||
that we get to see via CI whether changes to other packages break the build.
|
||||
Open an issue to discuss whether a package should be added to the main repo. If
|
||||
we decide that it can, you can still keep maintainership over it.
|
||||
|
||||
Whether or not you want your package to be in the repo, create an issue with
|
||||
the `news` label if you make a new package so we can know about it!
|
||||
|
||||
## Release policy
|
||||
|
||||
We are currently moving to a more aggresive release policy, so that you can get
|
||||
what you contribute from Hackage fairly soon. However, note that prior to major
|
||||
releases it may take some time in between releases.
|
||||
27
README.md
27
README.md
|
|
@ -17,29 +17,4 @@ list](https://groups.google.com/forum/#!forum/haskell-servant).
|
|||
|
||||
## Contributing
|
||||
|
||||
Contributions are very welcome! To hack on the github version, clone the
|
||||
repository. You can use `cabal`:
|
||||
|
||||
```shell
|
||||
./scripts/start-sandbox.sh # Initialize the sandbox and add-source the packages
|
||||
./scripts/test-all.sh # Run all the tests
|
||||
```
|
||||
|
||||
`stack`:
|
||||
|
||||
```shell
|
||||
stack build # Install and build packages
|
||||
stack test # Run all the tests
|
||||
```
|
||||
|
||||
Or `nix`:
|
||||
```shell
|
||||
./scripts/generate-nix-files.sh # Get up-to-date shell.nix files
|
||||
```
|
||||
|
||||
Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs`
|
||||
files in the repository provide a good baseline for consistency.
|
||||
|
||||
Please include a description of the changes in your PR in the `CHANGELOG.md` of
|
||||
the packages you've changed. And of course, write tests!
|
||||
|
||||
See `CONTRIBUTING.md`
|
||||
|
|
|
|||
|
|
@ -24,7 +24,6 @@ module Servant.Client
|
|||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.List
|
||||
|
|
@ -420,6 +419,6 @@ It may seem to make more sense to have:
|
|||
|
||||
But this means that if another instance exists that does *not* require
|
||||
non-empty lists, but is otherwise more specific, no instance will be overall
|
||||
more specific. This in turns generally means adding yet another instance (one
|
||||
more specific. This in turn generally means adding yet another instance (one
|
||||
for empty and one for non-empty lists).
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -156,7 +156,7 @@ performRequest reqMethod req reqHost manager = do
|
|||
|
||||
performRequestCT :: MimeUnrender ct result =>
|
||||
Proxy ct -> Method -> Req -> BaseUrl -> Manager
|
||||
-> ExceptT ServantError IO ([HTTP.Header], result)
|
||||
-> ExceptT ServantError IO ([HTTP.Header], result)
|
||||
performRequestCT ct reqMethod req reqHost manager = do
|
||||
let acceptCT = contentType ct
|
||||
(_status, respBody, respCT, hdrs, _response) <-
|
||||
|
|
|
|||
|
|
@ -3,8 +3,10 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
|
|
@ -13,7 +15,7 @@ module Servant.ServerSpec where
|
|||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Control.Monad (forM_, when)
|
||||
import Control.Monad (forM_, when, unless)
|
||||
import Control.Monad.Trans.Except (ExceptT, throwE)
|
||||
import Data.Aeson (FromJSON, ToJSON, decode', encode)
|
||||
import Data.ByteString.Conversion ()
|
||||
|
|
@ -33,79 +35,134 @@ import Network.Wai (Application, Request, pathInfo,
|
|||
responseBuilder, responseLBS)
|
||||
import Network.Wai.Internal (Response (ResponseBuilder))
|
||||
import Network.Wai.Test (defaultRequest, request,
|
||||
runSession, simpleBody)
|
||||
runSession, simpleBody,
|
||||
simpleHeaders, simpleStatus)
|
||||
import Servant.API ((:<|>) (..), (:>), Capture, Delete,
|
||||
Get, Header (..), Headers,
|
||||
HttpVersion, IsSecure (..), JSON,
|
||||
Patch, PlainText, Post, Put,
|
||||
Get, Header (..),
|
||||
Headers, HttpVersion,
|
||||
IsSecure (..), JSON,
|
||||
NoContent (..), Patch, PlainText,
|
||||
Post, Put,
|
||||
QueryFlag, QueryParam, QueryParams,
|
||||
Raw, RemoteHost, ReqBody, GetNoContent,
|
||||
PostNoContent, addHeader, NoContent(..))
|
||||
-- import Servant.Server (Server, serve, ServantErr(..), err404)
|
||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||
Raw, RemoteHost, ReqBody,
|
||||
StdMethod (..), Verb, addHeader)
|
||||
import Servant.Server (ServantErr (..), Server, err404,
|
||||
serve, Config(EmptyConfig))
|
||||
import Test.Hspec (Spec, context, describe, it,
|
||||
shouldBe, shouldContain)
|
||||
import Test.Hspec.Wai (get, liftIO, matchHeaders,
|
||||
matchStatus, post, request,
|
||||
matchStatus, request,
|
||||
shouldRespondWith, with, (<:>))
|
||||
|
||||
import Servant.Server (Config(EmptyConfig),
|
||||
ServantErr (..),
|
||||
Server, err404,
|
||||
serve)
|
||||
import Servant.Server.Internal.Router (Router, Router' (LeafRouter),
|
||||
runRouter,
|
||||
tweakResponse)
|
||||
import Servant.Server.Internal.RoutingApplication (RouteResult (..),
|
||||
toApplication)
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
(toApplication, RouteResult(..))
|
||||
import Servant.Server.Internal.Router
|
||||
(tweakResponse, runRouter,
|
||||
Router, Router'(LeafRouter))
|
||||
|
||||
|
||||
-- * test data types
|
||||
|
||||
data Person = Person {
|
||||
name :: String,
|
||||
age :: Integer
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON Person
|
||||
instance FromJSON Person
|
||||
|
||||
alice :: Person
|
||||
alice = Person "Alice" 42
|
||||
|
||||
data Animal = Animal {
|
||||
species :: String,
|
||||
numberOfLegs :: Integer
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON Animal
|
||||
instance FromJSON Animal
|
||||
|
||||
jerry :: Animal
|
||||
jerry = Animal "Mouse" 4
|
||||
|
||||
tweety :: Animal
|
||||
tweety = Animal "Bird" 2
|
||||
|
||||
|
||||
-- * specs
|
||||
-- * Specs
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
verbSpec
|
||||
captureSpec
|
||||
getSpec
|
||||
headSpec
|
||||
postSpec
|
||||
putSpec
|
||||
patchSpec
|
||||
queryParamSpec
|
||||
reqBodySpec
|
||||
headerSpec
|
||||
rawSpec
|
||||
unionSpec
|
||||
routerSpec
|
||||
alternativeSpec
|
||||
responseHeadersSpec
|
||||
miscReqCombinatorsSpec
|
||||
routerSpec
|
||||
miscCombinatorSpec
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- * verbSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
type VerbApi method status
|
||||
= Verb method status '[JSON] Person
|
||||
:<|> "noContent" :> Verb method status '[JSON] NoContent
|
||||
:<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)
|
||||
:<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)
|
||||
|
||||
verbSpec :: Spec
|
||||
verbSpec = describe "Servant.API.Verb" $ do
|
||||
let server :: Server (VerbApi method status)
|
||||
server = return alice
|
||||
:<|> return NoContent
|
||||
:<|> return (addHeader 5 alice)
|
||||
:<|> return (addHeader 10 NoContent)
|
||||
get200 = Proxy :: Proxy (VerbApi 'GET 200)
|
||||
post210 = Proxy :: Proxy (VerbApi 'POST 210)
|
||||
put203 = Proxy :: Proxy (VerbApi 'PUT 203)
|
||||
delete280 = Proxy :: Proxy (VerbApi 'DELETE 280)
|
||||
patch214 = Proxy :: Proxy (VerbApi 'PATCH 214)
|
||||
wrongMethod m = if m == methodPatch then methodPost else methodPatch
|
||||
test desc api method (status :: Int) = context desc $
|
||||
|
||||
with (return $ serve api EmptyConfig server) $ do
|
||||
|
||||
-- HEAD and 214/215 need not return bodies
|
||||
unless (status `elem` [214, 215] || method == methodHead) $
|
||||
it "returns the person" $ do
|
||||
response <- Test.Hspec.Wai.request method "/" [] ""
|
||||
liftIO $ statusCode (simpleStatus response) `shouldBe` status
|
||||
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
|
||||
|
||||
it "returns no content on NoContent" $ do
|
||||
response <- Test.Hspec.Wai.request method "/noContent" [] ""
|
||||
liftIO $ statusCode (simpleStatus response) `shouldBe` status
|
||||
liftIO $ simpleBody response `shouldBe` ""
|
||||
|
||||
-- HEAD should not return body
|
||||
when (method == methodHead) $
|
||||
it "HEAD returns no content body" $ do
|
||||
response <- Test.Hspec.Wai.request method "/" [] ""
|
||||
liftIO $ simpleBody response `shouldBe` ""
|
||||
|
||||
it "throws 405 on wrong method " $ do
|
||||
Test.Hspec.Wai.request (wrongMethod method) "/" [] ""
|
||||
`shouldRespondWith` 405
|
||||
|
||||
it "returns headers" $ do
|
||||
response1 <- Test.Hspec.Wai.request method "/header" [] ""
|
||||
liftIO $ statusCode (simpleStatus response1) `shouldBe` status
|
||||
liftIO $ simpleHeaders response1 `shouldContain` [("H", "5")]
|
||||
|
||||
response2 <- Test.Hspec.Wai.request method "/header" [] ""
|
||||
liftIO $ statusCode (simpleStatus response2) `shouldBe` status
|
||||
liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")]
|
||||
|
||||
it "handles trailing '/' gracefully" $ do
|
||||
response <- Test.Hspec.Wai.request method "/headerNC/" [] ""
|
||||
liftIO $ statusCode (simpleStatus response) `shouldBe` status
|
||||
|
||||
it "returns 406 if the Accept header is not supported" $ do
|
||||
Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
|
||||
`shouldRespondWith` 406
|
||||
|
||||
it "responds if the Accept header is supported" $ do
|
||||
response <- Test.Hspec.Wai.request method ""
|
||||
[(hAccept, "application/json")] ""
|
||||
liftIO $ statusCode (simpleStatus response) `shouldBe` status
|
||||
|
||||
it "sets the Content-Type header" $ do
|
||||
response <- Test.Hspec.Wai.request method "" [] ""
|
||||
liftIO $ simpleHeaders response `shouldContain`
|
||||
[("Content-Type", "application/json")]
|
||||
|
||||
test "GET 200" get200 methodGet 200
|
||||
test "POST 210" post210 methodPost 210
|
||||
test "PUT 203" put203 methodPut 203
|
||||
test "DELETE 280" delete280 methodDelete 280
|
||||
test "PATCH 214" patch214 methodPatch 214
|
||||
test "GET 200 with HEAD" get200 methodHead 200
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * captureSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
|
||||
captureApi :: Proxy CaptureApi
|
||||
|
|
@ -136,68 +193,10 @@ captureSpec = do
|
|||
it "strips the captured path snippet from pathInfo" $ do
|
||||
get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
|
||||
|
||||
|
||||
type GetApi = Get '[JSON] Person
|
||||
:<|> "empty" :> GetNoContent '[JSON] NoContent
|
||||
:<|> "emptyWithHeaders" :> GetNoContent '[JSON] (Headers '[Header "H" Int] NoContent)
|
||||
:<|> "post" :> PostNoContent '[JSON] NoContent
|
||||
|
||||
getApi :: Proxy GetApi
|
||||
getApi = Proxy
|
||||
|
||||
getSpec :: Spec
|
||||
getSpec = do
|
||||
describe "Servant.API.Get" $ do
|
||||
let server = return alice
|
||||
:<|> return NoContent
|
||||
:<|> return (addHeader 5 NoContent)
|
||||
:<|> return NoContent
|
||||
|
||||
with (return $ serve getApi EmptyConfig server) $ do
|
||||
|
||||
it "allows to GET a Person" $ do
|
||||
response <- get "/"
|
||||
return response `shouldRespondWith` 200
|
||||
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
|
||||
|
||||
it "throws 405 (wrong method) on POSTs" $ do
|
||||
post "/" "" `shouldRespondWith` 405
|
||||
post "/empty" "" `shouldRespondWith` 405
|
||||
|
||||
it "returns headers" $ do
|
||||
get "/emptyWithHeaders" `shouldRespondWith` 204 { matchHeaders = [ "H" <:> "5" ] }
|
||||
|
||||
it "returns 406 if the Accept header is not supported" $ do
|
||||
Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
|
||||
`shouldRespondWith` 406
|
||||
|
||||
|
||||
headSpec :: Spec
|
||||
headSpec = do
|
||||
describe "Servant.API.Head" $ do
|
||||
let server = return alice
|
||||
:<|> return NoContent
|
||||
:<|> return (addHeader 5 NoContent)
|
||||
:<|> return NoContent
|
||||
with (return $ serve getApi EmptyConfig server) $ do
|
||||
|
||||
it "allows to GET a Person" $ do
|
||||
response <- Test.Hspec.Wai.request methodHead "/" [] ""
|
||||
return response `shouldRespondWith` 200
|
||||
liftIO $ decode' (simpleBody response) `shouldBe` (Nothing :: Maybe Person)
|
||||
|
||||
it "does not allow HEAD to POST route" $ do
|
||||
response <- Test.Hspec.Wai.request methodHead "/post" [] ""
|
||||
return response `shouldRespondWith` 405
|
||||
|
||||
it "throws 405 (wrong method) on POSTs" $ do
|
||||
post "/" "" `shouldRespondWith` 405
|
||||
post "/empty" "" `shouldRespondWith` 405
|
||||
|
||||
it "returns 406 if the Accept header is not supported" $ do
|
||||
Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""
|
||||
`shouldRespondWith` 406
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * queryParamSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
|
||||
:<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
|
||||
|
|
@ -282,122 +281,41 @@ queryParamSpec = do
|
|||
name = "Alice"
|
||||
}
|
||||
|
||||
type PostApi =
|
||||
ReqBody '[JSON] Person :> Post '[JSON] Integer
|
||||
:<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
|
||||
:<|> "empty" :> Post '[JSON] ()
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * reqBodySpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
type ReqBodyApi = ReqBody '[JSON] Person :> Post '[JSON] Person
|
||||
:<|> "blah" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
|
||||
|
||||
postApi :: Proxy PostApi
|
||||
postApi = Proxy
|
||||
reqBodyApi :: Proxy ReqBodyApi
|
||||
reqBodyApi = Proxy
|
||||
|
||||
postSpec :: Spec
|
||||
postSpec = do
|
||||
describe "Servant.API.Post and .ReqBody" $ do
|
||||
let server = return . age :<|> return . age :<|> return ()
|
||||
with (return $ serve postApi EmptyConfig server) $ do
|
||||
let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
|
||||
, "application/json;charset=utf-8")]
|
||||
reqBodySpec :: Spec
|
||||
reqBodySpec = describe "Servant.API.ReqBody" $ do
|
||||
|
||||
it "allows to POST a Person" $ do
|
||||
post' "/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
let server :: Server ReqBodyApi
|
||||
server = return :<|> return . age
|
||||
mkReq method x = Test.Hspec.Wai.request method x
|
||||
[(hContentType, "application/json;charset=utf-8")]
|
||||
|
||||
it "allows alternative routes if all have request bodies" $ do
|
||||
post' "/bla" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
with (return $ serve reqBodyApi EmptyConfig server) $ do
|
||||
|
||||
it "handles trailing '/' gracefully" $ do
|
||||
post' "/bla/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
it "passes the argument to the handler" $ do
|
||||
response <- mkReq methodPost "" (encode alice)
|
||||
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
|
||||
|
||||
it "correctly rejects invalid request bodies with status 400" $ do
|
||||
post' "/" "some invalid body" `shouldRespondWith` 400
|
||||
it "rejects invalid request bodies with status 400" $ do
|
||||
mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400
|
||||
|
||||
it "responds with 415 if the request body media type is unsupported" $ do
|
||||
let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
|
||||
, "application/nonsense")]
|
||||
post'' "/" "anything at all" `shouldRespondWith` 415
|
||||
it "responds with 415 if the request body media type is unsupported" $ do
|
||||
Test.Hspec.Wai.request methodPost "/"
|
||||
[(hContentType, "application/nonsense")] "" `shouldRespondWith` 415
|
||||
|
||||
type PutApi =
|
||||
ReqBody '[JSON] Person :> Put '[JSON] Integer
|
||||
:<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
|
||||
:<|> "empty" :> Put '[JSON] ()
|
||||
|
||||
putApi :: Proxy PutApi
|
||||
putApi = Proxy
|
||||
|
||||
putSpec :: Spec
|
||||
putSpec = do
|
||||
describe "Servant.API.Put and .ReqBody" $ do
|
||||
let server = return . age :<|> return . age :<|> return ()
|
||||
with (return $ serve putApi EmptyConfig server) $ do
|
||||
let put' x = Test.Hspec.Wai.request methodPut x [(hContentType
|
||||
, "application/json;charset=utf-8")]
|
||||
|
||||
it "allows to put a Person" $ do
|
||||
put' "/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "allows alternative routes if all have request bodies" $ do
|
||||
put' "/bla" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "handles trailing '/' gracefully" $ do
|
||||
put' "/bla/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "correctly rejects invalid request bodies with status 400" $ do
|
||||
put' "/" "some invalid body" `shouldRespondWith` 400
|
||||
|
||||
it "responds with 415 if the request body media type is unsupported" $ do
|
||||
let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType
|
||||
, "application/nonsense")]
|
||||
put'' "/" "anything at all" `shouldRespondWith` 415
|
||||
|
||||
type PatchApi =
|
||||
ReqBody '[JSON] Person :> Patch '[JSON] Integer
|
||||
:<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer
|
||||
:<|> "empty" :> Patch '[JSON] ()
|
||||
|
||||
patchApi :: Proxy PatchApi
|
||||
patchApi = Proxy
|
||||
|
||||
patchSpec :: Spec
|
||||
patchSpec = do
|
||||
describe "Servant.API.Patch and .ReqBody" $ do
|
||||
let server = return . age :<|> return . age :<|> return ()
|
||||
with (return $ serve patchApi EmptyConfig server) $ do
|
||||
let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType
|
||||
, "application/json;charset=utf-8")]
|
||||
|
||||
it "allows to patch a Person" $ do
|
||||
patch' "/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "allows alternative routes if all have request bodies" $ do
|
||||
patch' "/bla" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "handles trailing '/' gracefully" $ do
|
||||
patch' "/bla/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "correctly rejects invalid request bodies with status 400" $ do
|
||||
patch' "/" "some invalid body" `shouldRespondWith` 400
|
||||
|
||||
it "responds with 415 if the request body media type is unsupported" $ do
|
||||
let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
|
||||
, "application/nonsense")]
|
||||
patch'' "/" "anything at all" `shouldRespondWith` 415
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * headerSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] ()
|
||||
headerApi :: Proxy (HeaderApi a)
|
||||
|
|
@ -426,12 +344,19 @@ headerSpec = describe "Servant.API.Header" $ do
|
|||
it "passes the header to the handler (String)" $
|
||||
delete' "/" "" `shouldRespondWith` 200
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * rawSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
type RawApi = "foo" :> Raw
|
||||
|
||||
rawApi :: Proxy RawApi
|
||||
rawApi = Proxy
|
||||
|
||||
rawApplication :: Show a => (Request -> a) -> Application
|
||||
rawApplication f request_ respond = respond $ responseLBS ok200 [] (cs $ show $ f request_)
|
||||
rawApplication f request_ respond = respond $ responseLBS ok200 []
|
||||
(cs $ show $ f request_)
|
||||
|
||||
rawSpec :: Spec
|
||||
rawSpec = do
|
||||
|
|
@ -452,7 +377,10 @@ rawSpec = do
|
|||
liftIO $ do
|
||||
simpleBody response `shouldBe` cs (show ["bar" :: String])
|
||||
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * alternativeSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
type AlternativeApi =
|
||||
"foo" :> Get '[JSON] Person
|
||||
:<|> "bar" :> Get '[JSON] Animal
|
||||
|
|
@ -460,11 +388,12 @@ type AlternativeApi =
|
|||
:<|> "bar" :> Post '[JSON] Animal
|
||||
:<|> "bar" :> Put '[JSON] Animal
|
||||
:<|> "bar" :> Delete '[JSON] ()
|
||||
unionApi :: Proxy AlternativeApi
|
||||
unionApi = Proxy
|
||||
|
||||
unionServer :: Server AlternativeApi
|
||||
unionServer =
|
||||
alternativeApi :: Proxy AlternativeApi
|
||||
alternativeApi = Proxy
|
||||
|
||||
alternativeServer :: Server AlternativeApi
|
||||
alternativeServer =
|
||||
return alice
|
||||
:<|> return jerry
|
||||
:<|> return "a string"
|
||||
|
|
@ -472,10 +401,10 @@ unionServer =
|
|||
:<|> return jerry
|
||||
:<|> return ()
|
||||
|
||||
unionSpec :: Spec
|
||||
unionSpec = do
|
||||
alternativeSpec :: Spec
|
||||
alternativeSpec = do
|
||||
describe "Servant.API.Alternative" $ do
|
||||
with (return $ serve unionApi EmptyConfig unionServer) $ do
|
||||
with (return $ serve alternativeApi EmptyConfig alternativeServer) $ do
|
||||
|
||||
it "unions endpoints" $ do
|
||||
response <- get "/foo"
|
||||
|
|
@ -492,7 +421,10 @@ unionSpec = do
|
|||
|
||||
it "returns 404 if the path does not exist" $ do
|
||||
get "/nonexistent" `shouldRespondWith` 404
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * responseHeaderSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
type ResponseHeadersApi =
|
||||
Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
|
||||
:<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
|
||||
|
|
@ -509,26 +441,29 @@ responseHeadersSpec :: Spec
|
|||
responseHeadersSpec = describe "ResponseHeaders" $ do
|
||||
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) EmptyConfig responseHeadersServer) $ do
|
||||
|
||||
let methods = [(methodGet, 200), (methodPost, 200), (methodPut, 200), (methodPatch, 200)]
|
||||
let methods = [methodGet, methodPost, methodPut, methodPatch]
|
||||
|
||||
it "includes the headers in the response" $
|
||||
forM_ methods $ \(method, expected) ->
|
||||
forM_ methods $ \method ->
|
||||
Test.Hspec.Wai.request method "/" [] ""
|
||||
`shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]
|
||||
, matchStatus = expected
|
||||
, matchStatus = 200
|
||||
}
|
||||
|
||||
it "responds with not found for non-existent endpoints" $
|
||||
forM_ methods $ \(method,_) ->
|
||||
forM_ methods $ \method ->
|
||||
Test.Hspec.Wai.request method "blahblah" [] ""
|
||||
`shouldRespondWith` 404
|
||||
|
||||
it "returns 406 if the Accept header is not supported" $
|
||||
forM_ methods $ \(method,_) ->
|
||||
forM_ methods $ \method ->
|
||||
Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
|
||||
`shouldRespondWith` 406
|
||||
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * routerSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
routerSpec :: Spec
|
||||
routerSpec = do
|
||||
describe "Servant.Server.Internal.Router" $ do
|
||||
|
|
@ -547,6 +482,10 @@ routerSpec = do
|
|||
it "calls f on route result" $ do
|
||||
get "" `shouldRespondWith` 202
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * miscCombinatorSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
type MiscCombinatorsAPI
|
||||
= "version" :> HttpVersion :> Get '[JSON] String
|
||||
:<|> "secure" :> IsSecure :> Get '[JSON] String
|
||||
|
|
@ -565,8 +504,8 @@ miscServ = versionHandler
|
|||
secureHandler NotSecure = return "not secure"
|
||||
hostHandler = return . show
|
||||
|
||||
miscReqCombinatorsSpec :: Spec
|
||||
miscReqCombinatorsSpec = with (return $ serve miscApi EmptyConfig miscServ) $
|
||||
miscCombinatorSpec :: Spec
|
||||
miscCombinatorSpec = with (return $ serve miscApi EmptyConfig miscServ) $
|
||||
describe "Misc. combinators for request inspection" $ do
|
||||
it "Successfully gets the HTTP version specified in the request" $
|
||||
go "/version" "\"HTTP/1.0\""
|
||||
|
|
@ -578,3 +517,35 @@ miscReqCombinatorsSpec = with (return $ serve miscApi EmptyConfig miscServ) $
|
|||
go "/host" "\"0.0.0.0:0\""
|
||||
|
||||
where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Test data types {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
data Person = Person {
|
||||
name :: String,
|
||||
age :: Integer
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON Person
|
||||
instance FromJSON Person
|
||||
|
||||
alice :: Person
|
||||
alice = Person "Alice" 42
|
||||
|
||||
data Animal = Animal {
|
||||
species :: String,
|
||||
numberOfLegs :: Integer
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON Animal
|
||||
instance FromJSON Animal
|
||||
|
||||
jerry :: Animal
|
||||
jerry = Animal "Mouse" 4
|
||||
|
||||
tweety :: Animal
|
||||
tweety = Animal "Bird" 2
|
||||
-- }}}
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader),
|
|||
getHeadersHList, getResponse)
|
||||
import Servant.API.Sub ((:>))
|
||||
import Servant.API.Vault (Vault)
|
||||
import Servant.API.Verbs (Created, Delete, DeleteAccepted,
|
||||
import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted,
|
||||
DeleteNoContent,
|
||||
DeleteNonAuthoritative, Get,
|
||||
GetAccepted, GetNoContent,
|
||||
|
|
@ -87,7 +87,7 @@ import Servant.API.Verbs (Created, Delete, DeleteAccepted,
|
|||
PutAccepted, PutNoContent,
|
||||
PutNoContent, PutNonAuthoritative,
|
||||
ReflectMethod (reflectMethod),
|
||||
Verb)
|
||||
Verb, StdMethod(..))
|
||||
import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
|
||||
URI (..), safeLink)
|
||||
import Web.HttpApiData (FromHttpApiData (..),
|
||||
|
|
|
|||
|
|
@ -238,11 +238,12 @@ class (AllMime list) => AllMimeRender (list :: [*]) a where
|
|||
-> a -- value to serialize
|
||||
-> [(M.MediaType, ByteString)] -- content-types/response pairs
|
||||
|
||||
instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
|
||||
instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
|
||||
allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)]
|
||||
where pctyp = Proxy :: Proxy ctyp
|
||||
|
||||
instance ( MimeRender ctyp a
|
||||
instance OVERLAPPABLE_
|
||||
( MimeRender ctyp a
|
||||
, AllMimeRender (ctyp' ': ctyps) a
|
||||
) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
|
||||
allMimeRender _ a = (contentType pctyp, mimeRender pctyp a)
|
||||
|
|
@ -250,6 +251,19 @@ instance ( MimeRender ctyp a
|
|||
where pctyp = Proxy :: Proxy ctyp
|
||||
pctyps = Proxy :: Proxy (ctyp' ': ctyps)
|
||||
|
||||
|
||||
-- Ideally we would like to declare a 'MimeRender a NoContent' instance, and
|
||||
-- then this would be taken care of. However there is no more specific instance
|
||||
-- between that and 'MimeRender JSON a', so we do this instead
|
||||
instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
|
||||
allMimeRender _ _ = [(contentType pctyp, "")]
|
||||
where pctyp = Proxy :: Proxy ctyp
|
||||
|
||||
instance OVERLAPPING_
|
||||
( AllMime (ctyp ': ctyp' ': ctyps)
|
||||
) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where
|
||||
allMimeRender p _ = zip (allMime p) (repeat "")
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- Check that all elements of list are instances of MimeUnrender
|
||||
--------------------------------------------------------------------------
|
||||
|
|
@ -304,28 +318,10 @@ instance MimeRender OctetStream ByteString where
|
|||
instance MimeRender OctetStream BS.ByteString where
|
||||
mimeRender _ = fromStrict
|
||||
|
||||
-- | A type for responses with content-body.
|
||||
-- | A type for responses without content-body.
|
||||
data NoContent = NoContent
|
||||
deriving (Show, Eq, Read)
|
||||
|
||||
instance FromJSON NoContent where
|
||||
parseJSON _ = return NoContent
|
||||
|
||||
instance ToJSON NoContent where
|
||||
toJSON _ = ""
|
||||
|
||||
|
||||
instance OVERLAPPING_
|
||||
MimeRender JSON NoContent where
|
||||
mimeRender _ _ = ""
|
||||
|
||||
instance OVERLAPPING_
|
||||
MimeRender PlainText NoContent where
|
||||
mimeRender _ _ = ""
|
||||
|
||||
instance OVERLAPPING_
|
||||
MimeRender OctetStream NoContent where
|
||||
mimeRender _ _ = ""
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- * MimeUnrender Instances
|
||||
|
|
|
|||
|
|
@ -3,17 +3,20 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
module Servant.API.Verbs where
|
||||
module Servant.API.Verbs
|
||||
( module Servant.API.Verbs
|
||||
, StdMethod(GET, POST, HEAD, PUT, DELETE, TRACE, CONNECT, OPTIONS, PATCH)
|
||||
) where
|
||||
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Proxy (Proxy)
|
||||
import GHC.Generics (Generic)
|
||||
import GHC.TypeLits (Nat)
|
||||
import Network.HTTP.Types.Method (Method, StdMethod (..),
|
||||
methodDelete, methodGet, methodHead,
|
||||
methodPatch, methodPost, methodPut)
|
||||
import Servant.API.ContentTypes (NoContent(..))
|
||||
|
||||
-- | @Verb@ is a general type for representing HTTP verbs/methods. For
|
||||
-- | @Verb@ is a general type for representing HTTP verbs (a.k.a. methods). For
|
||||
-- convenience, type synonyms for each verb with a 200 response code are
|
||||
-- provided, but you are free to define your own:
|
||||
--
|
||||
|
|
@ -55,7 +58,7 @@ type Patch contentTypes a = Verb 'PATCH 200 contentTypes a
|
|||
|
||||
-- | 'POST' with 201 status code.
|
||||
--
|
||||
type Created contentTypes a = Verb 'POST 201 contentTypes a
|
||||
type PostCreated contentTypes a = Verb 'POST 201 contentTypes a
|
||||
|
||||
|
||||
-- ** 202 Accepted
|
||||
|
|
@ -141,11 +144,11 @@ type PutResetContent contentTypes noContent = Verb 'PUT 205 contentTypes noConte
|
|||
-- RFC7233 Section 4.1>
|
||||
|
||||
-- | 'GET' with 206 status code.
|
||||
type GetPartialContent contentTypes noContent = Verb 'GET 205 contentTypes noContent
|
||||
type GetPartialContent contentTypes noContent = Verb 'GET 206 contentTypes noContent
|
||||
|
||||
|
||||
class ReflectMethod a where
|
||||
reflectMethod :: proxy a -> Method
|
||||
reflectMethod :: Proxy a -> Method
|
||||
|
||||
instance ReflectMethod 'GET where
|
||||
reflectMethod _ = methodGet
|
||||
|
|
|
|||
|
|
@ -74,9 +74,7 @@
|
|||
-- >>> safeLink api bad_link
|
||||
-- ...
|
||||
-- Could not deduce (Or
|
||||
-- (IsElem'
|
||||
-- (Verb 'Network.HTTP.Types.Method.DELETE 200 '[JSON] ())
|
||||
-- (Verb 'Network.HTTP.Types.Method.GET 200 '[JSON] Int))
|
||||
-- (IsElem' (Verb 'DELETE 200 '[JSON] ()) (Verb 'GET 200 '[JSON] Int))
|
||||
-- (IsElem'
|
||||
-- ("hello" :> Delete '[JSON] ())
|
||||
-- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ()))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue