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

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

View file

@ -2,6 +2,11 @@ master
------ ------
* Added support for matrix parameters, see e.g. http://www.w3.org/DesignIssues/MatrixURIs.html * 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 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;
};
}

View file

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

View file

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

View file

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

View file

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

View file

@ -9,7 +9,7 @@ module Servant.Server.Internal where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad.Trans.Either (EitherT, runEitherT) 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 as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.IORef (newIORef, readIORef, writeIORef) import Data.IORef (newIORef, readIORef, writeIORef)
@ -24,12 +24,18 @@ import qualified Data.Text as T
import Data.Typeable import Data.Typeable
import GHC.TypeLits (KnownSymbol, symbolVal) import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.HTTP.Types hiding (Header) import Network.HTTP.Types hiding (Header)
import Network.Wai (Response, Request, ResponseReceived, Application, pathInfo, requestBody, import Network.Wai ( Response, Request, ResponseReceived, Application
strictRequestBody, lazyRequestBody, requestHeaders, requestMethod, , pathInfo, requestBody, strictRequestBody
, lazyRequestBody, requestHeaders, requestMethod,
rawQueryString, responseLBS) 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) import Servant.Common.Text (FromText, fromText)
data ReqBodyState = Uncalled data ReqBodyState = Uncalled
| Called !B.ByteString | Called !B.ByteString
| Done !B.ByteString | Done !B.ByteString
@ -66,39 +72,33 @@ toApplication ra request respond = do
respond $ responseLBS methodNotAllowed405 [] "method not allowed" respond $ responseLBS methodNotAllowed405 [] "method not allowed"
routingRespond (Left (InvalidBody err)) = routingRespond (Left (InvalidBody err)) =
respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ 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)) = routingRespond (Left (HttpError status body)) =
respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
routingRespond (Right response) = routingRespond (Right response) =
respond 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 -- * Route mismatch
data RouteMismatch = data RouteMismatch =
NotFound -- ^ the usual "not found" error NotFound -- ^ the usual "not found" error
| WrongMethod -- ^ a more informative "you just got the HTTP method wrong" 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 | 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. | 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 instance Monoid RouteMismatch where
mempty = NotFound 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@. -- | A wrapper around @'Either' 'RouteMismatch' a@.
newtype RouteResult 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 -- represented by @a@ and if it fails tries @b@. You must provide a request
-- handler for each route. -- handler for each route.
-- --
-- > type MyApi = "books" :> Get [Book] -- GET /books -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books -- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = listAllBooks :<|> postBook -- > server = listAllBooks :<|> postBook
@ -203,7 +203,7 @@ captured _ = fromText
-- --
-- Example: -- Example:
-- --
-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book -- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBook -- > server = getBook
@ -225,7 +225,7 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
_ -> respond $ failWith NotFound _ -> respond $ failWith NotFound
where captureProxy = Proxy :: Proxy (Capture capture a) where captureProxy = Proxy :: Proxy (Capture capture a)
-- | If you have a 'Delete' endpoint in your API, -- | If you have a 'Delete' endpoint in your API,
-- the handler for this endpoint is meant to delete -- 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' -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met. -- to quickly fail if some conditions are not met.
-- --
-- If successfully returning a value, we just require that its type has -- If successfully returning a value, we use the type-level list, combined
-- a 'ToJSON' instance and servant takes care of encoding it for you, -- with the request's @Accept@ header, to encode the value for you
-- yielding status code 200 along the way. -- (returning a status code of 200). If there was no @Accept@ header or it
instance ToJSON result => HasServer (Get result) where -- was @*/*@, we return encode using the first @Content-Type@ type on the
type Server (Get result) = EitherT (Int, String) IO result -- 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 route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do | pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action e <- runEitherT action
respond . succeedWith $ case e of respond . succeedWith $ case e of
Right output -> Right output -> do
responseLBS ok200 [("Content-Type", "application/json")] (encode output) 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) -> Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message) responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodGet = | pathIsEmpty request && requestMethod request /= methodGet =
@ -292,7 +299,7 @@ instance ToJSON result => HasServer (Get result) where
-- > deriving (Eq, Show, FromText, ToText) -- > deriving (Eq, Show, FromText, ToText)
-- > -- >
-- > -- GET /view-my-referer -- > -- 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 :: Server MyApi
-- > server = viewReferer -- > server = viewReferer
@ -318,18 +325,25 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met. -- to quickly fail if some conditions are not met.
-- --
-- If successfully returning a value, we just require that its type has -- If successfully returning a value, we use the type-level list, combined
-- a 'ToJSON' instance and servant takes care of encoding it for you, -- with the request's @Accept@ header, to encode the value for you
-- yielding status code 201 along the way. -- (returning a status code of 201). If there was no @Accept@ header or it
instance ToJSON a => HasServer (Post a) where -- was @*/*@, we return encode using the first @Content-Type@ type on the
type Server (Post a) = EitherT (Int, String) IO a -- 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 route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do | pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action e <- runEitherT action
respond . succeedWith $ case e of respond . succeedWith $ case e of
Right out -> Right output -> do
responseLBS status201 [("Content-Type", "application/json")] (encode out) 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) -> Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message) responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPost = | 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' -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met. -- to quickly fail if some conditions are not met.
-- --
-- If successfully returning a value, we just require that its type has -- If successfully returning a value, we use the type-level list, combined
-- a 'ToJSON' instance and servant takes care of encoding it for you, -- with the request's @Accept@ header, to encode the value for you
-- yielding status code 200 along the way. -- (returning a status code of 201). If there was no @Accept@ header or it
instance ToJSON a => HasServer (Put a) where -- was @*/*@, we return encode using the first @Content-Type@ type on the
type Server (Put a) = EitherT (Int, String) IO a -- 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 route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do | pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action e <- runEitherT action
respond . succeedWith $ case e of respond . succeedWith $ case e of
Right out -> Right output -> do
responseLBS ok200 [("Content-Type", "application/json")] (encode out) 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) -> Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message) responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPut = | 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 -- If successfully returning a value, we just require that its type has
-- a 'ToJSON' instance and servant takes care of encoding it for you, -- a 'ToJSON' instance and servant takes care of encoding it for you,
-- yielding status code 201 along the way. -- yielding status code 201 along the way.
instance (Typeable a, ToJSON a) => HasServer (Patch a) where instance ( AllCTRender ctypes a
type Server (Patch a) = EitherT (Int, String) IO 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 route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do | pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action e <- runEitherT action
respond . succeedWith $ case e of respond . succeedWith $ case e of
Right out -> case cast out 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 [] "" Just () -> responseLBS status204 [] ""
Left (status, message) -> Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message) responseLBS (mkStatus status (cs message)) [] (cs message)
@ -404,7 +432,7 @@ instance (Typeable a, ToJSON a) => HasServer (Patch a) where
-- --
-- Example: -- Example:
-- --
-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book] -- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBooksBy -- > server = getBooksBy
@ -443,7 +471,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
-- --
-- Example: -- Example:
-- --
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book] -- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBooksBy -- > server = getBooksBy
@ -476,7 +504,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
-- --
-- Example: -- Example:
-- --
-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book] -- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBooks -- > server = getBooks
@ -635,30 +663,42 @@ instance HasServer Raw where
-- | If you use 'ReqBody' in one of the endpoints for your API, -- | If you use 'ReqBody' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
-- that takes an argument of the type specified by 'ReqBody'. -- 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 -- This lets servant worry about extracting it from the request and turning
-- it into a value of the type you specify. -- it into a value of the type you specify.
-- --
--
-- All it asks is for a 'FromJSON' instance. -- All it asks is for a 'FromJSON' instance.
-- --
-- Example: -- Example:
-- --
-- > type MyApi = "books" :> ReqBody Book :> Post Book -- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = postBook -- > server = postBook
-- > where postBook :: Book -> EitherT (Int, String) IO Book -- > where postBook :: Book -> EitherT (Int, String) IO Book
-- > postBook book = ...insert into your db... -- > postBook book = ...insert into your db...
instance (FromJSON a, HasServer sublayout) instance ( AllCTUnrender list a, HasServer sublayout
=> HasServer (ReqBody a :> sublayout) where ) => HasServer (ReqBody list a :> sublayout) where
type Server (ReqBody a :> sublayout) = type Server (ReqBody list a :> sublayout) =
a -> Server sublayout a -> Server sublayout
route Proxy subserver request respond = do 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 case mrqbody of
Left e -> respond . failWith $ InvalidBody e Nothing -> respond . failWith $ UnsupportedMediaType
Right v -> route (Proxy :: Proxy sublayout) (subserver v) request respond 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 -- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @sublayout@. -- pass the rest of the request path to @sublayout@.

View file

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

View file

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