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

Merge branch 'master' into canonical-types

Browse source 
Conflicts:
	CHANGELOG.md
	src/Servant/Server/Internal.hs
This commit is contained in:
Alp Mestanogullari 2015-04-19 11:17:11 +02:00
commit f71c7a813a
4 changed files with 407 additions and 99 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
CHANGELOG.md
View file

@ -6,6 +6,8 @@
* Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29)
* Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21)
* Canonicalize API types before generating the handler types with `Server`
* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)
* Add server support for response headers
0.2.4
-----

1
servant-server.cabal
View file

@ -80,6 +80,7 @@ test-suite spec
base == 4.*
, aeson
, bytestring
, bytestring-conversion
, directory
, either
, exceptions

225
src/Servant/Server/Internal.hs
View file

@ -1,46 +1,53 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.Server.Internal where
import Control.Applicative ((<$>))
import Control.Monad.Trans.Either (EitherT, runEitherT)
import Data.Aeson (ToJSON)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.List (unfoldr)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid (Monoid, mempty, mappend)
import Data.Monoid (Monoid, mappend, mempty)
import Data.String (fromString)
import Data.String.Conversions (cs, (<>))
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Typeable
import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.HTTP.Types hiding (Header)
import Network.Wai ( Response, Request, ResponseReceived, Application
, pathInfo, requestBody, strictRequestBody
, lazyRequestBody, requestHeaders, requestMethod,
rawQueryString, responseLBS)
import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header
, MatrixParams, MatrixParam, MatrixFlag
, Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..)
, Canonicalize)
import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..)
, AllCTUnrender(..),)
import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Wai (Application, Request, Response,
ResponseReceived, lazyRequestBody,
pathInfo, rawQueryString,
requestBody, requestHeaders,
requestMethod, responseLBS,
strictRequestBody)
import Servant.API ((:<|>) (..), (:>), Capture,
Canonicalize, Delete, Get, Header,
MatrixFlag, MatrixParam, MatrixParams,
Patch, Post, Put, QueryFlag,
QueryParam, QueryParams, Raw,
ReqBody)
import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..),
AllCTUnrender (..))
import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)
import Servant.Common.Text (FromText, fromText)
data ReqBodyState = Uncalled
| Called !B.ByteString
| Done !B.ByteString
toApplication :: RoutingApplication -> Application
toApplication ra request respond = do
reqBodyRef <- newIORef Uncalled
@ -281,19 +288,53 @@ 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
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
| otherwise = respond $ failWith NotFound
-- '()' ==> 204 No Content
instance HasServer (Get ctypes ()) where
type ServerT (Get ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- Add response headers
instance ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where
type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | If you use 'Header' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of the type specified by 'Header'.
@ -347,19 +388,52 @@ 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
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
| otherwise = respond $ failWith NotFound
instance HasServer (Post ctypes ()) where
type ServerT (Post ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- Add response headers
instance ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where
type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | When implementing the handler for a 'Put' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
-- and 'Servant.API.Post.Post', the handler code runs in the
@ -370,7 +444,7 @@ instance ( AllCTRender ctypes a
--
-- If successfully returning a value, we use the type-level list, combined
-- with the request's @Accept@ header, to encode the value for you
-- (returning a status code of 201). If there was no @Accept@ header or it
-- (returning a status code of 200). If there was no @Accept@ header or it
-- was @*/*@, we return encode using the first @Content-Type@ type on the
-- list.
instance ( AllCTRender ctypes a
@ -381,18 +455,50 @@ 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
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
| otherwise = respond $ failWith NotFound
instance HasServer (Put ctypes ()) where
type ServerT (Put ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- Add response headers
instance ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where
type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | When implementing the handler for a 'Patch' endpoint,
@ -405,28 +511,57 @@ instance ( AllCTRender ctypes a
--
-- If successfully returning a value, we just require that its type has
-- a 'ToJSON' instance and servant takes care of encoding it for you,
-- yielding status code 201 along the way.
-- yielding status code 200 along the way.
instance ( AllCTRender ctypes a
, Typeable a
, ToJSON a) => HasServer (Patch ctypes a) where
) => HasServer (Patch ctypes a) where
type ServerT' (Patch ctypes a) m = m a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
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
| otherwise = respond $ failWith NotFound
instance HasServer (Patch ctypes ()) where
type ServerT (Patch ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond . succeedWith $ case e of
Right out -> case cast out of
Nothing -> do
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) out of
Nothing -> responseLBS (mkStatus 406 "") [] ""
Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
, cs contentT)] body
Just () -> responseLBS status204 [] ""
Right () -> responseLBS noContent204 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPost =
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- Add response headers
instance ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where
type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond $ case e of
Right outpatch -> do
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
headers = getHeaders outpatch
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound

210
test/Servant/ServerSpec.hs
View file

@ -1,34 +1,46 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Servant.ServerSpec where
import Control.Monad (when)
import Control.Monad (forM_, when)
import Control.Monad.Trans.Either (EitherT, left)
import Data.Aeson (ToJSON, FromJSON, encode, decode')
import Data.Aeson (FromJSON, ToJSON, decode', encode)
import Data.ByteString.Conversion ()
import Data.Char (toUpper)
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 ( parseQuery, ok200, status409, methodPost
, methodDelete, hContentType)
import Network.Wai ( Application, Request, responseLBS, pathInfo
, queryString, rawQueryString )
import Network.Wai.Test (runSession, defaultRequest, simpleBody, request)
import Network.HTTP.Types (hAccept, hContentType,
methodDelete, methodGet,
methodPatch, methodPost, methodPut,
ok200, parseQuery, status409)
import Network.Wai (Application, Request, pathInfo,
queryString, rawQueryString,
responseLBS)
import Network.Wai.Test (defaultRequest, request,
runSession, simpleBody)
import Test.Hspec (Spec, describe, it, shouldBe)
import Test.Hspec.Wai ( liftIO, with, get, post, shouldRespondWith
, matchStatus, request )
import Test.Hspec.Wai (get, liftIO, matchHeaders,
matchStatus, post, request,
shouldRespondWith, with, (<:>))
import Servant.API (JSON, Capture, Get, ReqBody, Post, QueryParam
, QueryParams, QueryFlag, MatrixParam, MatrixParams
, MatrixFlag, Raw, (:>), (:<|>)(..), Header, Delete )
import Servant.API ((:<|>) (..), (:>),
AddHeader (addHeader), Capture,
Delete, Get, Header (..), Headers,
JSON, MatrixFlag, MatrixParam,
MatrixParams, Patch, PlainText,
Post, Put, QueryFlag, QueryParam,
QueryParams, Raw, ReqBody)
import Servant.Server (Server, serve)
import Servant.Server.Internal (RouteMismatch (..))
@ -69,13 +81,16 @@ spec :: Spec
spec = do
captureSpec
getSpec
postSpec
putSpec
patchSpec
queryParamSpec
matrixParamSpec
postSpec
headerSpec
rawSpec
unionSpec
errorsSpec
responseHeadersSpec
type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
@ -91,10 +106,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))
@ -105,21 +123,32 @@ captureSpec = do
type GetApi = Get '[JSON] Person
:<|> "empty" :> Get '[] ()
getApi :: Proxy GetApi
getApi = Proxy
getSpec :: Spec
getSpec = do
describe "Servant.API.Get" $ do
with (return (serve getApi (return alice))) $ 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
@ -291,13 +320,16 @@ matrixParamSpec = do
type PostApi =
ReqBody '[JSON] Person :> Post '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
:<|> "empty" :> Post '[] ()
postApi :: Proxy PostApi
postApi = Proxy
postSpec :: Spec
postSpec = do
describe "Servant.API.Post and .ReqBody" $ do
with (return (serve postApi (return . age :<|> return . age))) $ 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")]
@ -319,11 +351,98 @@ postSpec = do
it "correctly rejects invalid request bodies with status 400" $ do
post' "/" "some invalid body" `shouldRespondWith` 400
it "returns 204 if the type is '()'" $ do
post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
it "responds with 415 if the requested media type is unsupported" $ do
let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
, "application/nonsense")]
post'' "/" "anything at all" `shouldRespondWith` 415
type PutApi =
ReqBody '[JSON] Person :> Put '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
:<|> "empty" :> Put '[] ()
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 "returns 204 if the type is '()'" $ do
put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
it "responds with 415 if the requested 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 '[] ()
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 "returns 204 if the type is '()'" $ do
patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
it "responds with 415 if the requested media type is unsupported" $ do
let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
, "application/nonsense")]
patch'' "/" "anything at all" `shouldRespondWith` 415
type HeaderApi a = Header "MyHeader" a :> Delete
headerApi :: Proxy (HeaderApi a)
headerApi = Proxy
@ -381,6 +500,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
@ -388,11 +511,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
@ -403,6 +531,48 @@ 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
type ResponseHeadersApi =
Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
:<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
:<|> Put '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
:<|> Patch '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
responseHeadersServer :: Server ResponseHeadersApi
responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"
in h :<|> h :<|> h :<|> h
responseHeadersSpec :: Spec
responseHeadersSpec = describe "ResponseHeaders" $ do
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do
let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)]
it "includes the headers in the response" $
forM_ methods $ \(method, expected) ->
Test.Hspec.Wai.request method "/" [] ""
`shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]
, matchStatus = expected
}
it "responds with not found for non-existent endpoints" $
forM_ methods $ \(method,_) ->
Test.Hspec.Wai.request method "blahblah" [] ""
`shouldRespondWith` 404
it "returns 415 if the Accept header is not supported" $
forM_ methods $ \(method,_) ->
Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 415
-- | Test server error functionality.
errorsSpec :: Spec
errorsSpec = do