diff --git a/CHANGELOG.md b/CHANGELOG.md index 6827d2a1..0993fc8f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ----- diff --git a/default.nix b/default.nix new file mode 100644 index 00000000..e8a420df --- /dev/null +++ b/default.nix @@ -0,0 +1,15 @@ +{ pkgs ? import { 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; + }; +} diff --git a/example/greet.hs b/example/greet.hs index 822559d6..78521af6 100644 --- a/example/greet.hs +++ b/example/greet.hs @@ -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 diff --git a/servant-server.cabal b/servant-server.cabal index 7da021e7..8061a0ba 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -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 diff --git a/src/Servant.hs b/src/Servant.hs index 0a92f8dd..38671f34 100644 --- a/src/Servant.hs +++ b/src/Servant.hs @@ -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 diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index 3d8156ae..4f8c94a8 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -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 diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 4bd0a08b..edee67e4 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -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@. diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index ee3a8d22..e73c565e 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -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 diff --git a/test/Servant/Utils/StaticFilesSpec.hs b/test/Servant/Utils/StaticFilesSpec.hs index 6918448f..4d4b2420 100644 --- a/test/Servant/Utils/StaticFilesSpec.hs +++ b/test/Servant/Utils/StaticFilesSpec.hs @@ -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