Review fixes
This commit is contained in:
Julian K. Arni
parent
783a849c67
commit
f1b6603c52
7 changed files with 237 additions and 259 deletions
|
|
@ -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 ()
|
||||
|
|
@ -23,82 +25,144 @@ import Data.String (fromString)
|
|||
import Data.String.Conversions (cs)
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Types (hAccept, hContentType,
|
||||
methodDelete, methodGet, methodHead,
|
||||
methodPatch, methodPost, methodPut,
|
||||
ok200, parseQuery, Status(..))
|
||||
import Network.HTTP.Types (Status (..), hAccept, hContentType,
|
||||
methodDelete, methodGet,
|
||||
methodHead, methodPatch,
|
||||
methodPost, methodPut, ok200,
|
||||
parseQuery)
|
||||
import Network.Wai (Application, Request, pathInfo,
|
||||
queryString, rawQueryString,
|
||||
responseLBS, responseBuilder)
|
||||
import Network.Wai.Internal (Response(ResponseBuilder))
|
||||
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)
|
||||
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.Internal.RoutingApplication (toApplication, RouteResult(..))
|
||||
|
||||
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 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
|
||||
|
|
@ -128,68 +192,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 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 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
|
||||
|
|
@ -274,122 +280,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 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 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 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 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)
|
||||
|
|
@ -418,12 +343,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
|
||||
|
|
@ -444,7 +376,10 @@ rawSpec = do
|
|||
liftIO $ do
|
||||
simpleBody response `shouldBe` cs (show ["bar" :: String])
|
||||
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * alternativeSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
type AlternativeApi =
|
||||
"foo" :> Get '[JSON] Person
|
||||
:<|> "bar" :> Get '[JSON] Animal
|
||||
|
|
@ -452,11 +387,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"
|
||||
|
|
@ -464,10 +400,10 @@ unionServer =
|
|||
:<|> return jerry
|
||||
:<|> return ()
|
||||
|
||||
unionSpec :: Spec
|
||||
unionSpec = do
|
||||
alternativeSpec :: Spec
|
||||
alternativeSpec = do
|
||||
describe "Servant.API.Alternative" $ do
|
||||
with (return $ serve unionApi unionServer) $ do
|
||||
with (return $ serve alternativeApi alternativeServer) $ do
|
||||
|
||||
it "unions endpoints" $ do
|
||||
response <- get "/foo"
|
||||
|
|
@ -484,7 +420,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)
|
||||
|
|
@ -501,26 +440,29 @@ responseHeadersSpec :: Spec
|
|||
responseHeadersSpec = describe "ResponseHeaders" $ do
|
||||
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) 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
|
||||
|
|
@ -539,6 +481,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
|
||||
|
|
@ -557,8 +503,8 @@ miscServ = versionHandler
|
|||
secureHandler NotSecure = return "not secure"
|
||||
hostHandler = return . show
|
||||
|
||||
miscReqCombinatorsSpec :: Spec
|
||||
miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $
|
||||
miscCombinatorSpec :: Spec
|
||||
miscCombinatorSpec = with (return $ serve miscApi miscServ) $
|
||||
describe "Misc. combinators for request inspection" $ do
|
||||
it "Successfully gets the HTTP version specified in the request" $
|
||||
go "/version" "\"HTTP/1.0\""
|
||||
|
|
@ -570,3 +516,35 @@ miscReqCombinatorsSpec = with (return $ serve miscApi 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 (..),
|
||||
|
|
|
|||
|
|
@ -304,7 +304,7 @@ 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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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…
Add table
Reference in a new issue