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

Merge pull request #13 from haskell-servant/jkarni/content-types

Browse Source 
Jkarni/content types
This commit is contained in:
Julian Arni 2015-02-24 15:01:46 +01:00
commit cae0b6e252
9 changed files with 212 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
CHANGELOG.md
View File

@ -2,6 +2,11 @@ master
------
* Added support for matrix parameters, see e.g. http://www.w3.org/DesignIssues/MatrixURIs.html
* Add support for serializing based on Accept header
(https://github.com/haskell-servant/servant-server/issues/9)
* Ignore trailing slashes
(https://github.com/haskell-servant/servant-server/issues/5)
0.2.3
-----

15
default.nix Normal file
View File

@ -0,0 +1,15 @@
{ pkgs ? import <nixpkgs> { config.allowUnfree = true; }
, src ? builtins.filterSource (path: type:
type != "unknown" &&
baseNameOf path != ".git" &&
baseNameOf path != "result" &&
baseNameOf path != "dist") ./.
, servant ? import ../servant {}
}:
pkgs.haskellPackages.buildLocalCabalWithArgs {
name = "servant-server";
inherit src;
args = {
inherit servant;
};
}

6
example/greet.hs
View File

@ -18,7 +18,7 @@ import Servant
-- * Example
-- | A greet message data type
newtype Greet = Greet { msg :: Text }
newtype Greet = Greet { _msg :: Text }
deriving (Generic, Show)
instance FromJSON Greet
@ -27,11 +27,11 @@ instance ToJSON Greet
-- API specification
type TestApi =
-- GET /hello/:name?capital={true, false} returns a Greet as JSON
"hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
"hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet
-- POST /greet with a Greet as JSON in the request body,
-- returns a Greet as JSON
:<|> "greet" :> ReqBody Greet :> Post Greet
:<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
-- DELETE /greet/:greetid
:<|> "greet" :> Capture "greetid" Text :> Delete

34
servant-server.cabal
View File

@ -34,23 +34,23 @@ library
Servant.Server.Internal
Servant.Utils.StaticFiles
build-depends:
base >=4.7 && <5
, aeson
, attoparsec
, bytestring
, either >= 4.3
, http-types
, network-uri >= 2.6
, safe
, servant >= 0.2.2
, split
, string-conversions
, system-filepath
, text
, transformers
, wai
, wai-app-static >= 3.0.0.6
, warp
base >= 4.7 && < 5
, aeson >= 0.7 && < 0.9
, attoparsec >= 0.12 && < 0.13
, bytestring >= 0.10 && < 0.11
, either >= 4.3 && < 4.4
, http-types >= 0.8 && < 0.9
, network-uri >= 2.6 && < 2.7
, safe >= 0.3 && < 0.4
, servant >= 0.2 && < 0.4
, split >= 0.2 && < 0.3
, string-conversions >= 0.3 && < 0.4
, system-filepath >= 0.4 && < 0.5
, text >= 1.2 && < 1.3
, transformers >= 0.3 && < 0.5
, wai >= 3.0 && < 3.1
, wai-app-static >= 3.0 && < 3.1
, warp >= 3.0 && < 3.1
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall

2
src/Servant.hs
View File

@ -8,7 +8,6 @@ module Servant (
-- | Using your types in request paths and query string parameters
module Servant.Common.Text,
-- | Utilities on top of the servant core
module Servant.QQ,
module Servant.Utils.Links,
module Servant.Utils.StaticFiles,
-- | Useful re-exports
@ -19,6 +18,5 @@ import Data.Proxy
import Servant.API
import Servant.Common.Text
import Servant.Server
import Servant.QQ
import Servant.Utils.Links
import Servant.Utils.StaticFiles

5
src/Servant/Server.hs
View File

@ -9,6 +9,7 @@ module Servant.Server
, -- * Handlers for all standard combinators
HasServer(..)
) where
import Data.Proxy (Proxy)
@ -23,8 +24,8 @@ import Servant.Server.Internal
--
-- Example:
--
-- > type MyApi = "books" :> Get [Book] -- GET /books
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
-- >
-- > server :: Server MyApi
-- > server = listAllBooks :<|> postBook

162
src/Servant/Server/Internal.hs
View File

@ -9,7 +9,7 @@ module Servant.Server.Internal where
import Control.Applicative ((<$>))
import Control.Monad.Trans.Either (EitherT, runEitherT)
import Data.Aeson (ToJSON, FromJSON, encode, eitherDecode')
import Data.Aeson (ToJSON)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.IORef (newIORef, readIORef, writeIORef)
@ -24,12 +24,18 @@ import qualified Data.Text as T
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,
import Network.Wai ( Response, Request, ResponseReceived, Application
, pathInfo, requestBody, strictRequestBody
, lazyRequestBody, requestHeaders, requestMethod,
rawQueryString, responseLBS)
import Servant.API (QueryParams, QueryParam, QueryFlag, MatrixParams, MatrixParam, MatrixFlag, ReqBody, Header, Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..))
import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header
, MatrixParams, MatrixParam, MatrixFlag
, Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..))
import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..)
, AllCTUnrender(..),)
import Servant.Common.Text (FromText, fromText)
data ReqBodyState = Uncalled
| Called !B.ByteString
| Done !B.ByteString
@ -66,39 +72,33 @@ toApplication ra request respond = do
respond $ responseLBS methodNotAllowed405 [] "method not allowed"
routingRespond (Left (InvalidBody err)) =
respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err
routingRespond (Left UnsupportedMediaType) =
respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
routingRespond (Left (HttpError status body)) =
respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
routingRespond (Right response) =
respond response
-- Note that the ordering of the constructors has great significance! It
-- determines the Ord instance and, consequently, the monoid instance.
-- * Route mismatch
data RouteMismatch =
NotFound -- ^ the usual "not found" error
| WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
| UnsupportedMediaType -- ^ request body has unsupported media type
| InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
| HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
deriving (Eq, Show)
deriving (Eq, Ord, Show)
-- |
-- @
-- > mempty = NotFound
-- >
-- > _ `mappend` HttpError s b = HttpError s b
-- > HttpError s b `mappend` _ = HttpError s b
-- > NotFound `mappend` x = x
-- > WrongMethod `mappend` InvalidBody s = InvalidBody s
-- > WrongMethod `mappend` _ = WrongMethod
-- > InvalidBody s `mappend` _ = InvalidBody s
-- @
instance Monoid RouteMismatch where
mempty = NotFound
-- The following isn't great, since it picks @InvalidBody@ based on
-- alphabetical ordering, but any choice would be arbitrary.
--
-- "As one judge said to the other, 'Be just and if you can't be just, be
-- arbitrary'" -- William Burroughs
mappend = max
_ `mappend` HttpError s b = HttpError s b
HttpError s b `mappend` _ = HttpError s b
NotFound `mappend` x = x
WrongMethod `mappend` InvalidBody s = InvalidBody s
WrongMethod `mappend` _ = WrongMethod
InvalidBody s `mappend` _ = InvalidBody s
-- | A wrapper around @'Either' 'RouteMismatch' a@.
newtype RouteResult a =
@ -171,8 +171,8 @@ class HasServer layout where
-- represented by @a@ and if it fails tries @b@. You must provide a request
-- handler for each route.
--
-- > type MyApi = "books" :> Get [Book] -- GET /books
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
-- >
-- > server :: Server MyApi
-- > server = listAllBooks :<|> postBook
@ -203,7 +203,7 @@ captured _ = fromText
--
-- Example:
--
-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book
-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
-- >
-- > server :: Server MyApi
-- > server = getBook
@ -225,7 +225,7 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
_ -> respond $ failWith NotFound
where captureProxy = Proxy :: Proxy (Capture capture a)
-- | If you have a 'Delete' endpoint in your API,
-- the handler for this endpoint is meant to delete
@ -261,17 +261,24 @@ instance HasServer Delete where
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met.
--
-- 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 200 along the way.
instance ToJSON result => HasServer (Get result) where
type Server (Get result) = EitherT (Int, String) IO result
-- 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 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
) => HasServer (Get ctypes a) where
type Server (Get ctypes a) = EitherT (Int, String) IO a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond . succeedWith $ case e of
Right output ->
responseLBS ok200 [("Content-Type", "application/json")] (encode output)
Right output -> do
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> responseLBS (mkStatus 406 "Not Acceptable") [] ""
Just (contentT, body) -> responseLBS ok200 [ ("Content-Type"
, cs contentT)] body
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodGet =
@ -292,7 +299,7 @@ instance ToJSON result => HasServer (Get result) where
-- > deriving (Eq, Show, FromText, ToText)
-- >
-- > -- GET /view-my-referer
-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get Referer
-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
-- >
-- > server :: Server MyApi
-- > server = viewReferer
@ -318,18 +325,25 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met.
--
-- 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.
instance ToJSON a => HasServer (Post a) where
type Server (Post a) = EitherT (Int, String) IO 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
-- was @*/*@, we return encode using the first @Content-Type@ type on the
-- list.
instance ( AllCTRender ctypes a
) => HasServer (Post ctypes a) where
type Server (Post ctypes a) = EitherT (Int, String) IO a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond . succeedWith $ case e of
Right out ->
responseLBS status201 [("Content-Type", "application/json")] (encode out)
Right output -> do
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> responseLBS (mkStatus 406 "") [] ""
Just (contentT, body) -> responseLBS status201 [ ("Content-Type"
, cs contentT)] body
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPost =
@ -344,18 +358,25 @@ instance ToJSON a => HasServer (Post a) where
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met.
--
-- 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 200 along the way.
instance ToJSON a => HasServer (Put a) where
type Server (Put a) = EitherT (Int, String) IO 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
-- was @*/*@, we return encode using the first @Content-Type@ type on the
-- list.
instance ( AllCTRender ctypes a
) => HasServer (Put ctypes a) where
type Server (Put ctypes a) = EitherT (Int, String) IO a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond . succeedWith $ case e of
Right out ->
responseLBS ok200 [("Content-Type", "application/json")] (encode out)
Right output -> do
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> responseLBS (mkStatus 406 "") [] ""
Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
, cs contentT)] body
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPut =
@ -374,15 +395,22 @@ instance ToJSON a => HasServer (Put a) where
-- 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.
instance (Typeable a, ToJSON a) => HasServer (Patch a) where
type Server (Patch a) = EitherT (Int, String) IO a
instance ( AllCTRender ctypes a
, Typeable a
, ToJSON a) => HasServer (Patch ctypes a) where
type Server (Patch ctypes a) = EitherT (Int, String) IO a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond . succeedWith $ case e of
Right out -> case cast out of
Nothing -> responseLBS status200 [("Content-Type", "application/json")] (encode out)
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 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
@ -404,7 +432,7 @@ instance (Typeable a, ToJSON a) => HasServer (Patch a) where
--
-- Example:
--
-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book]
-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooksBy
@ -443,7 +471,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
--
-- Example:
--
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book]
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooksBy
@ -476,7 +504,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
--
-- Example:
--
-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book]
-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
-- >
-- > server :: Server MyApi
-- > server = getBooks
@ -635,30 +663,42 @@ instance HasServer Raw where
-- | If you use 'ReqBody' 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 'ReqBody'.
-- The @Content-Type@ header is inspected, and the list provided is used to
-- attempt deserialization. If the request does not have a @Content-Type@
-- header, it is treated as @application/octet-stream@.
-- This lets servant worry about extracting it from the request and turning
-- it into a value of the type you specify.
--
--
-- All it asks is for a 'FromJSON' instance.
--
-- Example:
--
-- > type MyApi = "books" :> ReqBody Book :> Post Book
-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
-- >
-- > server :: Server MyApi
-- > server = postBook
-- > where postBook :: Book -> EitherT (Int, String) IO Book
-- > postBook book = ...insert into your db...
instance (FromJSON a, HasServer sublayout)
=> HasServer (ReqBody a :> sublayout) where
instance ( AllCTUnrender list a, HasServer sublayout
) => HasServer (ReqBody list a :> sublayout) where
type Server (ReqBody a :> sublayout) =
type Server (ReqBody list a :> sublayout) =
a -> Server sublayout
route Proxy subserver request respond = do
mrqbody <- eitherDecode' <$> lazyRequestBody request
-- See HTTP RFC 2616, section 7.2.1
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
-- See also "W3C Internet Media Type registration, consistency of use"
-- http://www.w3.org/2001/tag/2002/0129-mime
let contentTypeH = fromMaybe "application/octet-stream"
$ lookup hContentType $ requestHeaders request
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
<$> lazyRequestBody request
case mrqbody of
Left e -> respond . failWith $ InvalidBody e
Right v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
Nothing -> respond . failWith $ UnsupportedMediaType
Just (Left e) -> respond . failWith $ InvalidBody e
Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond
-- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @sublayout@.

97
test/Servant/ServerSpec.hs
View File

@ -8,6 +8,7 @@
module Servant.ServerSpec where
import Control.Monad (when)
import Control.Monad.Trans.Either (EitherT, left)
import Data.Aeson (ToJSON, FromJSON, encode, decode')
import Data.Char (toUpper)
@ -16,21 +17,18 @@ import Data.Proxy (Proxy(Proxy))
import Data.String (fromString)
import Data.String.Conversions (cs)
import GHC.Generics (Generic)
import Network.HTTP.Types (parseQuery, ok200, status409)
import Network.Wai (Application, Request, responseLBS, pathInfo, queryString, rawQueryString)
import Network.Wai.Test (runSession, request, defaultRequest, simpleBody)
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 Test.Hspec (Spec, describe, it, shouldBe)
import Test.Hspec.Wai (liftIO, with, get, post, shouldRespondWith, matchStatus)
import Test.Hspec.Wai ( liftIO, with, get, post, shouldRespondWith
, matchStatus, request )
import Servant.API.Capture (Capture)
import Servant.API.Get (Get)
import Servant.API.ReqBody (ReqBody)
import Servant.API.Post (Post)
import Servant.API.QueryParam (QueryParam, QueryParams, QueryFlag)
import Servant.API.MatrixParam (MatrixParam, MatrixParams, MatrixFlag)
import Servant.API.Raw (Raw)
import Servant.API.Sub ((:>))
import Servant.API.Alternative ((:<|>)((:<|>)))
import Servant.API (JSON, Capture, Get, ReqBody, Post, QueryParam
, QueryParams, QueryFlag, MatrixParam, MatrixParams
, MatrixFlag, Raw, (:>), (:<|>)(..), Header, Delete )
import Servant.Server (Server, serve)
import Servant.Server.Internal (RouteMismatch(..))
@ -74,12 +72,13 @@ spec = do
queryParamSpec
matrixParamSpec
postSpec
headerSpec
rawSpec
unionSpec
errorsSpec
type CaptureApi = Capture "legs" Integer :> Get Animal
type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
captureApi :: Proxy CaptureApi
captureApi = Proxy
captureServer :: Integer -> EitherT (Int, String) IO Animal
@ -105,7 +104,7 @@ captureSpec = do
get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
type GetApi = Get Person
type GetApi = Get '[JSON] Person
getApi :: Proxy GetApi
getApi = Proxy
@ -123,9 +122,9 @@ getSpec = do
post "/" "" `shouldRespondWith` 405
type QueryParamApi = QueryParam "name" String :> Get Person
:<|> "a" :> QueryParams "names" String :> Get Person
:<|> "b" :> QueryFlag "capitalize" :> Get Person
type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
:<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
:<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person
queryParamApi :: Proxy QueryParamApi
queryParamApi = Proxy
@ -170,6 +169,7 @@ queryParamSpec = do
name = "john"
}
it "allows to retrieve value-less GET parameters" $
(flip runSession) (serve queryParamApi qpServer) $ do
let params3 = "?capitalize"
@ -205,10 +205,10 @@ queryParamSpec = do
name = "Alice"
}
type MatrixParamApi = "a" :> MatrixParam "name" String :> Get Person
:<|> "b" :> MatrixParams "names" String :> "bsub" :> MatrixParams "names" String :> Get Person
:<|> "c" :> MatrixFlag "capitalize" :> Get Person
:<|> "d" :> Capture "foo" Integer :> MatrixParam "name" String :> MatrixFlag "capitalize" :> "dsub" :> Get Person
type MatrixParamApi = "a" :> MatrixParam "name" String :> Get '[JSON] Person
:<|> "b" :> MatrixParams "names" String :> "bsub" :> MatrixParams "names" String :> Get '[JSON] Person
:<|> "c" :> MatrixFlag "capitalize" :> Get '[JSON] Person
:<|> "d" :> Capture "foo" Integer :> MatrixParam "name" String :> MatrixFlag "capitalize" :> "dsub" :> Get '[JSON] Person
matrixParamApi :: Proxy MatrixParamApi
matrixParamApi = Proxy
@ -289,8 +289,8 @@ matrixParamSpec = do
}
type PostApi =
ReqBody Person :> Post Integer
:<|> "bla" :> ReqBody Person :> Post Integer
ReqBody '[JSON] Person :> Post '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
postApi :: Proxy PostApi
postApi = Proxy
@ -298,23 +298,58 @@ postSpec :: Spec
postSpec = do
describe "Servant.API.Post and .ReqBody" $ do
with (return (serve postApi (return . age :<|> return . age))) $ do
let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
, "application/json;charset=utf-8")]
it "allows to POST a Person" $ do
post "/" (encode alice) `shouldRespondWith` "42"{
post' "/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201
}
it "allows alternative routes if all have request bodies" $ do
post "/bla" (encode alice) `shouldRespondWith` "42"{
post' "/bla" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201
}
it "handles trailing '/' gracefully" $ do
post "/bla/" (encode alice) `shouldRespondWith` "42"{
post' "/bla/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201
}
it "correctly rejects invalid request bodies with status 400" $ do
post "/" "some invalid body" `shouldRespondWith` 400
post' "/" "some invalid body" `shouldRespondWith` 400
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 HeaderApi a = Header "MyHeader" a :> Delete
headerApi :: Proxy (HeaderApi a)
headerApi = Proxy
headerSpec :: Spec
headerSpec = describe "Servant.API.Header" $ do
let expectsInt :: Maybe Int -> EitherT (Int,String) IO ()
expectsInt (Just x) = when (x /= 5) $ error "Expected 5"
expectsInt Nothing = error "Expected an int"
let expectsString :: Maybe String -> EitherT (Int,String) IO ()
expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
expectsString Nothing = error "Expected a string"
with (return (serve headerApi expectsInt)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")]
it "passes the header to the handler (Int)" $
delete' "/" "" `shouldRespondWith` 204
with (return (serve headerApi expectsString)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")]
it "passes the header to the handler (String)" $
delete' "/" "" `shouldRespondWith` 204
type RawApi = "foo" :> Raw
@ -344,8 +379,8 @@ rawSpec = do
type AlternativeApi =
"foo" :> Get Person
:<|> "bar" :> Get Animal
"foo" :> Get '[JSON] Person
:<|> "bar" :> Get '[JSON] Animal
unionApi :: Proxy AlternativeApi
unionApi = Proxy
@ -375,7 +410,7 @@ errorsSpec = do
let ib = InvalidBody "The body is invalid"
let wm = WrongMethod
let nf = NotFound
describe "Servant.Server.Internal.RouteMismatch" $ do
it "HttpError > *" $ do
ib <> he `shouldBe` he

3
test/Servant/Utils/StaticFilesSpec.hs
View File

@ -13,6 +13,7 @@ import System.IO.Temp (withSystemTempDirectory)
import Test.Hspec (Spec, describe, it, around_)
import Test.Hspec.Wai (with, get, shouldRespondWith)
import Servant.API (JSON)
import Servant.API.Alternative ((:<|>)((:<|>)))
import Servant.API.Capture (Capture)
import Servant.API.Get (Get)
@ -23,7 +24,7 @@ import Servant.ServerSpec (Person(Person))
import Servant.Utils.StaticFiles (serveDirectory)
type Api =
"dummy_api" :> Capture "person_name" String :> Get Person
"dummy_api" :> Capture "person_name" String :> Get '[JSON] Person
:<|> "static" :> Raw