From e43532b71dd67a7c48f8ed69e66be031344e4ba4 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Wed, 10 Dec 2014 16:10:57 +0100 Subject: [PATCH 01/52] first shot at a server package --- LICENSE | 30 ++ README.md | 25 ++ Setup.hs | 2 + example/README.md | 2 + example/greet.hs | 72 ++++ example/greet.md | 52 +++ servant-server.cabal | 95 ++++++ src/Servant.hs | 24 ++ src/Servant/Server.hs | 39 +++ src/Servant/Server/Internal.hs | 459 ++++++++++++++++++++++++++ src/Servant/Utils/StaticFiles.hs | 36 ++ test/Servant/ServerSpec.hs | 258 +++++++++++++++ test/Servant/Utils/StaticFilesSpec.hs | 64 ++++ test/Spec.hs | 1 + 14 files changed, 1159 insertions(+) create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 example/README.md create mode 100644 example/greet.hs create mode 100644 example/greet.md create mode 100644 servant-server.cabal create mode 100644 src/Servant.hs create mode 100644 src/Servant/Server.hs create mode 100644 src/Servant/Server/Internal.hs create mode 100644 src/Servant/Utils/StaticFiles.hs create mode 100644 test/Servant/ServerSpec.hs create mode 100644 test/Servant/Utils/StaticFilesSpec.hs create mode 100644 test/Spec.hs diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..bfee8018 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Zalora South East Asia Pte Ltd + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Zalora South East Asia Pte Ltd nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 00000000..7d978b8a --- /dev/null +++ b/README.md @@ -0,0 +1,25 @@ +# servant + +[![Build Status](https://secure.travis-ci.org/haskell-servant/servant.svg)](http://travis-ci.org/haskell-servant/servant) + +![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) + +These libraries provides a family of combinators to define webservices and automatically generate the documentation and client-side querying functions for each endpoint. + +In order to minimize the dependencies depending on your needs, we provide these features under different packages. + +- `servant`, which contains everything you need to *declare* a webservice and *implement* an HTTP server with handlers for each endpoint. +- `servant-client`, which lets you derive automatically Haskell functions that let you query each endpoint of a *servant* webservice. +- `servant-docs`, which lets you generate API docs for your webservice. +- `servant-jquery`, which lets you derive Javascript functions (based on jquery) to query your API's endpoints, in the same spirit as `servant-client`. + +## Getting started + +We've written a [Getting Started](http://haskell-servant.github.io/getting-started/) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples. + +## Repositories and Haddocks + +- The core [servant](http://github.com/haskell-servant) package - [docs](http://haskell-servant.github.io/servant/) +- (Haskell) client-side function generation with [servant-client](http://github.com/haskell-servant/servant-client) - [docs](http://haskell-servant.github.io/servant-client/) +- (Javascript) client-side function generation with [servant-jquery](http://github.com/haskell-servant/servant-jquery) - [docs](http://haskell-servant.github.io/servant-jquery/) +- API docs generation with [servant-docs](http://github.com/haskell-servant/servant-docs) - [docs](http://haskell-servant.github.io/servant-docs/) diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/README.md b/example/README.md new file mode 100644 index 00000000..a787d7c7 --- /dev/null +++ b/example/README.md @@ -0,0 +1,2 @@ +- `greet.hs` shows how to write a simple webservice, run it, query it with automatically-derived haskell functions and print the (generated) markdown documentation for the API. +- `greet.md` contains the aforementionned generated documentation. \ No newline at end of file diff --git a/example/greet.hs b/example/greet.hs new file mode 100644 index 00000000..822559d6 --- /dev/null +++ b/example/greet.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} + +import Data.Aeson +import Data.Monoid +import Data.Proxy +import Data.Text +import GHC.Generics +import Network.Wai +import Network.Wai.Handler.Warp + +import Servant + +-- * Example + +-- | A greet message data type +newtype Greet = Greet { msg :: Text } + deriving (Generic, Show) + +instance FromJSON Greet +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 + + -- POST /greet with a Greet as JSON in the request body, + -- returns a Greet as JSON + :<|> "greet" :> ReqBody Greet :> Post Greet + + -- DELETE /greet/:greetid + :<|> "greet" :> Capture "greetid" Text :> Delete + +testApi :: Proxy TestApi +testApi = Proxy + +-- Server-side handlers. +-- +-- There's one handler per endpoint, which, just like in the type +-- that represents the API, are glued together using :<|>. +-- +-- Each handler runs in the 'EitherT (Int, String) IO' monad. +server :: Server TestApi +server = helloH :<|> postGreetH :<|> deleteGreetH + + where helloH name Nothing = helloH name (Just False) + helloH name (Just False) = return . Greet $ "Hello, " <> name + helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name + + postGreetH greet = return greet + + deleteGreetH _ = return () + +-- Turn the server into a WAI app. 'serve' is provided by servant, +-- more precisely by the Servant.Server module. +test :: Application +test = serve testApi server + +-- Run the server. +-- +-- 'run' comes from Network.Wai.Handler.Warp +runTestServer :: Port -> IO () +runTestServer port = run port test + +-- Put this all to work! +main :: IO () +main = runTestServer 8001 diff --git a/example/greet.md b/example/greet.md new file mode 100644 index 00000000..149c3d59 --- /dev/null +++ b/example/greet.md @@ -0,0 +1,52 @@ +POST /greet +----------- + +**Request Body**: + +``` javascript +{"msg":"Hello, haskeller!"} +``` + +**Response**: + + - Status code 201 + - Response body as below. + +``` javascript +{"msg":"Hello, haskeller!"} +``` + +GET /hello/:name +---------------- + +**Captures**: + +- *name*: name of the person to greet + +**GET Parameters**: + + - capital + - **Values**: *true, false* + - **Description**: Get the greeting message in uppercase (true) or not (false). Default is false. + + +**Response**: + + - Status code 200 + - Response body as below. + +``` javascript +{"msg":"Hello, haskeller!"} +``` + +DELETE /greet/:greetid +---------------------- + +**Captures**: + +- *greetid*: identifier of the greet msg to remove + +**Response**: + + - Status code 204 + - No response body diff --git a/servant-server.cabal b/servant-server.cabal new file mode 100644 index 00000000..03d62aa2 --- /dev/null +++ b/servant-server.cabal @@ -0,0 +1,95 @@ +name: servant-server +version: 0.2.1 +synopsis: A family of combinators for defining webservices APIs and serving them +description: + A family of combinators for defining webservices APIs and serving them + . + You can learn about the basics in guide. + . + 's a runnable example, with comments, that defines a dummy API and + implements a webserver that serves this API, using this package. +homepage: http://haskell-servant.github.io/ +Bug-reports: http://github.com/haskell-servant/servant-server/issues +license: BSD3 +license-file: LICENSE +author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni +maintainer: alpmestan@gmail.com +copyright: 2014 Zalora South East Asia Pte Ltd +category: Web +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC >= 7.8 +source-repository head + type: git + location: http://github.com/haskell-servant/servant-server.git + +library + exposed-modules: + Servant + Servant.Server + Servant.Utils.StaticFiles + other-modules: Servant.Server.Internal + build-depends: + base >=4.7 && <5 + , aeson + , attoparsec + , bytestring + , either + , http-types + , network-uri >= 2.6 + , safe + , servant >= 0.2 + , split + , string-conversions + , system-filepath + , text + , transformers + , wai + , wai-app-static + , warp + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +executable greet + main-is: greet.hs + hs-source-dirs: example + ghc-options: -Wall + default-language: Haskell2010 + build-depends: + base + , servant + , servant-server + , aeson + , warp + , wai + , text + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: + -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + base == 4.* + , aeson + , bytestring + , directory + , either + , exceptions + , hspec == 2.* + , hspec-wai + , http-types + , network >= 2.6 + , QuickCheck + , parsec + , servant + , string-conversions + , temporary + , text + , transformers + , wai + , wai-extra + , warp diff --git a/src/Servant.hs b/src/Servant.hs new file mode 100644 index 00000000..0a92f8dd --- /dev/null +++ b/src/Servant.hs @@ -0,0 +1,24 @@ +module Servant ( + -- | This module and its submodules can be used to define servant APIs. Note + -- that these API definitions don't directly implement a server (or anything + -- else). + module Servant.API, + -- | For implementing servers for servant APIs. + module Servant.Server, + -- | 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 + Proxy(..), + ) where + +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 new file mode 100644 index 00000000..d1d6e4c4 --- /dev/null +++ b/src/Servant/Server.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | This module lets you implement 'Server's for defined APIs. You'll +-- most likely just need 'serve'. +module Servant.Server + ( -- * Implementing an API + serve + + , -- * Handlers for all standard combinators + HasServer(..) + ) where + +import Data.Proxy +import Network.Wai +import Servant.Server.Internal + +-- * Implementing Servers + +-- | 'serve' allows you to implement an API and produce a wai 'Application'. +-- +-- Example: +-- +-- > type MyApi = "books" :> Get [Book] -- GET /books +-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books +-- > +-- > server :: Server MyApi +-- > server = listAllBooks :<|> postBook +-- > where listAllBooks = ... +-- > postBook book = ... +-- > +-- > app :: Application +-- > app = serve myApi server +-- > +-- > main :: IO () +-- > main = Network.Wai.Handler.Warp.run 8080 app +serve :: HasServer layout => Proxy layout -> Server layout -> Application +serve p server = toApplication (route p server) + diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs new file mode 100644 index 00000000..a706c211 --- /dev/null +++ b/src/Servant/Server/Internal.hs @@ -0,0 +1,459 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Servant.Server.Internal where + +import Control.Applicative +import Control.Monad.Trans.Either +import Data.Aeson +import Data.Maybe (catMaybes) +import Data.Monoid +import Data.Proxy +import Data.String +import Data.String.Conversions +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import GHC.TypeLits +import Network.HTTP.Types hiding (Header) +import Network.Wai +import Servant.API +import Servant.Common.Text + +toApplication :: RoutingApplication -> Application +toApplication ra request respond = do + ra request (routingRespond . routeResult) + where + routingRespond :: Either RouteMismatch Response -> IO ResponseReceived + routingRespond (Left NotFound) = + respond $ responseLBS notFound404 [] "not found" + routingRespond (Left WrongMethod) = + respond $ responseLBS methodNotAllowed405 [] "method not allowed" + routingRespond (Left InvalidBody) = + respond $ responseLBS badRequest400 [] "Invalid JSON in request body" + routingRespond (Right response) = + respond response + +-- * Route mismatch +data RouteMismatch = + NotFound -- ^ the usual "not found" error + | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error + | InvalidBody -- ^ an even more informative "your json request body wasn't valid" error + deriving (Eq, Show) + +-- | +-- @ +-- > mempty = NotFound +-- > +-- > NotFound `mappend` x = x +-- > WrongMethod `mappend` InvalidBody = InvalidBody +-- > WrongMethod `mappend` _ = WrongMethod +-- > InvalidBody `mappend` _ = InvalidBody +-- @ +instance Monoid RouteMismatch where + mempty = NotFound + + NotFound `mappend` x = x + WrongMethod `mappend` InvalidBody = InvalidBody + WrongMethod `mappend` _ = WrongMethod + InvalidBody `mappend` _ = InvalidBody + +-- | A wrapper around @'Either' 'RouteMismatch' a@. +newtype RouteResult a = + RR { routeResult :: Either RouteMismatch a } + deriving (Eq, Show) + +failWith :: RouteMismatch -> RouteResult a +failWith = RR . Left + +succeedWith :: a -> RouteResult a +succeedWith = RR . Right + +isMismatch :: RouteResult a -> Bool +isMismatch (RR (Left _)) = True +isMismatch _ = False + +-- | If we get a `Right`, it has precedence over everything else. +-- +-- This in particular means that if we could get several 'Right's, +-- only the first we encounter would be taken into account. +instance Monoid (RouteResult a) where + mempty = RR $ Left mempty + + RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y) + RR (Left _) `mappend` RR (Right y) = RR $ Right y + r `mappend` _ = r + +type RoutingApplication = + Request -- ^ the request, the field 'pathInfo' may be modified by url routing + -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived + +class HasServer layout where + type Server layout :: * + route :: Proxy layout -> Server layout -> RoutingApplication + +-- * Instances + +-- | A server for @a ':<|>' b@ first tries to match the request again the route +-- 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 +-- > +-- > server :: Server MyApi +-- > server = listAllBooks :<|> postBook +-- > where listAllBooks = ... +-- > postBook book = ... +instance (HasServer a, HasServer b) => HasServer (a :<|> b) where + type Server (a :<|> b) = Server a :<|> Server b + route Proxy (a :<|> b) request respond = + route pa a request $ \ mResponse -> + if isMismatch mResponse + then route pb b request $ \mResponse' -> respond (mResponse <> mResponse') + else respond mResponse + + where pa = Proxy :: Proxy a + pb = Proxy :: Proxy b + +captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a +captured _ = fromText + +-- | If you use 'Capture' 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 the 'Capture'. +-- This lets servant worry about getting it from the URL and turning +-- it into a value of the type you specify. +-- +-- You can control how it'll be converted from 'Text' to your type +-- by simply providing an instance of 'FromText' for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book +-- > +-- > server :: Server MyApi +-- > server = getBook +-- > where getBook :: Text -> EitherT (Int, String) IO Book +-- > getBook isbn = ... +instance (KnownSymbol capture, FromText a, HasServer sublayout) + => HasServer (Capture capture a :> sublayout) where + + type Server (Capture capture a :> sublayout) = + a -> Server sublayout + + route Proxy subserver request respond = case pathInfo request of + (first : rest) + -> case captured captureProxy first of + Nothing -> respond $ failWith NotFound + Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{ + pathInfo = rest + } respond + _ -> 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 +-- a resource. +-- +-- The code of the handler will, just like +-- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and +-- 'Servant.API.Put.Put', run in @EitherT (Int, String) IO ()@. +-- The 'Int' represents the status code and the 'String' a message +-- to be returned. You can use 'Control.Monad.Trans.Either.left' to +-- painlessly error out if the conditions for a successful deletion +-- are not met. +instance HasServer Delete where + type Server Delete = EitherT (Int, String) IO () + + route Proxy action request respond + | null (pathInfo request) && requestMethod request == methodDelete = do + e <- runEitherT action + respond $ succeedWith $ case e of + Right () -> + responseLBS status204 [] "" + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | null (pathInfo request) && requestMethod request /= methodDelete = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound + +-- | When implementing the handler for a 'Get' endpoint, +-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' +-- and 'Servant.API.Put.Put', the handler code runs in the +-- @EitherT (Int, String) IO@ monad, where the 'Int' represents +-- the status code and the 'String' a message, returned in case of +-- 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 + route Proxy action request respond + | null (pathInfo request) && requestMethod request == methodGet = do + e <- runEitherT action + respond . succeedWith $ case e of + Right output -> + responseLBS ok200 [("Content-Type", "application/json")] (encode output) + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | null (pathInfo 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'. +-- 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 'FromText' instance. +-- +-- Example: +-- +-- > newtype Referer = Referer Text +-- > deriving (Eq, Show, FromText, ToText) +-- > +-- > -- GET /view-my-referer +-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get Referer +-- > +-- > server :: Server MyApi +-- > server = viewReferer +-- > where viewReferer :: Referer -> EitherT (Int, String) IO referer +-- > viewReferer referer = return referer +instance (KnownSymbol sym, FromText a, HasServer sublayout) + => HasServer (Header sym a :> sublayout) where + + type Server (Header sym a :> sublayout) = + Maybe a -> Server sublayout + + route Proxy subserver request respond = do + let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request) + route (Proxy :: Proxy sublayout) (subserver mheader) request respond + + where str = fromString $ symbolVal (Proxy :: Proxy sym) + +-- | When implementing the handler for a 'Post' endpoint, +-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' +-- and 'Servant.API.Put.Put', the handler code runs in the +-- @EitherT (Int, String) IO@ monad, where the 'Int' represents +-- the status code and the 'String' a message, returned in case of +-- 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 + + route Proxy action request respond + | null (pathInfo request) && requestMethod request == methodPost = do + e <- runEitherT action + respond . succeedWith $ case e of + Right out -> + responseLBS status201 [("Content-Type", "application/json")] (encode out) + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | null (pathInfo 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 +-- @EitherT (Int, String) IO@ monad, where the 'Int' represents +-- the status code and the 'String' a message, returned in case of +-- 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 + + route Proxy action request respond + | null (pathInfo request) && requestMethod request == methodPut = do + e <- runEitherT action + respond . succeedWith $ case e of + Right out -> + responseLBS ok200 [("Content-Type", "application/json")] (encode out) + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | null (pathInfo request) && requestMethod request /= methodPut = + respond $ failWith WrongMethod + + | otherwise = respond $ failWith NotFound + +-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of type @'Maybe' 'Text'@. +-- +-- This lets servant worry about looking it up in the query string +-- and turning it into a value of the type you specify, enclosed +-- in 'Maybe', because it may not be there and servant would then +-- hand you 'Nothing'. +-- +-- You can control how it'll be converted from 'Text' to your type +-- by simply providing an instance of 'FromText' for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooksBy +-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book] +-- > getBooksBy Nothing = ...return all books... +-- > getBooksBy (Just author) = ...return books by the given author... +instance (KnownSymbol sym, FromText a, HasServer sublayout) + => HasServer (QueryParam sym a :> sublayout) where + + type Server (QueryParam sym a :> sublayout) = + Maybe a -> Server sublayout + + route Proxy subserver request respond = do + let querytext = parseQueryText $ rawQueryString request + param = + case lookup paramname querytext of + Nothing -> Nothing -- param absent from the query string + Just Nothing -> Nothing -- param present with no value -> Nothing + Just (Just v) -> fromText v -- if present, we try to convert to + -- the right type + + route (Proxy :: Proxy sublayout) (subserver param) request respond + + where paramname = cs $ symbolVal (Proxy :: Proxy sym) + +-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of type @['Text']@. +-- +-- This lets servant worry about looking up 0 or more values in the query string +-- associated to @authors@ and turning each of them into a value of +-- the type you specify. +-- +-- You can control how the individual values are converted from 'Text' to your type +-- by simply providing an instance of 'FromText' for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooksBy +-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book] +-- > getBooksBy authors = ...return all books by these authors... +instance (KnownSymbol sym, FromText a, HasServer sublayout) + => HasServer (QueryParams sym a :> sublayout) where + + type Server (QueryParams sym a :> sublayout) = + [a] -> Server sublayout + + route Proxy subserver request respond = do + let querytext = parseQueryText $ rawQueryString request + -- if sym is "foo", we look for query string parameters + -- named "foo" or "foo[]" and call fromText on the + -- corresponding values + parameters = filter looksLikeParam querytext + values = catMaybes $ map (convert . snd) parameters + + route (Proxy :: Proxy sublayout) (subserver values) request respond + + where paramname = cs $ symbolVal (Proxy :: Proxy sym) + looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") + convert Nothing = Nothing + convert (Just v) = fromText v + +-- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of type 'Bool'. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooks +-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book] +-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... +instance (KnownSymbol sym, HasServer sublayout) + => HasServer (QueryFlag sym :> sublayout) where + + type Server (QueryFlag sym :> sublayout) = + Bool -> Server sublayout + + route Proxy subserver request respond = do + let querytext = parseQueryText $ rawQueryString request + param = case lookup paramname querytext of + Just Nothing -> True -- param is there, with no value + Just (Just v) -> examine v -- param with a value + Nothing -> False -- param not in the query string + + route (Proxy :: Proxy sublayout) (subserver param) request respond + + where paramname = cs $ symbolVal (Proxy :: Proxy sym) + examine v | v == "true" || v == "1" || v == "" = True + | otherwise = False + +-- | Just pass the request to the underlying application and serve its response. +-- +-- Example: +-- +-- > type MyApi = "images" :> Raw +-- > +-- > server :: Server MyApi +-- > server = serveDirectory "/var/www/images" +instance HasServer Raw where + type Server Raw = Application + route Proxy rawApplication request respond = + rawApplication request (respond . succeedWith) + +-- | 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'. +-- 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 +-- > +-- > 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 + + type Server (ReqBody a :> sublayout) = + a -> Server sublayout + + route Proxy subserver request respond = do + mrqbody <- decode' <$> lazyRequestBody request + case mrqbody of + Nothing -> respond $ failWith InvalidBody + Just 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@. +instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where + type Server (path :> sublayout) = Server sublayout + route Proxy subserver request respond = case pathInfo request of + (first : rest) + | first == cs (symbolVal proxyPath) + -> route (Proxy :: Proxy sublayout) subserver request{ + pathInfo = rest + } respond + _ -> respond $ failWith NotFound + + where proxyPath = Proxy :: Proxy path diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs new file mode 100644 index 00000000..17146aa7 --- /dev/null +++ b/src/Servant/Utils/StaticFiles.hs @@ -0,0 +1,36 @@ +-- | This module defines a sever-side handler that lets you serve static files. +-- +-- - 'serveDirectory' lets you serve anything that lives under a particular +-- directory on your filesystem. +module Servant.Utils.StaticFiles ( + serveDirectory, + ) where + +import Filesystem.Path.CurrentOS (decodeString) +import Network.Wai.Application.Static +import Servant.API.Raw +import Servant.Server.Internal + +-- | Serve anything under the specified directory as a 'Raw' endpoint. +-- +-- @ +-- type MyApi = "static" :> Raw +-- +-- server :: Server MyApi +-- server = serveDirectory "\/var\/www" +-- @ +-- +-- would capture any request to @\/static\/\@ and look for +-- @\@ under @\/var\/www@. +-- +-- It will do its best to guess the MIME type for that file, based on the extension, +-- and send an appropriate /Content-Type/ header if possible. +-- +-- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API +-- as a webapp backend, you will most likely not want the static files to be hidden +-- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectory' +-- handler in the last position, because /servant/ will try to match the handlers +-- in order. +serveDirectory :: FilePath -> Server Raw +serveDirectory documentRoot = + staticApp (defaultFileServerSettings (decodeString (documentRoot ++ "/"))) diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs new file mode 100644 index 00000000..38313136 --- /dev/null +++ b/test/Servant/ServerSpec.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.ServerSpec where + + +import Control.Monad.Trans.Either +import Data.Aeson +import Data.Char +import Data.Proxy +import Data.String +import Data.String.Conversions +import GHC.Generics +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Test +import Test.Hspec +import Test.Hspec.Wai + +import Servant.API.Capture +import Servant.API.Get +import Servant.API.ReqBody +import Servant.API.Post +import Servant.API.QueryParam +import Servant.API.Raw +import Servant.API.Sub +import Servant.API.Alternative +import Servant.Server + + +-- * test data types + +data Person = Person { + name :: String, + age :: Integer + } + deriving (Eq, Show, Generic) + +instance ToJSON Person +instance FromJSON Person + +alice :: Person +alice = Person "Alice" 42 + +data Animal = Animal { + species :: String, + numberOfLegs :: Integer + } + deriving (Eq, Show, Generic) + +instance ToJSON Animal +instance FromJSON Animal + +jerry :: Animal +jerry = Animal "Mouse" 4 + +tweety :: Animal +tweety = Animal "Bird" 2 + + +-- * specs + +spec :: Spec +spec = do + captureSpec + getSpec + queryParamSpec + postSpec + rawSpec + unionSpec + + +type CaptureApi = Capture "legs" Integer :> Get Animal +captureApi :: Proxy CaptureApi +captureApi = Proxy +captureServer :: Integer -> EitherT (Int, String) IO Animal +captureServer legs = case legs of + 4 -> return jerry + 2 -> return tweety + _ -> left (404, "not found") + +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 + + with (return (serve + (Proxy :: Proxy (Capture "captured" String :> Raw)) + (\ "captured" request respond -> + respond $ responseLBS ok200 [] (cs $ show $ pathInfo request)))) $ do + it "strips the captured path snippet from pathInfo" $ do + get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) + + +type GetApi = Get Person +getApi :: Proxy GetApi +getApi = Proxy + +getSpec :: Spec +getSpec = do + describe "Servant.API.Get" $ do + with (return (serve getApi (return alice))) $ do + it "allows to GET a Person" $ do + response <- get "/" + return response `shouldRespondWith` 200 + liftIO $ do + decode' (simpleBody response) `shouldBe` Just alice + + it "throws 405 (wrong method) on POSTs" $ do + post "/" "" `shouldRespondWith` 405 + + +type QueryParamApi = QueryParam "name" String :> Get Person + :<|> "a" :> QueryParams "names" String :> Get Person + :<|> "b" :> QueryFlag "capitalize" :> Get Person + +queryParamApi :: Proxy QueryParamApi +queryParamApi = Proxy + +qpServer :: Server QueryParamApi +qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize + + where qpNames (_:name2:_) = return alice { name = name2 } + qpNames _ = return alice + + qpCapitalize False = return alice + qpCapitalize True = return alice { name = map toUpper (name alice) } + + queryParamServer (Just name) = return alice{name = name} + queryParamServer Nothing = return alice + +queryParamSpec :: Spec +queryParamSpec = do + describe "Servant.API.QueryParam" $ do + it "allows to retrieve simple GET parameters" $ + (flip runSession) (serve queryParamApi qpServer) $ do + let params1 = "?name=bob" + response1 <- Network.Wai.Test.request defaultRequest{ + rawQueryString = params1, + queryString = parseQuery params1 + } + liftIO $ do + decode' (simpleBody response1) `shouldBe` Just alice{ + name = "bob" + } + + it "allows to retrieve lists in GET parameters" $ + (flip runSession) (serve queryParamApi qpServer) $ do + let params2 = "?names[]=bob&names[]=john" + response2 <- Network.Wai.Test.request defaultRequest{ + rawQueryString = params2, + queryString = parseQuery params2, + pathInfo = ["a"] + } + liftIO $ + decode' (simpleBody response2) `shouldBe` Just alice{ + name = "john" + } + + it "allows to retrieve value-less GET parameters" $ + (flip runSession) (serve queryParamApi qpServer) $ do + let params3 = "?capitalize" + response3 <- Network.Wai.Test.request defaultRequest{ + rawQueryString = params3, + queryString = parseQuery params3, + pathInfo = ["b"] + } + liftIO $ + decode' (simpleBody response3) `shouldBe` Just alice{ + name = "ALICE" + } + + let params3' = "?capitalize=" + response3' <- Network.Wai.Test.request defaultRequest{ + rawQueryString = params3', + queryString = parseQuery params3', + pathInfo = ["b"] + } + liftIO $ + decode' (simpleBody response3') `shouldBe` Just alice{ + name = "ALICE" + } + +type PostApi = ReqBody Person :> Post Integer +postApi :: Proxy PostApi +postApi = Proxy + +postSpec :: Spec +postSpec = do + describe "Servant.API.Post and .ReqBody" $ do + with (return (serve postApi (return . age))) $ do + it "allows to POST a Person" $ do + post "/" (encode alice) `shouldRespondWith` "42"{ + matchStatus = 201 + } + + it "correctly rejects invalid request bodies with status 400" $ do + post "/" "some invalid body" `shouldRespondWith` 400 + + +type RawApi = "foo" :> Raw +rawApi :: Proxy RawApi +rawApi = Proxy +rawApplication :: Show a => (Request -> a) -> Application +rawApplication f request respond = respond $ responseLBS ok200 [] (cs $ show $ f request) + +rawSpec :: Spec +rawSpec = do + describe "Servant.API.Raw" $ do + it "runs applications" $ do + (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do + response <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["foo"] + } + liftIO $ do + simpleBody response `shouldBe` "42" + + it "gets the pathInfo modified" $ do + (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do + response <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["foo", "bar"] + } + liftIO $ do + simpleBody response `shouldBe` cs (show ["bar" :: String]) + + +type AlternativeApi = + "foo" :> Get Person + :<|> "bar" :> Get Animal +unionApi :: Proxy AlternativeApi +unionApi = Proxy + +unionServer :: Server AlternativeApi +unionServer = + return alice + :<|> return jerry + +unionSpec :: Spec +unionSpec = do + describe "Servant.API.Alternative" $ do + with (return $ serve unionApi unionServer) $ do + it "unions endpoints" $ do + response <- get "/foo" + liftIO $ do + decode' (simpleBody response) `shouldBe` + Just alice + response <- get "/bar" + liftIO $ do + decode' (simpleBody response) `shouldBe` + Just jerry diff --git a/test/Servant/Utils/StaticFilesSpec.hs b/test/Servant/Utils/StaticFilesSpec.hs new file mode 100644 index 00000000..8d34f90f --- /dev/null +++ b/test/Servant/Utils/StaticFilesSpec.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Servant.Utils.StaticFilesSpec where + +import Control.Exception +import Data.Proxy +import Network.Wai +import System.Directory +import System.IO.Temp +import Test.Hspec hiding (pending) +import Test.Hspec.Wai + +import Servant.API.Alternative +import Servant.API.Capture +import Servant.API.Get +import Servant.API.Raw +import Servant.API.Sub +import Servant.Server +import Servant.ServerSpec +import Servant.Utils.StaticFiles + +type Api = + "dummy_api" :> Capture "person_name" String :> Get Person + :<|> "static" :> Raw + + +api :: Proxy Api +api = Proxy + +app :: Application +app = serve api server + +server :: Server Api +server = + (\ name -> return (Person name 42)) + :<|> serveDirectory "static" + +withStaticFiles :: IO () -> IO () +withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir -> + bracket (setup tmpDir) teardown (const action) + where + setup tmpDir = do + outer <- getCurrentDirectory + setCurrentDirectory tmpDir + createDirectory "static" + writeFile "static/foo.txt" "bar" + writeFile "static/index.html" "index" + return outer + + teardown outer = do + setCurrentDirectory outer + +spec :: Spec +spec = do + around_ withStaticFiles $ with (return app) $ do + describe "serveDirectory" $ do + it "successfully serves files" $ do + get "/static/foo.txt" `shouldRespondWith` "bar" + + it "serves the contents of index.html when requesting the root of a directory" $ do + get "/static" `shouldRespondWith` "index" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} From 824c56ff223006ff43209ac1187b3a8e7f4258da Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Wed, 10 Dec 2014 16:39:40 +0100 Subject: [PATCH 02/52] prepare for release --- .travis.yml | 15 +++++++++++++++ README.md | 13 +++---------- servant-server.cabal | 1 + 3 files changed, 19 insertions(+), 10 deletions(-) create mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 00000000..b1f3666c --- /dev/null +++ b/.travis.yml @@ -0,0 +1,15 @@ +language: haskell + +ghc: + - 7.8 + +notifications: + irc: + channels: + - "irc.freenode.org#servant" + template: + - "%{repository}#%{build_number} - %{commit} on %{branch} by %{author}: %{message}" + - "Build details: %{build_url} - Change view: %{compare_url}" + skip_join: true + on_success: change + on_failure: always diff --git a/README.md b/README.md index 7d978b8a..448f82e1 100644 --- a/README.md +++ b/README.md @@ -1,17 +1,10 @@ -# servant +# servant-server -[![Build Status](https://secure.travis-ci.org/haskell-servant/servant.svg)](http://travis-ci.org/haskell-servant/servant) +[![Build Status](https://secure.travis-ci.org/haskell-servant/servant-server.svg)](http://travis-ci.org/haskell-servant/servant-server) ![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) -These libraries provides a family of combinators to define webservices and automatically generate the documentation and client-side querying functions for each endpoint. - -In order to minimize the dependencies depending on your needs, we provide these features under different packages. - -- `servant`, which contains everything you need to *declare* a webservice and *implement* an HTTP server with handlers for each endpoint. -- `servant-client`, which lets you derive automatically Haskell functions that let you query each endpoint of a *servant* webservice. -- `servant-docs`, which lets you generate API docs for your webservice. -- `servant-jquery`, which lets you derive Javascript functions (based on jquery) to query your API's endpoints, in the same spirit as `servant-client`. +This library lets you *implement* an HTTP server with handlers for each endpoint of a servant API, handling most of the boilerplate for you. ## Getting started diff --git a/servant-server.cabal b/servant-server.cabal index 03d62aa2..0f5f1a91 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -86,6 +86,7 @@ test-suite spec , QuickCheck , parsec , servant + , servant-server , string-conversions , temporary , text From 0fea0ddbf96e6125194db281e82f4b1cf6a6313a Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Fri, 19 Dec 2014 18:15:21 +0100 Subject: [PATCH 03/52] expose Servant.Server.Internal, useful when we define our own combinators externally --- servant-server.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-server.cabal b/servant-server.cabal index 0f5f1a91..d1fefddd 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -1,5 +1,5 @@ name: servant-server -version: 0.2.1 +version: 0.2.2 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them @@ -27,8 +27,8 @@ library exposed-modules: Servant Servant.Server + Servant.Server.Internal Servant.Utils.StaticFiles - other-modules: Servant.Server.Internal build-depends: base >=4.7 && <5 , aeson From df5c8d9843cf0c48850db71ceb5124afc0535cb6 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Fri, 19 Dec 2014 18:26:03 +0100 Subject: [PATCH 04/52] guard against failures with old versions of 'either' --- servant-server.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-server.cabal b/servant-server.cabal index d1fefddd..8a2f13e0 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -34,7 +34,7 @@ library , aeson , attoparsec , bytestring - , either + , either >= 4.3 , http-types , network-uri >= 2.6 , safe From 77aed79eba1ade40bae489ea339221857e2a3ba6 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Thu, 1 Jan 2015 20:10:17 +0000 Subject: [PATCH 05/52] Complete code example in Servant.Server --- src/Servant/Server.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index d1d6e4c4..d8661585 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -29,6 +29,9 @@ import Servant.Server.Internal -- > where listAllBooks = ... -- > postBook book = ... -- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > -- > app :: Application -- > app = serve myApi server -- > From 83f55259fa45f2ecfc73e0c2833ec262347a0fdb Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 2 Jan 2015 19:34:15 +0100 Subject: [PATCH 06/52] Memoize requestBody IO action. --- src/Servant/Server/Internal.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index a706c211..8a8d423a 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -10,13 +10,14 @@ module Servant.Server.Internal where import Control.Applicative import Control.Monad.Trans.Either import Data.Aeson -import Data.Maybe (catMaybes) +import Data.IORef +import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid import Data.Proxy import Data.String import Data.String.Conversions -import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) +import Data.Text (Text) import GHC.TypeLits import Network.HTTP.Types hiding (Header) import Network.Wai @@ -25,7 +26,12 @@ import Servant.Common.Text toApplication :: RoutingApplication -> Application toApplication ra request respond = do - ra request (routingRespond . routeResult) + reqBodyRef <- newIORef Nothing + let memoReqBody = fromMaybe <$> (do + r <- requestBody request + writeIORef reqBodyRef $ Just r + return r ) <*> readIORef reqBodyRef + ra request{ requestBody = memoReqBody } (routingRespond . routeResult) where routingRespond :: Either RouteMismatch Response -> IO ResponseReceived routingRespond (Left NotFound) = @@ -44,7 +50,7 @@ data RouteMismatch = | InvalidBody -- ^ an even more informative "your json request body wasn't valid" error deriving (Eq, Show) --- | +-- | -- @ -- > mempty = NotFound -- > From ecb1da0e37a260b0ee9123a57ddbd10b4d39b70d Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 3 Jan 2015 18:07:39 +0100 Subject: [PATCH 07/52] Cycle through ByteString. --- src/Servant/Server/Internal.hs | 28 ++++++++++++++++++++++------ 1 file changed, 22 insertions(+), 6 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 8a8d423a..2b16fea0 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -10,8 +10,10 @@ module Servant.Server.Internal where import Control.Applicative import Control.Monad.Trans.Either import Data.Aeson +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL import Data.IORef -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes) import Data.Monoid import Data.Proxy import Data.String @@ -24,13 +26,27 @@ import Network.Wai import Servant.API import Servant.Common.Text +data ReqBodyState = Uncalled + | Called B.ByteString + | Done B.ByteString + toApplication :: RoutingApplication -> Application toApplication ra request respond = do - reqBodyRef <- newIORef Nothing - let memoReqBody = fromMaybe <$> (do - r <- requestBody request - writeIORef reqBodyRef $ Just r - return r ) <*> readIORef reqBodyRef + reqBodyRef <- newIORef Uncalled + let memoReqBody = do + ior <- readIORef reqBodyRef + case ior of + Uncalled -> do + r <- BL.toStrict <$> strictRequestBody request + writeIORef reqBodyRef $ Done r + return r + Called bs -> do + writeIORef reqBodyRef $ Done bs + return bs + Done bs -> do + writeIORef reqBodyRef $ Called bs + return B.empty + ra request{ requestBody = memoReqBody } (routingRespond . routeResult) where routingRespond :: Either RouteMismatch Response -> IO ResponseReceived From 726848b8a3e58bc92172bc1bedd7e9d72d2b9b8c Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 3 Jan 2015 18:16:26 +0100 Subject: [PATCH 08/52] Add comment about what the bug was. Make ReqBodyState strict. --- src/Servant/Server/Internal.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 2b16fea0..5a9fbe5b 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -27,12 +27,15 @@ import Servant.API import Servant.Common.Text data ReqBodyState = Uncalled - | Called B.ByteString - | Done B.ByteString + | Called !B.ByteString + | Done !B.ByteString toApplication :: RoutingApplication -> Application toApplication ra request respond = do reqBodyRef <- newIORef Uncalled + -- We need to check the requestBody possibly more than once, so instead + -- of consuming it entirely once, we cycle through it. + -- See https://github.com/haskell-servant/servant/issues/3 let memoReqBody = do ior <- readIORef reqBodyRef case ior of From b43301967d20c160ef624129a0b20e596261af22 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 4 Jan 2015 16:08:22 +0100 Subject: [PATCH 09/52] Update reqBodyRef comment. --- src/Servant/Server/Internal.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 5a9fbe5b..e87a4733 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -33,8 +33,11 @@ data ReqBodyState = Uncalled toApplication :: RoutingApplication -> Application toApplication ra request respond = do reqBodyRef <- newIORef Uncalled - -- We need to check the requestBody possibly more than once, so instead - -- of consuming it entirely once, we cycle through it. + -- We may need to consume the requestBody more than once. In order to + -- maintain the illusion that 'requestBody' works as expected, + -- 'ReqBodyState' is introduced, and the complete body is memoized and + -- returned as many times as requested with empty "Done" marker chunks in + -- between. -- See https://github.com/haskell-servant/servant/issues/3 let memoReqBody = do ior <- readIORef reqBodyRef From 1ec9d0a497d2fed8ffc5f1eccf2fd9c32c90aec4 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 4 Jan 2015 16:21:25 +0100 Subject: [PATCH 10/52] Add CHANGELOG. --- CHANGELOG.md | 6 ++++++ servant-server.cabal | 4 ++++ 2 files changed, 10 insertions(+) create mode 100644 CHANGELOG.md diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 00000000..354d0927 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +0.2.3 +----- + +* Fix consuming request body issue + (https://github.com/haskell-servant/servant/issues/3) +* Make code sample in Servant.Server complete diff --git a/servant-server.cabal b/servant-server.cabal index 8a2f13e0..f326d3b8 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -23,6 +23,10 @@ source-repository head type: git location: http://github.com/haskell-servant/servant-server.git +extra-source-files: + CHANGELOG.md + README.md + library exposed-modules: Servant From 0cc4f975cce5685e933b103dfbb00196659bb6d2 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 4 Jan 2015 16:22:28 +0100 Subject: [PATCH 11/52] Bump version to 0.2.3 --- servant-server.cabal | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/servant-server.cabal b/servant-server.cabal index f326d3b8..5cb01ef0 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -1,5 +1,5 @@ name: servant-server -version: 0.2.2 +version: 0.2.3 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them @@ -19,13 +19,13 @@ category: Web build-type: Simple cabal-version: >=1.10 tested-with: GHC >= 7.8 +extra-source-files: + CHANGELOG.md + README.md source-repository head type: git location: http://github.com/haskell-servant/servant-server.git -extra-source-files: - CHANGELOG.md - README.md library exposed-modules: From 9b8d25c83824c096af9187353824bda51d548bd3 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 5 Jan 2015 14:27:06 +0100 Subject: [PATCH 12/52] Ignore redundant trailing slashes (with test case). --- src/Servant/Server/Internal.hs | 24 ++++++++++++++++-------- test/Servant/ServerSpec.hs | 5 +++++ 2 files changed, 21 insertions(+), 8 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index e87a4733..0421124b 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -104,6 +104,14 @@ isMismatch :: RouteResult a -> Bool isMismatch (RR (Left _)) = True isMismatch _ = False +-- | Like `null . pathInfo`, but works with redundant trailing slashes. +pathIsEmpty :: Request -> Bool +pathIsEmpty = f . pathInfo + where + f [] = True + f [""] = True + f _ = False + -- | If we get a `Right`, it has precedence over everything else. -- -- This in particular means that if we could get several 'Right's, @@ -199,14 +207,14 @@ instance HasServer Delete where type Server Delete = EitherT (Int, String) IO () route Proxy action request respond - | null (pathInfo request) && requestMethod request == methodDelete = do + | pathIsEmpty request && requestMethod request == methodDelete = do e <- runEitherT action respond $ succeedWith $ case e of Right () -> responseLBS status204 [] "" Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) - | null (pathInfo request) && requestMethod request /= methodDelete = + | pathIsEmpty request && requestMethod request /= methodDelete = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -224,14 +232,14 @@ instance HasServer Delete where instance ToJSON result => HasServer (Get result) where type Server (Get result) = EitherT (Int, String) IO result route Proxy action request respond - | null (pathInfo request) && requestMethod request == methodGet = do + | pathIsEmpty request && requestMethod request == methodGet = do e <- runEitherT action respond . succeedWith $ case e of Right output -> responseLBS ok200 [("Content-Type", "application/json")] (encode output) Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) - | null (pathInfo request) && requestMethod request /= methodGet = + | pathIsEmpty request && requestMethod request /= methodGet = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -282,14 +290,14 @@ instance ToJSON a => HasServer (Post a) where type Server (Post a) = EitherT (Int, String) IO a route Proxy action request respond - | null (pathInfo request) && requestMethod request == methodPost = do + | pathIsEmpty request && requestMethod request == methodPost = do e <- runEitherT action respond . succeedWith $ case e of Right out -> responseLBS status201 [("Content-Type", "application/json")] (encode out) Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) - | null (pathInfo request) && requestMethod request /= methodPost = + | pathIsEmpty request && requestMethod request /= methodPost = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -308,14 +316,14 @@ instance ToJSON a => HasServer (Put a) where type Server (Put a) = EitherT (Int, String) IO a route Proxy action request respond - | null (pathInfo request) && requestMethod request == methodPut = do + | pathIsEmpty request && requestMethod request == methodPut = do e <- runEitherT action respond . succeedWith $ case e of Right out -> responseLBS ok200 [("Content-Type", "application/json")] (encode out) Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) - | null (pathInfo request) && requestMethod request /= methodPut = + | pathIsEmpty request && requestMethod request /= methodPut = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index de802670..7ae69c17 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -209,6 +209,11 @@ postSpec = do matchStatus = 201 } + it "handles trailing '/' gracefully" $ do + post "/bla/" (encode alice) `shouldRespondWith` "42"{ + matchStatus = 201 + } + it "correctly rejects invalid request bodies with status 400" $ do post "/" "some invalid body" `shouldRespondWith` 400 From 2f9c6340c4d647485187a97c75f1fe6ea621ac05 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 6 Jan 2015 17:25:25 +0100 Subject: [PATCH 13/52] Explicit imports in /src. --- src/Servant/Server.hs | 9 +++++---- src/Servant/Server/Internal.hs | 26 ++++++++++++++------------ src/Servant/Utils/StaticFiles.hs | 6 +++--- 3 files changed, 22 insertions(+), 19 deletions(-) diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index d8661585..3d8156ae 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -11,10 +11,12 @@ module Servant.Server HasServer(..) ) where -import Data.Proxy -import Network.Wai +import Data.Proxy (Proxy) +import Network.Wai (Application) + import Servant.Server.Internal + -- * Implementing Servers -- | 'serve' allows you to implement an API and produce a wai 'Application'. @@ -30,7 +32,7 @@ import Servant.Server.Internal -- > postBook book = ... -- > -- > myApi :: Proxy MyApi --- > myApi = Proxy +-- > myApi = Proxy -- > -- > app :: Application -- > app = serve myApi server @@ -39,4 +41,3 @@ import Servant.Server.Internal -- > main = Network.Wai.Handler.Warp.run 8080 app serve :: HasServer layout => Proxy layout -> Server layout -> Application serve p server = toApplication (route p server) - diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 0421124b..02d81bf9 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -7,24 +7,26 @@ {-# LANGUAGE ScopedTypeVariables #-} module Servant.Server.Internal where -import Control.Applicative -import Control.Monad.Trans.Either -import Data.Aeson +import Control.Applicative ((<$>)) +import Control.Monad.Trans.Either (EitherT, runEitherT) +import Data.Aeson (ToJSON, FromJSON, encode, decode') import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -import Data.IORef +import Data.IORef (newIORef, readIORef, writeIORef) import Data.Maybe (catMaybes) -import Data.Monoid -import Data.Proxy -import Data.String -import Data.String.Conversions +import Data.Monoid (Monoid, mempty, mappend) +import Data.Proxy (Proxy(Proxy)) +import Data.String (fromString) +import Data.String.Conversions (cs, (<>)) import Data.Text.Encoding (decodeUtf8) import Data.Text (Text) -import GHC.TypeLits +import GHC.TypeLits (KnownSymbol, symbolVal) import Network.HTTP.Types hiding (Header) -import Network.Wai -import Servant.API -import Servant.Common.Text +import Network.Wai (Response, Request, ResponseReceived, Application, pathInfo, requestBody, + strictRequestBody, lazyRequestBody, requestHeaders, requestMethod, + rawQueryString, responseLBS) +import Servant.API (QueryParams, QueryParam, QueryFlag, ReqBody, Header, Capture, Get, Delete, Put, Post, Raw, (:>), (:<|>)(..)) +import Servant.Common.Text (FromText, fromText) data ReqBodyState = Uncalled | Called !B.ByteString diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs index 17146aa7..9cd5fdcc 100644 --- a/src/Servant/Utils/StaticFiles.hs +++ b/src/Servant/Utils/StaticFiles.hs @@ -7,9 +7,9 @@ module Servant.Utils.StaticFiles ( ) where import Filesystem.Path.CurrentOS (decodeString) -import Network.Wai.Application.Static -import Servant.API.Raw -import Servant.Server.Internal +import Network.Wai.Application.Static (staticApp, defaultFileServerSettings) +import Servant.API.Raw (Raw) +import Servant.Server.Internal (Server) -- | Serve anything under the specified directory as a 'Raw' endpoint. -- From 663fbaaabb5ebdb6a4e1827a870dbac03306f917 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 6 Jan 2015 17:26:37 +0100 Subject: [PATCH 14/52] Make -Wall less noisy. --- test/Servant/ServerSpec.hs | 12 ++++++------ test/Servant/Utils/StaticFilesSpec.hs | 2 +- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 7ae69c17..7e2bb3b2 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -94,8 +94,8 @@ captureSpec = do with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) - (\ "captured" request respond -> - respond $ responseLBS ok200 [] (cs $ show $ pathInfo request)))) $ do + (\ "captured" request_ respond -> + respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) @@ -134,7 +134,7 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize qpCapitalize False = return alice qpCapitalize True = return alice { name = map toUpper (name alice) } - queryParamServer (Just name) = return alice{name = name} + queryParamServer (Just name_) = return alice{name = name_} queryParamServer Nothing = return alice queryParamSpec :: Spec @@ -222,7 +222,7 @@ type RawApi = "foo" :> Raw rawApi :: Proxy RawApi rawApi = Proxy rawApplication :: Show a => (Request -> a) -> Application -rawApplication f request respond = respond $ responseLBS ok200 [] (cs $ show $ f request) +rawApplication f request_ respond = respond $ responseLBS ok200 [] (cs $ show $ f request_) rawSpec :: Spec rawSpec = do @@ -264,7 +264,7 @@ unionSpec = do liftIO $ do decode' (simpleBody response) `shouldBe` Just alice - response <- get "/bar" + response_ <- get "/bar" liftIO $ do - decode' (simpleBody response) `shouldBe` + decode' (simpleBody response_) `shouldBe` Just jerry diff --git a/test/Servant/Utils/StaticFilesSpec.hs b/test/Servant/Utils/StaticFilesSpec.hs index 8d34f90f..731edc6e 100644 --- a/test/Servant/Utils/StaticFilesSpec.hs +++ b/test/Servant/Utils/StaticFilesSpec.hs @@ -35,7 +35,7 @@ app = serve api server server :: Server Api server = - (\ name -> return (Person name 42)) + (\ name_ -> return (Person name_ 42)) :<|> serveDirectory "static" withStaticFiles :: IO () -> IO () From ca817f0c9d48ddba69beb26b783a23eb10a7ac20 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 6 Jan 2015 17:34:03 +0100 Subject: [PATCH 15/52] Explicit imports in /test. --- test/Servant/ServerSpec.hs | 42 +++++++++++++-------------- test/Servant/Utils/StaticFilesSpec.hs | 30 +++++++++---------- 2 files changed, 36 insertions(+), 36 deletions(-) diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 7e2bb3b2..c907cd26 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -8,28 +8,28 @@ module Servant.ServerSpec where -import Control.Monad.Trans.Either -import Data.Aeson -import Data.Char -import Data.Proxy -import Data.String -import Data.String.Conversions -import GHC.Generics -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Test -import Test.Hspec -import Test.Hspec.Wai +import Control.Monad.Trans.Either (EitherT, left) +import Data.Aeson (ToJSON, FromJSON, encode, decode') +import Data.Char (toUpper) +import Data.Proxy (Proxy(Proxy)) +import Data.String (fromString) +import Data.String.Conversions (cs) +import GHC.Generics (Generic) +import Network.HTTP.Types (parseQuery, ok200) +import Network.Wai (Application, Request, responseLBS, pathInfo, queryString, rawQueryString) +import Network.Wai.Test (runSession, request, defaultRequest, simpleBody) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec.Wai (liftIO, with, get, post, shouldRespondWith, matchStatus) -import Servant.API.Capture -import Servant.API.Get -import Servant.API.ReqBody -import Servant.API.Post -import Servant.API.QueryParam -import Servant.API.Raw -import Servant.API.Sub -import Servant.API.Alternative -import Servant.Server +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.Raw (Raw) +import Servant.API.Sub ((:>)) +import Servant.API.Alternative ((:<|>)((:<|>))) +import Servant.Server (Server, serve) -- * test data types diff --git a/test/Servant/Utils/StaticFilesSpec.hs b/test/Servant/Utils/StaticFilesSpec.hs index 731edc6e..de7b9e3c 100644 --- a/test/Servant/Utils/StaticFilesSpec.hs +++ b/test/Servant/Utils/StaticFilesSpec.hs @@ -5,22 +5,22 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Utils.StaticFilesSpec where -import Control.Exception -import Data.Proxy -import Network.Wai -import System.Directory -import System.IO.Temp -import Test.Hspec hiding (pending) -import Test.Hspec.Wai +import Control.Exception (bracket) +import Data.Proxy (Proxy(Proxy)) +import Network.Wai (Application) +import System.Directory (getCurrentDirectory, setCurrentDirectory, createDirectory) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec (Spec, describe, it, around_) +import Test.Hspec.Wai (with, get, shouldRespondWith) -import Servant.API.Alternative -import Servant.API.Capture -import Servant.API.Get -import Servant.API.Raw -import Servant.API.Sub -import Servant.Server -import Servant.ServerSpec -import Servant.Utils.StaticFiles +import Servant.API.Alternative ((:<|>)((:<|>))) +import Servant.API.Capture (Capture) +import Servant.API.Get (Get) +import Servant.API.Raw (Raw) +import Servant.API.Sub ((:>)) +import Servant.Server (Server, serve) +import Servant.ServerSpec (Person(Person)) +import Servant.Utils.StaticFiles (serveDirectory) type Api = "dummy_api" :> Capture "person_name" String :> Get Person From b18f27df7a90d3e7caceef9eedb590b19ea730f4 Mon Sep 17 00:00:00 2001 From: Daniel Larsson Date: Sun, 28 Dec 2014 23:07:14 +0100 Subject: [PATCH 16/52] Added support for Matrix parameters --- .gitignore | 17 ++++ servant-server.cabal | 4 +- src/Servant/Server/Internal.hs | 156 +++++++++++++++++++++++++++++++-- test/Servant/ServerSpec.hs | 96 ++++++++++++++++++++ 4 files changed, 265 insertions(+), 8 deletions(-) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..0855a79b --- /dev/null +++ b/.gitignore @@ -0,0 +1,17 @@ +dist +cabal-dev +*.o +*.hi +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.virtualenv +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +cabal.config +*.prof +*.aux +*.hp diff --git a/servant-server.cabal b/servant-server.cabal index 5cb01ef0..fdc59103 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -1,5 +1,5 @@ name: servant-server -version: 0.2.3 +version: 0.2.4 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them @@ -42,7 +42,7 @@ library , http-types , network-uri >= 2.6 , safe - , servant >= 0.2 + , servant >= 0.2.2 , split , string-conversions , system-filepath diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 02d81bf9..621a2be8 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -13,19 +13,21 @@ import Data.Aeson (ToJSON, FromJSON, encode, decode') 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) import Data.Monoid (Monoid, mempty, mappend) import Data.Proxy (Proxy(Proxy)) import Data.String (fromString) import Data.String.Conversions (cs, (<>)) -import Data.Text.Encoding (decodeUtf8) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text (Text) +import qualified Data.Text as T 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, Capture, Get, Delete, Put, Post, Raw, (:>), (:<|>)(..)) +import Servant.API (QueryParams, QueryParam, QueryFlag, MatrixParams, MatrixParam, MatrixFlag, ReqBody, Header, Capture, Get, Delete, Put, Post, Raw, (:>), (:<|>)(..)) import Servant.Common.Text (FromText, fromText) data ReqBodyState = Uncalled @@ -108,7 +110,7 @@ isMismatch _ = False -- | Like `null . pathInfo`, but works with redundant trailing slashes. pathIsEmpty :: Request -> Bool -pathIsEmpty = f . pathInfo +pathIsEmpty = f . processedPathInfo where f [] = True f [""] = True @@ -129,13 +131,36 @@ type RoutingApplication = Request -- ^ the request, the field 'pathInfo' may be modified by url routing -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived +splitMatrixParameters :: Text -> (Text, Text) +splitMatrixParameters = T.break (== ';') + +parsePathInfo :: Request -> [Text] +parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo + where mergePairs = concat . unfoldr pairToList + pairToList [] = Nothing + pairToList ((a, b):xs) = Just ([a, b], xs) + +-- | Returns a processed pathInfo from the request. +-- +-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be +-- processed, so routing works as intended. Therefor this function should be used to access +-- the pathInfo for routing purposes. +processedPathInfo :: Request -> [Text] +processedPathInfo r = + case pinfo of + (x:xs) | T.head x == ';' -> xs + _ -> pinfo + where pinfo = parsePathInfo r + class HasServer layout where type Server layout :: * route :: Proxy layout -> Server layout -> RoutingApplication + + -- * Instances --- | A server for @a ':<|>' b@ first tries to match the request again the route +-- | A server for @a ':<|>' b@ first tries to match the request against the route -- represented by @a@ and if it fails tries @b@. You must provide a request -- handler for each route. -- @@ -183,7 +208,7 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout) type Server (Capture capture a :> sublayout) = a -> Server sublayout - route Proxy subserver request respond = case pathInfo request of + route Proxy subserver request respond = case processedPathInfo request of (first : rest) -> case captured captureProxy first of Nothing -> respond $ failWith NotFound @@ -193,6 +218,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 @@ -441,6 +467,124 @@ instance (KnownSymbol sym, HasServer sublayout) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False +parseMatrixText :: B.ByteString -> QueryText +parseMatrixText = parseQueryText + +-- | If you use @'MatrixParam' "author" Text@ in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of type @'Maybe' 'Text'@. +-- +-- This lets servant worry about looking it up in the query string +-- and turning it into a value of the type you specify, enclosed +-- in 'Maybe', because it may not be there and servant would then +-- hand you 'Nothing'. +-- +-- You can control how it'll be converted from 'Text' to your type +-- by simply providing an instance of 'FromText' for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> MatrixParam "author" Text :> Get [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooksBy +-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book] +-- > getBooksBy Nothing = ...return all books... +-- > getBooksBy (Just author) = ...return books by the given author... +instance (KnownSymbol sym, FromText a, HasServer sublayout) + => HasServer (MatrixParam sym a :> sublayout) where + + type Server (MatrixParam sym a :> sublayout) = + Maybe a -> Server sublayout + + route Proxy subserver request respond = case parsePathInfo request of + (first : _) + -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first + param = case lookup paramname querytext of + Nothing -> Nothing -- param absent from the query string + Just Nothing -> Nothing -- param present with no value -> Nothing + Just (Just v) -> fromText v -- if present, we try to convert to + -- the right type + route (Proxy :: Proxy sublayout) (subserver param) request respond + _ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond + + where paramname = cs $ symbolVal (Proxy :: Proxy sym) + +-- | If you use @'MatrixParams' "authors" Text@ in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of type @['Text']@. +-- +-- This lets servant worry about looking up 0 or more values in the query string +-- associated to @authors@ and turning each of them into a value of +-- the type you specify. +-- +-- You can control how the individual values are converted from 'Text' to your type +-- by simply providing an instance of 'FromText' for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> MatrixParams "authors" Text :> Get [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooksBy +-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book] +-- > getBooksBy authors = ...return all books by these authors... +instance (KnownSymbol sym, FromText a, HasServer sublayout) + => HasServer (MatrixParams sym a :> sublayout) where + + type Server (MatrixParams sym a :> sublayout) = + [a] -> Server sublayout + + route Proxy subserver request respond = case parsePathInfo request of + (first : _) + -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first + -- if sym is "foo", we look for matrix parameters + -- named "foo" or "foo[]" and call fromText on the + -- corresponding values + parameters = filter looksLikeParam matrixtext + values = catMaybes $ map (convert . snd) parameters + route (Proxy :: Proxy sublayout) (subserver values) request respond + _ -> route (Proxy :: Proxy sublayout) (subserver []) request respond + + where paramname = cs $ symbolVal (Proxy :: Proxy sym) + looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") + convert Nothing = Nothing + convert (Just v) = fromText v + +-- | If you use @'MatrixFlag' "published"@ in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of type 'Bool'. +-- +-- Example: +-- +-- > type MyApi = "books" :> MatrixFlag "published" :> Get [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooks +-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book] +-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... +instance (KnownSymbol sym, HasServer sublayout) + => HasServer (MatrixFlag sym :> sublayout) where + + type Server (MatrixFlag sym :> sublayout) = + Bool -> Server sublayout + + route Proxy subserver request respond = case parsePathInfo request of + (first : _) + -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first + param = case lookup paramname matrixtext of + Just Nothing -> True -- param is there, with no value + Just (Just v) -> examine v -- param with a value + Nothing -> False -- param not in the query string + + route (Proxy :: Proxy sublayout) (subserver param) request respond + + _ -> route (Proxy :: Proxy sublayout) (subserver False) request respond + + where paramname = cs $ symbolVal (Proxy :: Proxy sym) + examine v | v == "true" || v == "1" || v == "" = True + | otherwise = False + -- | Just pass the request to the underlying application and serve its response. -- -- Example: @@ -486,7 +630,7 @@ instance (FromJSON a, HasServer sublayout) -- pass the rest of the request path to @sublayout@. instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where type Server (path :> sublayout) = Server sublayout - route Proxy subserver request respond = case pathInfo request of + route Proxy subserver request respond = case processedPathInfo request of (first : rest) | first == cs (symbolVal proxyPath) -> route (Proxy :: Proxy sublayout) subserver request{ diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index c907cd26..56e98d94 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -26,6 +26,7 @@ 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 ((:<|>)((:<|>))) @@ -69,6 +70,7 @@ spec = do captureSpec getSpec queryParamSpec + matrixParamSpec postSpec rawSpec unionSpec @@ -189,6 +191,100 @@ queryParamSpec = do name = "ALICE" } + let params3'' = "?unknown=" + response3' <- Network.Wai.Test.request defaultRequest{ + rawQueryString = params3'', + queryString = parseQuery params3'', + pathInfo = ["b"] + } + liftIO $ + decode' (simpleBody response3') `shouldBe` Just alice{ + 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 + +matrixParamApi :: Proxy MatrixParamApi +matrixParamApi = Proxy + +mpServer :: Server MatrixParamApi +mpServer = matrixParamServer :<|> mpNames :<|> mpCapitalize alice :<|> mpComplex + where mpNames (_:name2:_) _ = return alice { name = name2 } + mpNames _ _ = return alice + + mpCapitalize p False = return p + mpCapitalize p True = return p { name = map toUpper (name p) } + + matrixParamServer (Just name) = return alice{name = name} + matrixParamServer Nothing = return alice + + mpAge age p = return p { age = age } + mpComplex capture name cap = matrixParamServer name >>= flip mpCapitalize cap >>= mpAge capture + +matrixParamSpec :: Spec +matrixParamSpec = do + describe "Servant.API.MatrixParam" $ do + it "allows to retrieve simple matrix parameters" $ + (flip runSession) (serve matrixParamApi mpServer) $ do + response1 <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["a;name=bob"] + } + liftIO $ do + decode' (simpleBody response1) `shouldBe` Just alice{ + name = "bob" + } + + it "allows to retrieve lists in matrix parameters" $ + (flip runSession) (serve matrixParamApi mpServer) $ do + response2 <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["b;names=bob;names=john", "bsub;names=anna;names=sarah"] + } + liftIO $ + decode' (simpleBody response2) `shouldBe` Just alice{ + name = "john" + } + + it "allows to retrieve value-less matrix parameters" $ + (flip runSession) (serve matrixParamApi mpServer) $ do + response3 <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["c;capitalize"] + } + liftIO $ + decode' (simpleBody response3) `shouldBe` Just alice{ + name = "ALICE" + } + + response3' <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["c;capitalize="] + } + liftIO $ + decode' (simpleBody response3') `shouldBe` Just alice{ + name = "ALICE" + } + + it "allows to retrieve matrix parameters on captured segments" $ + (flip runSession) (serve matrixParamApi mpServer) $ do + response4 <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["d", "12;name=stephen;capitalize", "dsub"] + } + liftIO $ + decode' (simpleBody response4) `shouldBe` Just alice{ + name = "STEPHEN", + age = 12 + } + + response4' <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["d;ignored=1", "5", "dsub"] + } + liftIO $ + decode' (simpleBody response4') `shouldBe` Just alice{ + name = "Alice", + age = 5 + } + type PostApi = ReqBody Person :> Post Integer :<|> "bla" :> ReqBody Person :> Post Integer From 294eb3b76f516b70f173227c81150dad5f6c8f85 Mon Sep 17 00:00:00 2001 From: Daniel Larsson Date: Thu, 15 Jan 2015 12:14:11 +0100 Subject: [PATCH 17/52] Added changelog text --- CHANGELOG.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 354d0927..6827d2a1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +master +------ + +* Added support for matrix parameters, see e.g. http://www.w3.org/DesignIssues/MatrixURIs.html + 0.2.3 ----- From 1148e2137757449623760d0cf813fb441978d90d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Fri, 16 Jan 2015 12:52:11 +0800 Subject: [PATCH 18/52] cabal: added lower bound for wai-app-static Fixes #1. --- servant-server.cabal | 2 +- test/Servant/Utils/StaticFilesSpec.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-server.cabal b/servant-server.cabal index 5cb01ef0..a82eccff 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -49,7 +49,7 @@ library , text , transformers , wai - , wai-app-static + , wai-app-static >= 3.0.0.6 , warp hs-source-dirs: src default-language: Haskell2010 diff --git a/test/Servant/Utils/StaticFilesSpec.hs b/test/Servant/Utils/StaticFilesSpec.hs index de7b9e3c..6918448f 100644 --- a/test/Servant/Utils/StaticFilesSpec.hs +++ b/test/Servant/Utils/StaticFilesSpec.hs @@ -61,4 +61,4 @@ spec = do get "/static/foo.txt" `shouldRespondWith` "bar" it "serves the contents of index.html when requesting the root of a directory" $ do - get "/static" `shouldRespondWith` "index" + get "/static/" `shouldRespondWith` "index" From 7736339328d00723e7580df5a179ed660e5a77be Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 15 Jan 2015 12:51:44 +0100 Subject: [PATCH 19/52] Make travis clone master servant. --- .travis.yml | 33 +++++++++++++++++++++++++++++++-- 1 file changed, 31 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index b1f3666c..e226e33e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,8 +1,37 @@ language: haskell -ghc: - - 7.8 +env: +- GHCVER=7.8.3 +before_install: + - | + if [ $GHCVER = `ghc --numeric-version` ]; then + travis/cabal-apt-install --enable-tests $MODE + export CABAL=cabal + else + travis_retry sudo add-apt-repository -y ppa:hvr/ghc + travis_retry sudo apt-get update + travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy + export CABAL=cabal-1.18 + export PATH=/opt/ghc/$GHCVER/bin:$PATH + fi + - $CABAL update + - | + if [ $GHCVER = "head" ] || [ $GHCVER = "7.8.3" ]; then + $CABAL install happy alex + export PATH=$HOME/.cabal/bin:$PATH + fi + - git clone https://github.com/haskell-servant/servant.git + - cabal sandbox init + - cabal sandbox add-source servant + +install: + - cabal install --only-dependencies --enable-tests + +script: + - cabal configure --enable-tests + - cabal build && cabal test + - cabal sdist notifications: irc: channels: From 56791952b8a343ae0bd83208455f39af95429685 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 19 Jan 2015 19:12:08 -0800 Subject: [PATCH 20/52] Return JSON error messages in response --- src/Servant/Server/Internal.hs | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 621a2be8..04baf856 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, decode') +import Data.Aeson (ToJSON, FromJSON, encode, eitherDecode') import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.IORef (newIORef, readIORef, writeIORef) @@ -64,34 +64,34 @@ toApplication ra request respond = do respond $ responseLBS notFound404 [] "not found" routingRespond (Left WrongMethod) = respond $ responseLBS methodNotAllowed405 [] "method not allowed" - routingRespond (Left InvalidBody) = - respond $ responseLBS badRequest400 [] "Invalid JSON in request body" + routingRespond (Left (InvalidBody err)) = + respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err routingRespond (Right response) = respond response -- * Route mismatch data RouteMismatch = - NotFound -- ^ the usual "not found" error - | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error - | InvalidBody -- ^ an even more informative "your json request body wasn't valid" error + NotFound -- ^ the usual "not found" error + | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error + | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error deriving (Eq, Show) -- | -- @ -- > mempty = NotFound -- > --- > NotFound `mappend` x = x --- > WrongMethod `mappend` InvalidBody = InvalidBody --- > WrongMethod `mappend` _ = WrongMethod --- > InvalidBody `mappend` _ = InvalidBody +-- > NotFound `mappend` x = x +-- > WrongMethod `mappend` InvalidBody s = InvalidBody s +-- > WrongMethod `mappend` _ = WrongMethod +-- > InvalidBody s `mappend` _ = InvalidBody s -- @ instance Monoid RouteMismatch where mempty = NotFound - NotFound `mappend` x = x - WrongMethod `mappend` InvalidBody = InvalidBody - WrongMethod `mappend` _ = WrongMethod - InvalidBody `mappend` _ = InvalidBody + 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 = @@ -621,10 +621,10 @@ instance (FromJSON a, HasServer sublayout) a -> Server sublayout route Proxy subserver request respond = do - mrqbody <- decode' <$> lazyRequestBody request + mrqbody <- eitherDecode' <$> lazyRequestBody request case mrqbody of - Nothing -> respond $ failWith InvalidBody - Just v -> route (Proxy :: Proxy sublayout) (subserver v) request respond + Left e -> respond . failWith $ InvalidBody e + 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@. From 6b55bf583d1fce3495dafc598cab9c96489988d9 Mon Sep 17 00:00:00 2001 From: Thomas Sutton Date: Fri, 30 Jan 2015 11:36:01 +1100 Subject: [PATCH 21/52] Add RouteMismatch constructor for arbitrary HTTP response code --- src/Servant/Server/Internal.hs | 9 +++++- test/Servant/ServerSpec.hs | 50 +++++++++++++++++++++++++++++++++- 2 files changed, 57 insertions(+), 2 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 04baf856..1abda7d0 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -14,7 +14,7 @@ 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) +import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid (Monoid, mempty, mappend) import Data.Proxy (Proxy(Proxy)) import Data.String (fromString) @@ -66,6 +66,8 @@ 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 (HttpError status body)) = + respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body routingRespond (Right response) = respond response @@ -74,12 +76,15 @@ data RouteMismatch = NotFound -- ^ the usual "not found" error | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" 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. deriving (Eq, 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 @@ -88,6 +93,8 @@ data RouteMismatch = instance Monoid RouteMismatch where 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 diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 56e98d94..ee3a8d22 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -11,11 +11,12 @@ module Servant.ServerSpec where import Control.Monad.Trans.Either (EitherT, left) import Data.Aeson (ToJSON, FromJSON, encode, decode') import Data.Char (toUpper) +import Data.Monoid ((<>)) import Data.Proxy (Proxy(Proxy)) import Data.String (fromString) import Data.String.Conversions (cs) import GHC.Generics (Generic) -import Network.HTTP.Types (parseQuery, ok200) +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 Test.Hspec (Spec, describe, it, shouldBe) @@ -31,6 +32,7 @@ import Servant.API.Raw (Raw) import Servant.API.Sub ((:>)) import Servant.API.Alternative ((:<|>)((:<|>))) import Servant.Server (Server, serve) +import Servant.Server.Internal (RouteMismatch(..)) -- * test data types @@ -74,6 +76,7 @@ spec = do postSpec rawSpec unionSpec + errorsSpec type CaptureApi = Capture "legs" Integer :> Get Animal @@ -364,3 +367,48 @@ unionSpec = do liftIO $ do decode' (simpleBody response_) `shouldBe` Just jerry + +-- | Test server error functionality. +errorsSpec :: Spec +errorsSpec = do + let he = HttpError status409 (Just "A custom error") + 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 + wm <> he `shouldBe` he + nf <> he `shouldBe` he + + he <> ib `shouldBe` he + he <> wm `shouldBe` he + he <> nf `shouldBe` he + + it "HE > InvalidBody > (WM,NF)" $ do + he <> ib `shouldBe` he + wm <> ib `shouldBe` ib + nf <> ib `shouldBe` ib + + ib <> he `shouldBe` he + ib <> wm `shouldBe` ib + ib <> nf `shouldBe` ib + + it "HE > IB > WrongMethod > NF" $ do + he <> wm `shouldBe` he + ib <> wm `shouldBe` ib + nf <> wm `shouldBe` wm + + wm <> he `shouldBe` he + wm <> ib `shouldBe` ib + wm <> nf `shouldBe` wm + + it "* > NotFound" $ do + he <> nf `shouldBe` he + ib <> nf `shouldBe` ib + wm <> nf `shouldBe` wm + + nf <> he `shouldBe` he + nf <> ib `shouldBe` ib + nf <> wm `shouldBe` wm From 9a3c268be48ba557c16a77e6ba66c240a9a9fe8e Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Tue, 10 Feb 2015 11:33:41 +1100 Subject: [PATCH 22/52] Add PATCH method --- src/Servant/Server/Internal.hs | 31 +++++++++++++++++++++++++++++-- 1 file changed, 29 insertions(+), 2 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 1abda7d0..4bd0a08b 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -16,18 +16,18 @@ import Data.IORef (newIORef, readIORef, writeIORef) import Data.List (unfoldr) import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid (Monoid, mempty, mappend) -import Data.Proxy (Proxy(Proxy)) 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.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, MatrixParams, MatrixParam, MatrixFlag, ReqBody, Header, Capture, Get, Delete, Put, Post, Raw, (:>), (:<|>)(..)) +import Servant.API (QueryParams, QueryParam, QueryFlag, MatrixParams, MatrixParam, MatrixFlag, ReqBody, Header, Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..)) import Servant.Common.Text (FromText, fromText) data ReqBodyState = Uncalled @@ -363,6 +363,33 @@ instance ToJSON a => HasServer (Put a) where | otherwise = respond $ failWith NotFound +-- | When implementing the handler for a 'Patch' endpoint, +-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' +-- and 'Servant.API.Put.Put', the handler code runs in the +-- @EitherT (Int, String) IO@ monad, where the 'Int' represents +-- the status code and the 'String' a message, returned in case of +-- 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 (Typeable a, ToJSON a) => HasServer (Patch a) where + type Server (Patch 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) + Just () -> responseLBS status204 [] "" + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | pathIsEmpty request && requestMethod request /= methodPost = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound + -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @'Maybe' 'Text'@. From 578bda35d99b6e3f3d4927347dde1705316852c2 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 18 Feb 2015 13:21:37 +0100 Subject: [PATCH 23/52] Use hackage docs. --- README.md | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index 448f82e1..8f7dc47a 100644 --- a/README.md +++ b/README.md @@ -12,7 +12,8 @@ We've written a [Getting Started](http://haskell-servant.github.io/getting-start ## Repositories and Haddocks -- The core [servant](http://github.com/haskell-servant) package - [docs](http://haskell-servant.github.io/servant/) -- (Haskell) client-side function generation with [servant-client](http://github.com/haskell-servant/servant-client) - [docs](http://haskell-servant.github.io/servant-client/) -- (Javascript) client-side function generation with [servant-jquery](http://github.com/haskell-servant/servant-jquery) - [docs](http://haskell-servant.github.io/servant-jquery/) -- API docs generation with [servant-docs](http://github.com/haskell-servant/servant-docs) - [docs](http://haskell-servant.github.io/servant-docs/) +- The core [servant](http://github.com/haskell-servant) package - [docs](http://hackage.haskell.org/package/servant) +- Implementing an HTTP server for a webservice API with [servant-server](http://github.com/haskell-servant/servant-server) - [docs](http://hackage.haskell.org/package/servant-server) +- (Haskell) client-side function generation with [servant-client](http://github.com/haskell-servant/servant-client) - [docs](http://hackage.haskell.org/package/servant-client) +- (Javascript) client-side function generation with [servant-jquery](http://github.com/haskell-servant/servant-jquery) - [docs](http://hackage.haskell.org/package/servant-jquery) +- API docs generation with [servant-docs](http://github.com/haskell-servant/servant-docs) - [docs](http://hackage.haskell.org/package/servant-docs) From b5f2032f77ea6fab2a91dcfe4785b2213a2332e3 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 19 Feb 2015 20:45:42 +0100 Subject: [PATCH 24/52] Enable coveralls --- .travis.yml | 7 ++++++- README.md | 1 + 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index e226e33e..fc80d487 100644 --- a/.travis.yml +++ b/.travis.yml @@ -29,9 +29,14 @@ install: - cabal install --only-dependencies --enable-tests script: - - cabal configure --enable-tests + - cabal configure --enable-tests --enable-library-coverage - cabal build && cabal test - cabal sdist + +after_script: + - cabal install hpc-coveralls + - hpc-coveralls --exclude-dir=test spec + notifications: irc: channels: diff --git a/README.md b/README.md index 8f7dc47a..e998f1a9 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,7 @@ # servant-server [![Build Status](https://secure.travis-ci.org/haskell-servant/servant-server.svg)](http://travis-ci.org/haskell-servant/servant-server) +[![Coverage Status](https://coveralls.io/repos/haskell-servant/servant-server/badge.svg)](https://coveralls.io/r/haskell-servant/servant-server) ![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) From c1377e0a73aa486d332e0bdf866501714bd6ea4b Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 19 Feb 2015 23:02:29 +0100 Subject: [PATCH 25/52] Add cabal sandbox to travis path --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index fc80d487..b6a1f304 100644 --- a/.travis.yml +++ b/.travis.yml @@ -35,6 +35,7 @@ script: after_script: - cabal install hpc-coveralls + - export PATH=.cabal-sandbox/bin:$PATH - hpc-coveralls --exclude-dir=test spec notifications: From 380acb3efa5e0162fd87519abae893fc67da3244 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 12 Jan 2015 15:08:41 +0100 Subject: [PATCH 26/52] Add Accept header handling. --- default.nix | 15 +++ servant-server.cabal | 2 + src/Servant/Server/ContentTypes.hs | 114 +++++++++++++++++++++ src/Servant/Server/Internal.hs | 53 ++++++---- test/Servant/Server/ContentTypesSpec.hs | 129 ++++++++++++++++++++++++ test/Servant/ServerSpec.hs | 19 ++-- test/Servant/Utils/StaticFilesSpec.hs | 3 +- 7 files changed, 308 insertions(+), 27 deletions(-) create mode 100644 default.nix create mode 100644 src/Servant/Server/ContentTypes.hs create mode 100644 test/Servant/Server/ContentTypesSpec.hs 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/servant-server.cabal b/servant-server.cabal index 7da021e7..077f63ea 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -31,6 +31,7 @@ library exposed-modules: Servant Servant.Server + Servant.Server.ContentTypes Servant.Server.Internal Servant.Utils.StaticFiles build-depends: @@ -41,6 +42,7 @@ library , either >= 4.3 , http-types , network-uri >= 2.6 + , http-media == 0.4.* , safe , servant >= 0.2.2 , split diff --git a/src/Servant/Server/ContentTypes.hs b/src/Servant/Server/ContentTypes.hs new file mode 100644 index 00000000..e714421d --- /dev/null +++ b/src/Servant/Server/ContentTypes.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Server.ContentTypes where + +import Data.Aeson (ToJSON(..), encode) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString as BS +import Data.Proxy (Proxy(..)) +import Data.String.Conversions (cs) +import qualified Network.HTTP.Media as M + + +import Servant.API (XML, HTML, JSON, JavaScript, CSS, PlainText) + +-- | Instances of 'Accept' represent mimetypes. They are used for matching +-- against the @Accept@ HTTP header of the request, and for setting the +-- @Content-Type@ header of the response +-- +-- Example: +-- +-- instance Accept HTML where +-- contentType _ = "text" // "html" +-- +class Accept ctype where + contentType :: Proxy ctype -> M.MediaType + +instance Accept HTML where + contentType _ = "text" M.// "html" + +instance Accept JSON where + contentType _ = "application" M.// "json" + +instance Accept XML where + contentType _ = "application" M.// "xml" + +instance Accept JavaScript where + contentType _ = "application" M.// "javascript" + +instance Accept CSS where + contentType _ = "text" M.// "css" + +instance Accept PlainText where + contentType _ = "text" M.// "plain" + +newtype AcceptHeader = AcceptHeader BS.ByteString + deriving (Eq, Show) + +-- | Instantiate this class to register a way of serializing a type based +-- on the @Accept@ header. +class Accept ctype => MimeRender ctype a where + toByteString :: Proxy ctype -> a -> ByteString + +class AllCTRender list a where + -- If the Accept header can be matched, returns (Just) a tuple of the + -- Content-Type and response (serialization of @a@ into the appropriate + -- mimetype). + handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) + +instance ( AllMimeRender ctyps a, IsEmpty ctyps ~ 'False + ) => AllCTRender ctyps a where + handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept + where pctyps = Proxy :: Proxy ctyps + amrs = amr pctyps val + lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs + + +-------------------------------------------------------------------------- +-- Check that all elements of list are instances of MimeRender +-------------------------------------------------------------------------- +class AllMimeRender ls a where + amr :: Proxy ls -> a -> [(M.MediaType, ByteString)] -- list of content-types/response pairs + +instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where + amr _ a = [(contentType pctyp, toByteString pctyp a)] + where pctyp = Proxy :: Proxy ctyp + +instance ( MimeRender ctyp a + , MimeRender ctyp' a + , AllMimeRender ctyps a + ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where + amr _ a = (contentType pctyp, toByteString pctyp a) + :(contentType pctyp', toByteString pctyp' a) + :(amr pctyps a) + where pctyp = Proxy :: Proxy ctyp + pctyps = Proxy :: Proxy ctyps + pctyp' = Proxy :: Proxy ctyp' + + +instance AllMimeRender '[] a where + amr _ _ = [] + +type family IsEmpty (ls::[*]) where + IsEmpty '[] = 'True + IsEmpty x = 'False + +-------------------------------------------------------------------------- +-- MimeRender Instances +-------------------------------------------------------------------------- + +instance ToJSON a => MimeRender JSON a where + toByteString _ = encode + +instance Show a => MimeRender PlainText a where + toByteString _ = encode . show + +instance MimeRender PlainText String where + toByteString _ = encode diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 4bd0a08b..033129b4 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -24,10 +24,14 @@ 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.Server.ContentTypes (AllCTRender(..), AcceptHeader(..)) import Servant.Common.Text (FromText, fromText) data ReqBodyState = Uncalled @@ -225,7 +229,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 @@ -264,14 +268,19 @@ instance HasServer Delete 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 200 along the way. -instance ToJSON result => HasServer (Get result) where - type Server (Get result) = EitherT (Int, String) IO result +instance ( AllCTRender ctypes a, ToJSON 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 "") [] "" + 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 = @@ -321,15 +330,20 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) -- 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 +instance ( AllCTRender ctypes a, ToJSON 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 = @@ -347,15 +361,20 @@ instance ToJSON a => HasServer (Post 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 200 along the way. -instance ToJSON a => HasServer (Put a) where - type Server (Put a) = EitherT (Int, String) IO a +instance ( AllCTRender ctypes a, ToJSON 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 = @@ -382,7 +401,7 @@ instance (Typeable a, ToJSON a) => HasServer (Patch a) where e <- runEitherT action respond . succeedWith $ case e of Right out -> case cast out of - Nothing -> responseLBS status200 [("Content-Type", "application/json")] (encode out) + Nothing -> responseLBS status200 [("Content-Type", "application/json")] (encode out) Just () -> responseLBS status204 [] "" Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) diff --git a/test/Servant/Server/ContentTypesSpec.hs b/test/Servant/Server/ContentTypesSpec.hs new file mode 100644 index 00000000..8d725f18 --- /dev/null +++ b/test/Servant/Server/ContentTypesSpec.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Servant.Server.ContentTypesSpec where + +import Control.Applicative +import Data.Aeson (encode) +import Data.ByteString.Char8 +import Data.Function (on) +import Data.Maybe (isJust, fromJust) +import Data.List (maximumBy) +import Data.Proxy (Proxy(..)) +import Data.String (IsString(..)) +import Data.String.Conversions (cs) +import Network.HTTP.Types (hAccept) +import Network.Wai (pathInfo, requestHeaders) +import Network.Wai.Test ( runSession, request, defaultRequest + , assertContentType, assertStatus ) +import Test.Hspec +import Test.QuickCheck + +import Servant.API +import Servant.Server +import Servant.Server.ContentTypes + + +spec :: Spec +spec = describe "Servant.Server.ContentTypes" $ do + handleAcceptHSpec + contentTypeSpec + +handleAcceptHSpec :: Spec +handleAcceptHSpec = describe "handleAcceptH" $ do + + it "should return Just if the 'Accept' header matches" $ do + handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) + `shouldSatisfy` isJust + handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int) + `shouldSatisfy` isJust + handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int) + `shouldSatisfy` isJust + + it "should return the Content-Type as the first element of the tuple" $ do + handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) + `shouldSatisfy` ((== "application/json") . fst . fromJust) + handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int) + `shouldSatisfy` ((== "application/json") . fst . fromJust) + handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int) + `shouldSatisfy` ((== "text/html") . fst . fromJust) + + it "should return the appropriately serialized representation" $ do + property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: Int) + == Just ("application/json", encode x) + + it "respects the Accept spec ordering" $ + property $ \a b c i -> fst (fromJust $ val a b c i) == (fst $ highest a b c) + where + highest a b c = maximumBy (compare `on` snd) [ ("text/html", a) + , ("application/json", b) + , ("application/xml", c) + ] + acceptH a b c = addToAccept (Proxy :: Proxy HTML) a $ + addToAccept (Proxy :: Proxy JSON) b $ + addToAccept (Proxy :: Proxy XML ) c "" + val a b c i = handleAcceptH (Proxy :: Proxy '[HTML, JSON, XML]) + (acceptH a b c) (i :: Int) + +type ContentTypeApi = "foo" :> Get '[JSON] Int + :<|> "bar" :> Get '[JSON, PlainText] Int + +contentTypeApi :: Proxy ContentTypeApi +contentTypeApi = Proxy + +contentTypeServer :: Server ContentTypeApi +contentTypeServer = return 5 :<|> return 3 + +contentTypeSpec :: Spec +contentTypeSpec = do + describe "Accept Headers" $ do + + it "uses the highest quality possible in the header" $ + flip runSession (serve contentTypeApi contentTypeServer) $ do + let acceptH = "text/plain; q=0.9, application/json; q=0.8" + response <- Network.Wai.Test.request defaultRequest{ + requestHeaders = [(hAccept, acceptH)] , + pathInfo = ["bar"] + } + assertContentType "text/plain" response + + it "returns the first content-type if the Accept header is missing" $ + flip runSession (serve contentTypeApi contentTypeServer) $ do + response <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["bar"] + } + assertContentType "application/json" response + + it "returns 406 if it can't serve the requested content-type" $ + flip runSession (serve contentTypeApi contentTypeServer) $ do + let acceptH = "text/css" + response <- Network.Wai.Test.request defaultRequest{ + requestHeaders = [(hAccept, acceptH)] , + pathInfo = ["bar"] + } + assertStatus 406 response + + +instance Show a => MimeRender HTML a where + toByteString _ = cs . show + +instance Show a => MimeRender XML a where + toByteString _ = cs . show + +instance IsString AcceptHeader where + fromString = AcceptHeader . fromString + +addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader +addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h) + where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f) + cont "" = new + cont old = old `append` ", " `append` new + +newtype ZeroToOne = ZeroToOne Float + deriving (Eq, Show, Ord) + +instance Arbitrary ZeroToOne where + arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]] diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index ee3a8d22..c173c3ae 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -22,6 +22,7 @@ import Network.Wai.Test (runSession, request, defaultRequest, simpleBody) import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec.Wai (liftIO, with, get, post, shouldRespondWith, matchStatus) +import Servant.API (JSON) import Servant.API.Capture (Capture) import Servant.API.Get (Get) import Servant.API.ReqBody (ReqBody) @@ -79,7 +80,7 @@ spec = do 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 +106,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 +124,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 @@ -289,8 +290,8 @@ matrixParamSpec = do } type PostApi = - ReqBody Person :> Post Integer - :<|> "bla" :> ReqBody Person :> Post Integer + ReqBody Person :> Post '[JSON] Integer + :<|> "bla" :> ReqBody Person :> Post '[JSON] Integer postApi :: Proxy PostApi postApi = Proxy @@ -344,8 +345,8 @@ rawSpec = do type AlternativeApi = - "foo" :> Get Person - :<|> "bar" :> Get Animal + "foo" :> Get '[JSON] Person + :<|> "bar" :> Get '[JSON] Animal unionApi :: Proxy AlternativeApi unionApi = Proxy 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 From 8028cceee72fc2beaff1fda54912c654f41320b1 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 13 Jan 2015 20:40:41 +0100 Subject: [PATCH 27/52] ReqBody content types. --- CHANGELOG.md | 5 ++ example/greet.hs | 6 +- servant-server.cabal | 36 ++++----- src/Servant/Server.hs | 9 ++- src/Servant/Server/ContentTypes.hs | 115 +++++++++++++++++++++++++---- src/Servant/Server/Internal.hs | 71 +++++++++++------- test/Servant/ServerSpec.hs | 28 ++++--- 7 files changed, 195 insertions(+), 75 deletions(-) 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/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 077f63ea..b4b2b3ab 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -35,24 +35,24 @@ 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 - , http-media == 0.4.* - , 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-media >= 0.4 && < 0.5 + , 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/Server.hs b/src/Servant/Server.hs index 3d8156ae..f7ca559e 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -9,12 +9,17 @@ module Servant.Server , -- * Handlers for all standard combinators HasServer(..) + + , -- * Building new Content-Types + Accept(..) + , MimeRender(..) ) where import Data.Proxy (Proxy) import Network.Wai (Application) import Servant.Server.Internal +import Servant.Server.ContentTypes (Accept(..), MimeRender(..)) -- * Implementing Servers @@ -23,8 +28,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/ContentTypes.hs b/src/Servant/Server/ContentTypes.hs index e714421d..5ca8989f 100644 --- a/src/Servant/Server/ContentTypes.hs +++ b/src/Servant/Server/ContentTypes.hs @@ -9,15 +9,21 @@ {-# LANGUAGE UndecidableInstances #-} module Servant.Server.ContentTypes where -import Data.Aeson (ToJSON(..), encode) +import Control.Monad (join) +import Data.Aeson (ToJSON(..), FromJSON(..), encode, decode) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as BS import Data.Proxy (Proxy(..)) import Data.String.Conversions (cs) +import qualified Data.Text.Lazy.Encoding as Text +import qualified Data.Text.Lazy as Text import qualified Network.HTTP.Media as M -import Servant.API (XML, HTML, JSON, JavaScript, CSS, PlainText) +import Servant.API ( XML, HTML, JSON, JavaScript, CSS, PlainText + , OctetStream) + +-- * Accept class -- | Instances of 'Accept' represent mimetypes. They are used for matching -- against the @Accept@ HTTP header of the request, and for setting the @@ -25,35 +31,59 @@ import Servant.API (XML, HTML, JSON, JavaScript, CSS, PlainText) -- -- Example: -- --- instance Accept HTML where --- contentType _ = "text" // "html" +-- > instance Accept HTML where +-- > contentType _ = "text" // "html" -- class Accept ctype where contentType :: Proxy ctype -> M.MediaType +-- | @text/html;charset=utf-8@ instance Accept HTML where contentType _ = "text" M.// "html" +-- | @application/json;charset=utf-8@ instance Accept JSON where - contentType _ = "application" M.// "json" + contentType _ = "application" M.// "json" M./: ("charset", "utf-8") +-- | @application/xml;charset=utf-8@ instance Accept XML where contentType _ = "application" M.// "xml" +-- | @application/javascript;charset=utf-8@ instance Accept JavaScript where contentType _ = "application" M.// "javascript" +-- | @text/css;charset=utf-8@ instance Accept CSS where contentType _ = "text" M.// "css" +-- | @text/plain;charset=utf-8@ instance Accept PlainText where contentType _ = "text" M.// "plain" +-- | @application/octet-stream@ +instance Accept OctetStream where + contentType _ = "application" M.// "octet-stream" + newtype AcceptHeader = AcceptHeader BS.ByteString deriving (Eq, Show) +-- * Render (serializing) + -- | Instantiate this class to register a way of serializing a type based -- on the @Accept@ header. +-- +-- Example: +-- +-- > data MyContentType +-- > +-- > instance Accept MyContentType where +-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8") +-- > +-- > instance Show a => MimeRender MyContentType where +-- > toByteString _ val = pack ("This is MINE! " ++ show val) +-- > +-- > type MyAPI = "path" :> Get '[MyContentType] Int class Accept ctype => MimeRender ctype a where toByteString :: Proxy ctype -> a -> ByteString @@ -71,18 +101,53 @@ instance ( AllMimeRender ctyps a, IsEmpty ctyps ~ 'False lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs + + +-------------------------------------------------------------------------- +-- * MimeRender Instances + +-- | @encode@ +instance ToJSON a => MimeRender JSON a where + toByteString _ = encode + +-- | @encodeUtf8@ +instance MimeRender PlainText Text.Text where + toByteString _ = Text.encodeUtf8 + +-------------------------------------------------------------------------- +-- * Unrender +class Accept ctype => MimeUnrender ctype a where + fromByteString :: Proxy ctype -> ByteString -> Maybe a + +class AllCTUnrender list a where + handleCTypeH :: Proxy list + -> ByteString -- Content-Type header + -> ByteString -- Request body + -> Maybe a + +instance ( AllMimeUnrender ctyps a, IsEmpty ctyps ~ 'False + ) => AllCTUnrender ctyps a where + handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH) + where lkup = amu (Proxy :: Proxy ctyps) body + +-------------------------------------------------------------------------- +-- * Utils (Internal) + + -------------------------------------------------------------------------- -- Check that all elements of list are instances of MimeRender -------------------------------------------------------------------------- class AllMimeRender ls a where - amr :: Proxy ls -> a -> [(M.MediaType, ByteString)] -- list of content-types/response pairs + amr :: Proxy ls + -> a -- value to serialize + -> [(M.MediaType, ByteString)] -- content-types/response pairs instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where amr _ a = [(contentType pctyp, toByteString pctyp a)] where pctyp = Proxy :: Proxy ctyp instance ( MimeRender ctyp a - , MimeRender ctyp' a + , MimeRender ctyp' a -- at least two elems to avoid overlap , AllMimeRender ctyps a ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where amr _ a = (contentType pctyp, toByteString pctyp a) @@ -96,19 +161,39 @@ instance ( MimeRender ctyp a instance AllMimeRender '[] a where amr _ _ = [] +-------------------------------------------------------------------------- +-- Check that all elements of list are instances of MimeUnrender +-------------------------------------------------------------------------- +class AllMimeUnrender ls a where + amu :: Proxy ls -> ByteString -> [(M.MediaType, Maybe a)] + +instance ( MimeUnrender ctyp a ) => AllMimeUnrender '[ctyp] a where + amu _ val = [(contentType pctyp, fromByteString pctyp val)] + where pctyp = Proxy :: Proxy ctyp + +instance ( MimeUnrender ctyp a + , MimeUnrender ctyp' a + , AllMimeUnrender ctyps a + ) => AllMimeUnrender (ctyp ': ctyp' ': ctyps) a where + amu _ val = (contentType pctyp, fromByteString pctyp val) + :(contentType pctyp', fromByteString pctyp' val) + :(amu pctyps val) + where pctyp = Proxy :: Proxy ctyp + pctyps = Proxy :: Proxy ctyps + pctyp' = Proxy :: Proxy ctyp' + type family IsEmpty (ls::[*]) where IsEmpty '[] = 'True IsEmpty x = 'False -------------------------------------------------------------------------- --- MimeRender Instances --------------------------------------------------------------------------- +-- * MimeUnrender Instances -instance ToJSON a => MimeRender JSON a where - toByteString _ = encode +-- | @decode@ +instance FromJSON a => MimeUnrender JSON a where + fromByteString _ = decode -instance Show a => MimeRender PlainText a where - toByteString _ = encode . show +-- | @Text.decodeUtf8'@ +instance MimeUnrender PlainText Text.Text where + fromByteString _ = either (const Nothing) Just . Text.decodeUtf8' -instance MimeRender PlainText String where - toByteString _ = encode diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 033129b4..fe2ee529 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -31,9 +31,11 @@ import Network.Wai ( Response, Request, ResponseReceived, Application import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header , MatrixParams, MatrixParam, MatrixFlag, , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..)) -import Servant.Server.ContentTypes (AllCTRender(..), AcceptHeader(..)) +import Servant.Server.ContentTypes ( AllCTRender(..), AcceptHeader(..) + , AllCTUnrender(..) ) import Servant.Common.Text (FromText, fromText) + data ReqBodyState = Uncalled | Called !B.ByteString | Done !B.ByteString @@ -175,8 +177,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 @@ -207,7 +209,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 @@ -265,10 +267,12 @@ 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 ( AllCTRender ctypes a, ToJSON 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 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 @@ -301,7 +305,7 @@ instance ( AllCTRender ctypes a, ToJSON a -- > 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 @@ -327,11 +331,13 @@ 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 ( AllCTRender ctypes a, ToJSON a - )=> HasServer (Post ctypes a) where +-- 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 @@ -358,10 +364,12 @@ instance ( AllCTRender ctypes a, ToJSON a -- 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 ( AllCTRender ctypes a, ToJSON 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 @@ -423,7 +431,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 @@ -462,7 +470,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 @@ -495,7 +503,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 @@ -654,27 +662,38 @@ 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 diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index c173c3ae..7982e29c 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -16,11 +16,13 @@ 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, 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 (JSON) import Servant.API.Capture (Capture) @@ -171,6 +173,7 @@ queryParamSpec = do name = "john" } + it "allows to retrieve value-less GET parameters" $ (flip runSession) (serve queryParamApi qpServer) $ do let params3 = "?capitalize" @@ -290,8 +293,8 @@ matrixParamSpec = do } type PostApi = - ReqBody Person :> Post '[JSON] Integer - :<|> "bla" :> ReqBody Person :> Post '[JSON] Integer + ReqBody '[JSON] Person :> Post '[JSON] Integer + :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer postApi :: Proxy PostApi postApi = Proxy @@ -299,23 +302,26 @@ 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")] + 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 type RawApi = "foo" :> Raw @@ -376,7 +382,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 From 2092ddc20142ca03575fcb8f603932f871206349 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 13 Jan 2015 22:40:41 +0100 Subject: [PATCH 28/52] Charset test fixes. --- src/Servant/Server/ContentTypes.hs | 22 ++++++++++++---------- test/Servant/Server/ContentTypesSpec.hs | 23 ++++++++++++----------- test/Servant/ServerSpec.hs | 2 +- 3 files changed, 25 insertions(+), 22 deletions(-) diff --git a/src/Servant/Server/ContentTypes.hs b/src/Servant/Server/ContentTypes.hs index 5ca8989f..b32ae124 100644 --- a/src/Servant/Server/ContentTypes.hs +++ b/src/Servant/Server/ContentTypes.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -17,6 +18,7 @@ import Data.Proxy (Proxy(..)) import Data.String.Conversions (cs) import qualified Data.Text.Lazy.Encoding as Text import qualified Data.Text.Lazy as Text +import GHC.Exts (Constraint) import qualified Network.HTTP.Media as M @@ -39,7 +41,7 @@ class Accept ctype where -- | @text/html;charset=utf-8@ instance Accept HTML where - contentType _ = "text" M.// "html" + contentType _ = "text" M.// "html" M./: ("charset", "utf-8") -- | @application/json;charset=utf-8@ instance Accept JSON where @@ -47,19 +49,19 @@ instance Accept JSON where -- | @application/xml;charset=utf-8@ instance Accept XML where - contentType _ = "application" M.// "xml" + contentType _ = "application" M.// "xml" M./: ("charset", "utf-8") -- | @application/javascript;charset=utf-8@ instance Accept JavaScript where - contentType _ = "application" M.// "javascript" + contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8") -- | @text/css;charset=utf-8@ instance Accept CSS where - contentType _ = "text" M.// "css" + contentType _ = "text" M.// "css" M./: ("charset", "utf-8") -- | @text/plain;charset=utf-8@ instance Accept PlainText where - contentType _ = "text" M.// "plain" + contentType _ = "text" M.// "plain" M./: ("charset", "utf-8") -- | @application/octet-stream@ instance Accept OctetStream where @@ -93,7 +95,7 @@ class AllCTRender list a where -- mimetype). handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) -instance ( AllMimeRender ctyps a, IsEmpty ctyps ~ 'False +instance ( AllMimeRender ctyps a, IsNonEmpty ctyps ) => AllCTRender ctyps a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept where pctyps = Proxy :: Proxy ctyps @@ -125,7 +127,7 @@ class AllCTUnrender list a where -> ByteString -- Request body -> Maybe a -instance ( AllMimeUnrender ctyps a, IsEmpty ctyps ~ 'False +instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps ) => AllCTUnrender ctyps a where handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH) where lkup = amu (Proxy :: Proxy ctyps) body @@ -182,9 +184,9 @@ instance ( MimeUnrender ctyp a pctyps = Proxy :: Proxy ctyps pctyp' = Proxy :: Proxy ctyp' -type family IsEmpty (ls::[*]) where - IsEmpty '[] = 'True - IsEmpty x = 'False +type family IsNonEmpty (ls::[*]) :: Constraint where + IsNonEmpty '[] = 'False ~ 'True + IsNonEmpty x = () -------------------------------------------------------------------------- -- * MimeUnrender Instances diff --git a/test/Servant/Server/ContentTypesSpec.hs b/test/Servant/Server/ContentTypesSpec.hs index 8d725f18..657f8860 100644 --- a/test/Servant/Server/ContentTypesSpec.hs +++ b/test/Servant/Server/ContentTypesSpec.hs @@ -13,6 +13,7 @@ import Data.Function (on) import Data.Maybe (isJust, fromJust) import Data.List (maximumBy) import Data.Proxy (Proxy(..)) +import qualified Data.Text.Lazy as T import Data.String (IsString(..)) import Data.String.Conversions (cs) import Network.HTTP.Types (hAccept) @@ -45,22 +46,22 @@ handleAcceptHSpec = describe "handleAcceptH" $ do it "should return the Content-Type as the first element of the tuple" $ do handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) - `shouldSatisfy` ((== "application/json") . fst . fromJust) + `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int) - `shouldSatisfy` ((== "application/json") . fst . fromJust) + `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int) - `shouldSatisfy` ((== "text/html") . fst . fromJust) + `shouldSatisfy` ((== "text/html;charset=utf-8") . fst . fromJust) it "should return the appropriately serialized representation" $ do property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: Int) - == Just ("application/json", encode x) + == Just ("application/json;charset=utf-8", encode x) it "respects the Accept spec ordering" $ property $ \a b c i -> fst (fromJust $ val a b c i) == (fst $ highest a b c) where - highest a b c = maximumBy (compare `on` snd) [ ("text/html", a) - , ("application/json", b) - , ("application/xml", c) + highest a b c = maximumBy (compare `on` snd) [ ("text/html;charset=utf-8", a) + , ("application/json;charset=utf-8", b) + , ("application/xml;charset=utf-8", c) ] acceptH a b c = addToAccept (Proxy :: Proxy HTML) a $ addToAccept (Proxy :: Proxy JSON) b $ @@ -69,13 +70,13 @@ handleAcceptHSpec = describe "handleAcceptH" $ do (acceptH a b c) (i :: Int) type ContentTypeApi = "foo" :> Get '[JSON] Int - :<|> "bar" :> Get '[JSON, PlainText] Int + :<|> "bar" :> Get '[JSON, PlainText] T.Text contentTypeApi :: Proxy ContentTypeApi contentTypeApi = Proxy contentTypeServer :: Server ContentTypeApi -contentTypeServer = return 5 :<|> return 3 +contentTypeServer = return 5 :<|> return "hi" contentTypeSpec :: Spec contentTypeSpec = do @@ -88,14 +89,14 @@ contentTypeSpec = do requestHeaders = [(hAccept, acceptH)] , pathInfo = ["bar"] } - assertContentType "text/plain" response + assertContentType "text/plain;charset=utf8" response it "returns the first content-type if the Accept header is missing" $ flip runSession (serve contentTypeApi contentTypeServer) $ do response <- Network.Wai.Test.request defaultRequest{ pathInfo = ["bar"] } - assertContentType "application/json" response + assertContentType "application/json;charset=utf8" response it "returns 406 if it can't serve the requested content-type" $ flip runSession (serve contentTypeApi contentTypeServer) $ do diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 7982e29c..2d82037e 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -303,7 +303,7 @@ 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")] + , "application/json;charset=utf-8")] it "allows to POST a Person" $ do post' "/" (encode alice) `shouldRespondWith` "42"{ From e9f3341b9e4e08116f5fb4396ed2cc3c7130adc7 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 19 Feb 2015 19:18:43 +0100 Subject: [PATCH 29/52] Move more Content-type logic back to servant. --- src/Servant/Server.hs | 5 +- src/Servant/Server/ContentTypes.hs | 160 +----------------------- src/Servant/Server/Internal.hs | 56 +++++---- test/Servant/Server/ContentTypesSpec.hs | 3 +- test/Servant/ServerSpec.hs | 13 +- 5 files changed, 46 insertions(+), 191 deletions(-) diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index f7ca559e..2495022e 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -10,16 +10,13 @@ module Servant.Server , -- * Handlers for all standard combinators HasServer(..) - , -- * Building new Content-Types - Accept(..) - , MimeRender(..) ) where import Data.Proxy (Proxy) import Network.Wai (Application) import Servant.Server.Internal -import Servant.Server.ContentTypes (Accept(..), MimeRender(..)) +import Servant.Server.ContentTypes () -- * Implementing Servers diff --git a/src/Servant/Server/ContentTypes.hs b/src/Servant/Server/ContentTypes.hs index b32ae124..8557dc3c 100644 --- a/src/Servant/Server/ContentTypes.hs +++ b/src/Servant/Server/ContentTypes.hs @@ -11,7 +11,8 @@ module Servant.Server.ContentTypes where import Control.Monad (join) -import Data.Aeson (ToJSON(..), FromJSON(..), encode, decode) +import Control.Arrow (left) +import Data.Aeson (ToJSON(..), FromJSON(..), encode, eitherDecode) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as BS import Data.Proxy (Proxy(..)) @@ -23,86 +24,7 @@ import qualified Network.HTTP.Media as M import Servant.API ( XML, HTML, JSON, JavaScript, CSS, PlainText - , OctetStream) - --- * Accept class - --- | Instances of 'Accept' represent mimetypes. They are used for matching --- against the @Accept@ HTTP header of the request, and for setting the --- @Content-Type@ header of the response --- --- Example: --- --- > instance Accept HTML where --- > contentType _ = "text" // "html" --- -class Accept ctype where - contentType :: Proxy ctype -> M.MediaType - --- | @text/html;charset=utf-8@ -instance Accept HTML where - contentType _ = "text" M.// "html" M./: ("charset", "utf-8") - --- | @application/json;charset=utf-8@ -instance Accept JSON where - contentType _ = "application" M.// "json" M./: ("charset", "utf-8") - --- | @application/xml;charset=utf-8@ -instance Accept XML where - contentType _ = "application" M.// "xml" M./: ("charset", "utf-8") - --- | @application/javascript;charset=utf-8@ -instance Accept JavaScript where - contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8") - --- | @text/css;charset=utf-8@ -instance Accept CSS where - contentType _ = "text" M.// "css" M./: ("charset", "utf-8") - --- | @text/plain;charset=utf-8@ -instance Accept PlainText where - contentType _ = "text" M.// "plain" M./: ("charset", "utf-8") - --- | @application/octet-stream@ -instance Accept OctetStream where - contentType _ = "application" M.// "octet-stream" - -newtype AcceptHeader = AcceptHeader BS.ByteString - deriving (Eq, Show) - --- * Render (serializing) - --- | Instantiate this class to register a way of serializing a type based --- on the @Accept@ header. --- --- Example: --- --- > data MyContentType --- > --- > instance Accept MyContentType where --- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8") --- > --- > instance Show a => MimeRender MyContentType where --- > toByteString _ val = pack ("This is MINE! " ++ show val) --- > --- > type MyAPI = "path" :> Get '[MyContentType] Int -class Accept ctype => MimeRender ctype a where - toByteString :: Proxy ctype -> a -> ByteString - -class AllCTRender list a where - -- If the Accept header can be matched, returns (Just) a tuple of the - -- Content-Type and response (serialization of @a@ into the appropriate - -- mimetype). - handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) - -instance ( AllMimeRender ctyps a, IsNonEmpty ctyps - ) => AllCTRender ctyps a where - handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept - where pctyps = Proxy :: Proxy ctyps - amrs = amr pctyps val - lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs - - + , OctetStream, MimeRender(..), MimeUnrender(..) ) -------------------------------------------------------------------------- @@ -116,86 +38,14 @@ instance ToJSON a => MimeRender JSON a where instance MimeRender PlainText Text.Text where toByteString _ = Text.encodeUtf8 --------------------------------------------------------------------------- --- * Unrender -class Accept ctype => MimeUnrender ctype a where - fromByteString :: Proxy ctype -> ByteString -> Maybe a - -class AllCTUnrender list a where - handleCTypeH :: Proxy list - -> ByteString -- Content-Type header - -> ByteString -- Request body - -> Maybe a - -instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps - ) => AllCTUnrender ctyps a where - handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH) - where lkup = amu (Proxy :: Proxy ctyps) body - --------------------------------------------------------------------------- --- * Utils (Internal) - - --------------------------------------------------------------------------- --- Check that all elements of list are instances of MimeRender --------------------------------------------------------------------------- -class AllMimeRender ls a where - amr :: Proxy ls - -> a -- value to serialize - -> [(M.MediaType, ByteString)] -- content-types/response pairs - -instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where - amr _ a = [(contentType pctyp, toByteString pctyp a)] - where pctyp = Proxy :: Proxy ctyp - -instance ( MimeRender ctyp a - , MimeRender ctyp' a -- at least two elems to avoid overlap - , AllMimeRender ctyps a - ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where - amr _ a = (contentType pctyp, toByteString pctyp a) - :(contentType pctyp', toByteString pctyp' a) - :(amr pctyps a) - where pctyp = Proxy :: Proxy ctyp - pctyps = Proxy :: Proxy ctyps - pctyp' = Proxy :: Proxy ctyp' - - -instance AllMimeRender '[] a where - amr _ _ = [] - --------------------------------------------------------------------------- --- Check that all elements of list are instances of MimeUnrender --------------------------------------------------------------------------- -class AllMimeUnrender ls a where - amu :: Proxy ls -> ByteString -> [(M.MediaType, Maybe a)] - -instance ( MimeUnrender ctyp a ) => AllMimeUnrender '[ctyp] a where - amu _ val = [(contentType pctyp, fromByteString pctyp val)] - where pctyp = Proxy :: Proxy ctyp - -instance ( MimeUnrender ctyp a - , MimeUnrender ctyp' a - , AllMimeUnrender ctyps a - ) => AllMimeUnrender (ctyp ': ctyp' ': ctyps) a where - amu _ val = (contentType pctyp, fromByteString pctyp val) - :(contentType pctyp', fromByteString pctyp' val) - :(amu pctyps val) - where pctyp = Proxy :: Proxy ctyp - pctyps = Proxy :: Proxy ctyps - pctyp' = Proxy :: Proxy ctyp' - -type family IsNonEmpty (ls::[*]) :: Constraint where - IsNonEmpty '[] = 'False ~ 'True - IsNonEmpty x = () - -------------------------------------------------------------------------- -- * MimeUnrender Instances -- | @decode@ instance FromJSON a => MimeUnrender JSON a where - fromByteString _ = decode + fromByteString _ = eitherDecode -- | @Text.decodeUtf8'@ instance MimeUnrender PlainText Text.Text where - fromByteString _ = either (const Nothing) Just . Text.decodeUtf8' + fromByteString _ = left show . Text.decodeUtf8' diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index fe2ee529..bb661194 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) @@ -29,10 +29,10 @@ import Network.Wai ( Response, Request, ResponseReceived, Application , lazyRequestBody, requestHeaders, requestMethod, rawQueryString, responseLBS) import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header - , MatrixParams, MatrixParam, MatrixFlag, + , MatrixParams, MatrixParam, MatrixFlag , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..)) -import Servant.Server.ContentTypes ( AllCTRender(..), AcceptHeader(..) - , AllCTUnrender(..) ) +import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..) + , AllCTUnrender(..),) import Servant.Common.Text (FromText, fromText) @@ -72,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 = @@ -401,15 +395,22 @@ 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. -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) @@ -695,8 +696,9 @@ instance ( AllCTUnrender list a, HasServer sublayout 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/Server/ContentTypesSpec.hs b/test/Servant/Server/ContentTypesSpec.hs index 657f8860..a857738b 100644 --- a/test/Servant/Server/ContentTypesSpec.hs +++ b/test/Servant/Server/ContentTypesSpec.hs @@ -24,8 +24,9 @@ import Test.Hspec import Test.QuickCheck import Servant.API +import Servant.API.ContentTypes import Servant.Server -import Servant.Server.ContentTypes +import Servant.Server.ContentTypes () spec :: Spec diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 2d82037e..26eece0f 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -209,10 +209,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 @@ -323,6 +323,11 @@ postSpec = do it "correctly rejects invalid request bodies with status 400" $ do 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 RawApi = "foo" :> Raw rawApi :: Proxy RawApi From 0789682cf80971e359b49e419bbd519cdc755757 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 21 Feb 2015 18:05:31 +0100 Subject: [PATCH 30/52] Remove ContentTypes.hs --- servant-server.cabal | 2 - src/Servant.hs | 2 - src/Servant/Server.hs | 1 - src/Servant/Server/ContentTypes.hs | 51 --------- test/Servant/Server/ContentTypesSpec.hs | 131 ------------------------ 5 files changed, 187 deletions(-) delete mode 100644 src/Servant/Server/ContentTypes.hs delete mode 100644 test/Servant/Server/ContentTypesSpec.hs diff --git a/servant-server.cabal b/servant-server.cabal index b4b2b3ab..8061a0ba 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -31,7 +31,6 @@ library exposed-modules: Servant Servant.Server - Servant.Server.ContentTypes Servant.Server.Internal Servant.Utils.StaticFiles build-depends: @@ -40,7 +39,6 @@ library , attoparsec >= 0.12 && < 0.13 , bytestring >= 0.10 && < 0.11 , either >= 4.3 && < 4.4 - , http-media >= 0.4 && < 0.5 , http-types >= 0.8 && < 0.9 , network-uri >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4 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 2495022e..4f8c94a8 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -16,7 +16,6 @@ import Data.Proxy (Proxy) import Network.Wai (Application) import Servant.Server.Internal -import Servant.Server.ContentTypes () -- * Implementing Servers diff --git a/src/Servant/Server/ContentTypes.hs b/src/Servant/Server/ContentTypes.hs deleted file mode 100644 index 8557dc3c..00000000 --- a/src/Servant/Server/ContentTypes.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Servant.Server.ContentTypes where - -import Control.Monad (join) -import Control.Arrow (left) -import Data.Aeson (ToJSON(..), FromJSON(..), encode, eitherDecode) -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString as BS -import Data.Proxy (Proxy(..)) -import Data.String.Conversions (cs) -import qualified Data.Text.Lazy.Encoding as Text -import qualified Data.Text.Lazy as Text -import GHC.Exts (Constraint) -import qualified Network.HTTP.Media as M - - -import Servant.API ( XML, HTML, JSON, JavaScript, CSS, PlainText - , OctetStream, MimeRender(..), MimeUnrender(..) ) - - --------------------------------------------------------------------------- --- * MimeRender Instances - --- | @encode@ -instance ToJSON a => MimeRender JSON a where - toByteString _ = encode - --- | @encodeUtf8@ -instance MimeRender PlainText Text.Text where - toByteString _ = Text.encodeUtf8 - --------------------------------------------------------------------------- --- * MimeUnrender Instances - --- | @decode@ -instance FromJSON a => MimeUnrender JSON a where - fromByteString _ = eitherDecode - --- | @Text.decodeUtf8'@ -instance MimeUnrender PlainText Text.Text where - fromByteString _ = left show . Text.decodeUtf8' - diff --git a/test/Servant/Server/ContentTypesSpec.hs b/test/Servant/Server/ContentTypesSpec.hs deleted file mode 100644 index a857738b..00000000 --- a/test/Servant/Server/ContentTypesSpec.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Servant.Server.ContentTypesSpec where - -import Control.Applicative -import Data.Aeson (encode) -import Data.ByteString.Char8 -import Data.Function (on) -import Data.Maybe (isJust, fromJust) -import Data.List (maximumBy) -import Data.Proxy (Proxy(..)) -import qualified Data.Text.Lazy as T -import Data.String (IsString(..)) -import Data.String.Conversions (cs) -import Network.HTTP.Types (hAccept) -import Network.Wai (pathInfo, requestHeaders) -import Network.Wai.Test ( runSession, request, defaultRequest - , assertContentType, assertStatus ) -import Test.Hspec -import Test.QuickCheck - -import Servant.API -import Servant.API.ContentTypes -import Servant.Server -import Servant.Server.ContentTypes () - - -spec :: Spec -spec = describe "Servant.Server.ContentTypes" $ do - handleAcceptHSpec - contentTypeSpec - -handleAcceptHSpec :: Spec -handleAcceptHSpec = describe "handleAcceptH" $ do - - it "should return Just if the 'Accept' header matches" $ do - handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) - `shouldSatisfy` isJust - handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int) - `shouldSatisfy` isJust - handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int) - `shouldSatisfy` isJust - - it "should return the Content-Type as the first element of the tuple" $ do - handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) - `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) - handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int) - `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) - handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int) - `shouldSatisfy` ((== "text/html;charset=utf-8") . fst . fromJust) - - it "should return the appropriately serialized representation" $ do - property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: Int) - == Just ("application/json;charset=utf-8", encode x) - - it "respects the Accept spec ordering" $ - property $ \a b c i -> fst (fromJust $ val a b c i) == (fst $ highest a b c) - where - highest a b c = maximumBy (compare `on` snd) [ ("text/html;charset=utf-8", a) - , ("application/json;charset=utf-8", b) - , ("application/xml;charset=utf-8", c) - ] - acceptH a b c = addToAccept (Proxy :: Proxy HTML) a $ - addToAccept (Proxy :: Proxy JSON) b $ - addToAccept (Proxy :: Proxy XML ) c "" - val a b c i = handleAcceptH (Proxy :: Proxy '[HTML, JSON, XML]) - (acceptH a b c) (i :: Int) - -type ContentTypeApi = "foo" :> Get '[JSON] Int - :<|> "bar" :> Get '[JSON, PlainText] T.Text - -contentTypeApi :: Proxy ContentTypeApi -contentTypeApi = Proxy - -contentTypeServer :: Server ContentTypeApi -contentTypeServer = return 5 :<|> return "hi" - -contentTypeSpec :: Spec -contentTypeSpec = do - describe "Accept Headers" $ do - - it "uses the highest quality possible in the header" $ - flip runSession (serve contentTypeApi contentTypeServer) $ do - let acceptH = "text/plain; q=0.9, application/json; q=0.8" - response <- Network.Wai.Test.request defaultRequest{ - requestHeaders = [(hAccept, acceptH)] , - pathInfo = ["bar"] - } - assertContentType "text/plain;charset=utf8" response - - it "returns the first content-type if the Accept header is missing" $ - flip runSession (serve contentTypeApi contentTypeServer) $ do - response <- Network.Wai.Test.request defaultRequest{ - pathInfo = ["bar"] - } - assertContentType "application/json;charset=utf8" response - - it "returns 406 if it can't serve the requested content-type" $ - flip runSession (serve contentTypeApi contentTypeServer) $ do - let acceptH = "text/css" - response <- Network.Wai.Test.request defaultRequest{ - requestHeaders = [(hAccept, acceptH)] , - pathInfo = ["bar"] - } - assertStatus 406 response - - -instance Show a => MimeRender HTML a where - toByteString _ = cs . show - -instance Show a => MimeRender XML a where - toByteString _ = cs . show - -instance IsString AcceptHeader where - fromString = AcceptHeader . fromString - -addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader -addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h) - where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f) - cont "" = new - cont old = old `append` ", " `append` new - -newtype ZeroToOne = ZeroToOne Float - deriving (Eq, Show, Ord) - -instance Arbitrary ZeroToOne where - arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]] From 81c358962498a76b02bd3a45389761726be85d9c Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 24 Feb 2015 14:05:04 +0100 Subject: [PATCH 31/52] Review fix --- src/Servant/Server/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index bb661194..edee67e4 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -276,7 +276,7 @@ instance ( AllCTRender ctypes a Right output -> do let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of - Nothing -> responseLBS (mkStatus 406 "") [] "" + Nothing -> responseLBS (mkStatus 406 "Not Acceptable") [] "" Just (contentT, body) -> responseLBS ok200 [ ("Content-Type" , cs contentT)] body Left (status, message) -> From b96a2d214d7069a811a91ccc91f51efcd01eb509 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 24 Feb 2015 14:48:17 +0100 Subject: [PATCH 32/52] Pay down some coverage debt --- test/Servant/ServerSpec.hs | 45 ++++++++++++++++++++++++++++---------- 1 file changed, 34 insertions(+), 11 deletions(-) diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 26eece0f..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,7 +17,8 @@ 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, methodPost, hContentType) +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) @@ -24,16 +26,9 @@ import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec.Wai ( liftIO, with, get, post, shouldRespondWith , matchStatus, request ) -import Servant.API (JSON) -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(..)) @@ -77,6 +72,7 @@ spec = do queryParamSpec matrixParamSpec postSpec + headerSpec rawSpec unionSpec errorsSpec @@ -328,6 +324,33 @@ postSpec = do , "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 rawApi :: Proxy RawApi From 1a63d8797a1d948c883049f82fb6b09cf9f01cc3 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 24 Feb 2015 13:46:50 +0100 Subject: [PATCH 33/52] Export `toApplication` from Server. --- src/Servant/Server.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index 4f8c94a8..ec7efbd6 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -4,12 +4,14 @@ -- | This module lets you implement 'Server's for defined APIs. You'll -- most likely just need 'serve'. module Servant.Server - ( -- * Implementing an API + ( -- * Run a wai application from an API serve + , -- * Construct a wai Application from an API + toApplication + , -- * Handlers for all standard combinators HasServer(..) - ) where import Data.Proxy (Proxy) @@ -40,5 +42,10 @@ import Servant.Server.Internal -- > -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app +-- +-- (If you need access to the wai 'Application' type, use +-- 'toApplication'. This is useful for writing custom servers that do +-- things other than routing (e.g. dumping all requests and responses +-- to a file).) serve :: HasServer layout => Proxy layout -> Server layout -> Application serve p server = toApplication (route p server) From 27e842365fb0f32b58eca0e45067bd2f61370ff7 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 27 Feb 2015 15:27:35 +0100 Subject: [PATCH 34/52] Remove overly specific comment. --- src/Servant/Server.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index ec7efbd6..0bec3370 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -42,10 +42,5 @@ import Servant.Server.Internal -- > -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app --- --- (If you need access to the wai 'Application' type, use --- 'toApplication'. This is useful for writing custom servers that do --- things other than routing (e.g. dumping all requests and responses --- to a file).) serve :: HasServer layout => Proxy layout -> Server layout -> Application serve p server = toApplication (route p server) From f7af3b14d25ed9a10b49624872c843b07522c228 Mon Sep 17 00:00:00 2001 From: Roland Schatz Date: Mon, 2 Mar 2015 22:23:56 +0100 Subject: [PATCH 35/52] Introduce `ServerT` to specify generic handlers. --- src/Servant/Server.hs | 1 + src/Servant/Server/Internal.hs | 55 +++++++++++++++++----------------- 2 files changed, 29 insertions(+), 27 deletions(-) diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index 0bec3370..de5d8434 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -12,6 +12,7 @@ module Servant.Server , -- * Handlers for all standard combinators HasServer(..) + , Server ) where import Data.Proxy (Proxy) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index edee67e4..9393327d 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -160,9 +160,10 @@ processedPathInfo r = where pinfo = parsePathInfo r class HasServer layout where - type Server layout :: * + type ServerT layout (m :: * -> *) :: * route :: Proxy layout -> Server layout -> RoutingApplication +type Server layout = ServerT layout (EitherT (Int, String) IO) -- * Instances @@ -179,7 +180,7 @@ class HasServer layout where -- > where listAllBooks = ... -- > postBook book = ... instance (HasServer a, HasServer b) => HasServer (a :<|> b) where - type Server (a :<|> b) = Server a :<|> Server b + type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m route Proxy (a :<|> b) request respond = route pa a request $ \ mResponse -> if isMismatch mResponse @@ -212,8 +213,8 @@ captured _ = fromText instance (KnownSymbol capture, FromText a, HasServer sublayout) => HasServer (Capture capture a :> sublayout) where - type Server (Capture capture a :> sublayout) = - a -> Server sublayout + type ServerT (Capture capture a :> sublayout) m = + a -> ServerT sublayout m route Proxy subserver request respond = case processedPathInfo request of (first : rest) @@ -239,7 +240,7 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout) -- painlessly error out if the conditions for a successful deletion -- are not met. instance HasServer Delete where - type Server Delete = EitherT (Int, String) IO () + type ServerT Delete m = m () route Proxy action request respond | pathIsEmpty request && requestMethod request == methodDelete = do @@ -268,7 +269,7 @@ instance HasServer Delete where -- list. instance ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where - type Server (Get ctypes a) = EitherT (Int, String) IO a + type ServerT (Get ctypes a) m = m a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodGet = do e <- runEitherT action @@ -308,8 +309,8 @@ instance ( AllCTRender ctypes a instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (Header sym a :> sublayout) where - type Server (Header sym a :> sublayout) = - Maybe a -> Server sublayout + type ServerT (Header sym a :> sublayout) m = + Maybe a -> ServerT sublayout m route Proxy subserver request respond = do let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request) @@ -332,7 +333,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) -- list. instance ( AllCTRender ctypes a ) => HasServer (Post ctypes a) where - type Server (Post ctypes a) = EitherT (Int, String) IO a + type ServerT (Post ctypes a) m = m a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPost = do @@ -365,7 +366,7 @@ instance ( AllCTRender ctypes a -- list. instance ( AllCTRender ctypes a ) => HasServer (Put ctypes a) where - type Server (Put ctypes a) = EitherT (Int, String) IO a + type ServerT (Put ctypes a) m = m a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPut = do @@ -398,7 +399,7 @@ instance ( AllCTRender ctypes a instance ( AllCTRender ctypes a , Typeable a , ToJSON a) => HasServer (Patch ctypes a) where - type Server (Patch ctypes a) = EitherT (Int, String) IO a + type ServerT (Patch ctypes a) m = m a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPost = do @@ -442,8 +443,8 @@ instance ( AllCTRender ctypes a instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (QueryParam sym a :> sublayout) where - type Server (QueryParam sym a :> sublayout) = - Maybe a -> Server sublayout + type ServerT (QueryParam sym a :> sublayout) m = + Maybe a -> ServerT sublayout m route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request @@ -480,8 +481,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (QueryParams sym a :> sublayout) where - type Server (QueryParams sym a :> sublayout) = - [a] -> Server sublayout + type ServerT (QueryParams sym a :> sublayout) m = + [a] -> ServerT sublayout m route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request @@ -513,8 +514,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout) => HasServer (QueryFlag sym :> sublayout) where - type Server (QueryFlag sym :> sublayout) = - Bool -> Server sublayout + type ServerT (QueryFlag sym :> sublayout) m = + Bool -> ServerT sublayout m route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request @@ -556,8 +557,8 @@ parseMatrixText = parseQueryText instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (MatrixParam sym a :> sublayout) where - type Server (MatrixParam sym a :> sublayout) = - Maybe a -> Server sublayout + type ServerT (MatrixParam sym a :> sublayout) m = + Maybe a -> ServerT sublayout m route Proxy subserver request respond = case parsePathInfo request of (first : _) @@ -594,8 +595,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (MatrixParams sym a :> sublayout) where - type Server (MatrixParams sym a :> sublayout) = - [a] -> Server sublayout + type ServerT (MatrixParams sym a :> sublayout) m = + [a] -> ServerT sublayout m route Proxy subserver request respond = case parsePathInfo request of (first : _) @@ -628,8 +629,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout) => HasServer (MatrixFlag sym :> sublayout) where - type Server (MatrixFlag sym :> sublayout) = - Bool -> Server sublayout + type ServerT (MatrixFlag sym :> sublayout) m = + Bool -> ServerT sublayout m route Proxy subserver request respond = case parsePathInfo request of (first : _) @@ -656,7 +657,7 @@ instance (KnownSymbol sym, HasServer sublayout) -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images" instance HasServer Raw where - type Server Raw = Application + type ServerT Raw m = Application route Proxy rawApplication request respond = rawApplication request (respond . succeedWith) @@ -683,8 +684,8 @@ instance HasServer Raw where instance ( AllCTUnrender list a, HasServer sublayout ) => HasServer (ReqBody list a :> sublayout) where - type Server (ReqBody list a :> sublayout) = - a -> Server sublayout + type ServerT (ReqBody list a :> sublayout) m = + a -> ServerT sublayout m route Proxy subserver request respond = do -- See HTTP RFC 2616, section 7.2.1 @@ -703,7 +704,7 @@ instance ( AllCTUnrender list a, HasServer sublayout -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @sublayout@. instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where - type Server (path :> sublayout) = Server sublayout + type ServerT (path :> sublayout) m = ServerT sublayout m route Proxy subserver request respond = case processedPathInfo request of (first : rest) | first == cs (symbolVal proxyPath) From b24822a44889420964f454f216b666082d2b5c04 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Wed, 4 Mar 2015 01:53:40 +0100 Subject: [PATCH 36/52] tentative changelog --- CHANGELOG.md | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 0993fc8f..f45412af 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,12 @@ -master ------- +0.3 +--- +* Add a `RouteMismatch` constructor for arbitrary HTTP response codes (https://github.com/haskell-servant/servant-server/pull/22) +* Add support for the `Patch` combinator +* Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3* +* Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29) +0.2.4 +----- * 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) From 0be89b4f3da56164ac7e8b7a46568ae17e256bc2 Mon Sep 17 00:00:00 2001 From: Christian Marie Date: Thu, 5 Mar 2015 12:11:20 +1100 Subject: [PATCH 37/52] Change JSON-specific error message to a more general one --- src/Servant/Server/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index edee67e4..159560fa 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -71,7 +71,7 @@ toApplication ra request respond = do routingRespond (Left WrongMethod) = respond $ responseLBS methodNotAllowed405 [] "method not allowed" routingRespond (Left (InvalidBody err)) = - respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err + respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err routingRespond (Left UnsupportedMediaType) = respond $ responseLBS unsupportedMediaType415 [] "unsupported media type" routingRespond (Left (HttpError status body)) = From 9a33fa7812aab6751575a9667ca661f0bcf090c3 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Mon, 9 Mar 2015 15:16:38 +0100 Subject: [PATCH 38/52] Canonicalize the API type to make sure that the following 'law' holds: Server (a :> (b :<|> c)) ~ Server (a :> b) :<|> Server (a :> c) --- src/Servant/Server.hs | 10 ++++-- src/Servant/Server/Internal.hs | 59 ++++++++++++++++---------------- src/Servant/Utils/StaticFiles.hs | 2 +- 3 files changed, 38 insertions(+), 33 deletions(-) diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index 0bec3370..7329fecc 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | This module lets you implement 'Server's for defined APIs. You'll @@ -12,11 +13,12 @@ module Servant.Server , -- * Handlers for all standard combinators HasServer(..) + , Server ) where import Data.Proxy (Proxy) import Network.Wai (Application) - +import Servant.API (Canonicalize) import Servant.Server.Internal @@ -42,5 +44,7 @@ import Servant.Server.Internal -- > -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app -serve :: HasServer layout => Proxy layout -> Server layout -> Application -serve p server = toApplication (route p server) +serve :: HasServer (Canonicalize layout) => Proxy layout -> Server layout -> Application +serve p server = toApplication (route (canonicalize p) server) + +type Server layout = Server' (Canonicalize layout) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 159560fa..a8e97687 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -160,10 +160,11 @@ processedPathInfo r = where pinfo = parsePathInfo r class HasServer layout where - type Server layout :: * - route :: Proxy layout -> Server layout -> RoutingApplication - + type Server' layout :: * + route :: Proxy layout -> Server' layout -> RoutingApplication +canonicalize :: Canonicalize layout ~ t => Proxy layout -> Proxy t +canonicalize Proxy = Proxy -- * Instances @@ -179,7 +180,7 @@ class HasServer layout where -- > where listAllBooks = ... -- > postBook book = ... instance (HasServer a, HasServer b) => HasServer (a :<|> b) where - type Server (a :<|> b) = Server a :<|> Server b + type Server' (a :<|> b) = Server' a :<|> Server' b route Proxy (a :<|> b) request respond = route pa a request $ \ mResponse -> if isMismatch mResponse @@ -212,8 +213,8 @@ captured _ = fromText instance (KnownSymbol capture, FromText a, HasServer sublayout) => HasServer (Capture capture a :> sublayout) where - type Server (Capture capture a :> sublayout) = - a -> Server sublayout + type Server' (Capture capture a :> sublayout) = + a -> Server' sublayout route Proxy subserver request respond = case processedPathInfo request of (first : rest) @@ -239,7 +240,7 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout) -- painlessly error out if the conditions for a successful deletion -- are not met. instance HasServer Delete where - type Server Delete = EitherT (Int, String) IO () + type Server' Delete = EitherT (Int, String) IO () route Proxy action request respond | pathIsEmpty request && requestMethod request == methodDelete = do @@ -268,7 +269,7 @@ instance HasServer Delete where -- list. instance ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where - type Server (Get ctypes a) = EitherT (Int, String) IO a + type Server' (Get ctypes a) = EitherT (Int, String) IO a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodGet = do e <- runEitherT action @@ -308,8 +309,8 @@ instance ( AllCTRender ctypes a instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (Header sym a :> sublayout) where - type Server (Header sym a :> sublayout) = - Maybe a -> Server sublayout + type Server' (Header sym a :> sublayout) = + Maybe a -> Server' sublayout route Proxy subserver request respond = do let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request) @@ -332,7 +333,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) -- list. instance ( AllCTRender ctypes a ) => HasServer (Post ctypes a) where - type Server (Post ctypes a) = EitherT (Int, String) IO a + type Server' (Post ctypes a) = EitherT (Int, String) IO a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPost = do @@ -365,7 +366,7 @@ instance ( AllCTRender ctypes a -- list. instance ( AllCTRender ctypes a ) => HasServer (Put ctypes a) where - type Server (Put ctypes a) = EitherT (Int, String) IO a + type Server' (Put ctypes a) = EitherT (Int, String) IO a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPut = do @@ -398,7 +399,7 @@ instance ( AllCTRender ctypes a instance ( AllCTRender ctypes a , Typeable a , ToJSON a) => HasServer (Patch ctypes a) where - type Server (Patch ctypes a) = EitherT (Int, String) IO a + type Server' (Patch ctypes a) = EitherT (Int, String) IO a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPost = do @@ -442,8 +443,8 @@ instance ( AllCTRender ctypes a instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (QueryParam sym a :> sublayout) where - type Server (QueryParam sym a :> sublayout) = - Maybe a -> Server sublayout + type Server' (QueryParam sym a :> sublayout) = + Maybe a -> Server' sublayout route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request @@ -480,8 +481,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (QueryParams sym a :> sublayout) where - type Server (QueryParams sym a :> sublayout) = - [a] -> Server sublayout + type Server' (QueryParams sym a :> sublayout) = + [a] -> Server' sublayout route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request @@ -513,8 +514,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout) => HasServer (QueryFlag sym :> sublayout) where - type Server (QueryFlag sym :> sublayout) = - Bool -> Server sublayout + type Server' (QueryFlag sym :> sublayout) = + Bool -> Server' sublayout route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request @@ -556,8 +557,8 @@ parseMatrixText = parseQueryText instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (MatrixParam sym a :> sublayout) where - type Server (MatrixParam sym a :> sublayout) = - Maybe a -> Server sublayout + type Server' (MatrixParam sym a :> sublayout) = + Maybe a -> Server' sublayout route Proxy subserver request respond = case parsePathInfo request of (first : _) @@ -594,8 +595,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (MatrixParams sym a :> sublayout) where - type Server (MatrixParams sym a :> sublayout) = - [a] -> Server sublayout + type Server' (MatrixParams sym a :> sublayout) = + [a] -> Server' sublayout route Proxy subserver request respond = case parsePathInfo request of (first : _) @@ -628,8 +629,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout) => HasServer (MatrixFlag sym :> sublayout) where - type Server (MatrixFlag sym :> sublayout) = - Bool -> Server sublayout + type Server' (MatrixFlag sym :> sublayout) = + Bool -> Server' sublayout route Proxy subserver request respond = case parsePathInfo request of (first : _) @@ -656,7 +657,7 @@ instance (KnownSymbol sym, HasServer sublayout) -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images" instance HasServer Raw where - type Server Raw = Application + type Server' Raw = Application route Proxy rawApplication request respond = rawApplication request (respond . succeedWith) @@ -683,8 +684,8 @@ instance HasServer Raw where instance ( AllCTUnrender list a, HasServer sublayout ) => HasServer (ReqBody list a :> sublayout) where - type Server (ReqBody list a :> sublayout) = - a -> Server sublayout + type Server' (ReqBody list a :> sublayout) = + a -> Server' sublayout route Proxy subserver request respond = do -- See HTTP RFC 2616, section 7.2.1 @@ -703,7 +704,7 @@ instance ( AllCTUnrender list a, HasServer sublayout -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @sublayout@. instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where - type Server (path :> sublayout) = Server sublayout + type Server' (path :> sublayout) = Server' sublayout route Proxy subserver request respond = case processedPathInfo request of (first : rest) | first == cs (symbolVal proxyPath) diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs index 9cd5fdcc..07c51173 100644 --- a/src/Servant/Utils/StaticFiles.hs +++ b/src/Servant/Utils/StaticFiles.hs @@ -9,7 +9,7 @@ module Servant.Utils.StaticFiles ( import Filesystem.Path.CurrentOS (decodeString) import Network.Wai.Application.Static (staticApp, defaultFileServerSettings) import Servant.API.Raw (Raw) -import Servant.Server.Internal (Server) +import Servant.Server (Server) -- | Serve anything under the specified directory as a 'Raw' endpoint. -- From 5f7795f70f2dc96c2e40183c25e2b07f758ee79c Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Mon, 9 Mar 2015 19:23:53 +0100 Subject: [PATCH 39/52] remove canonicalize, it's now in servant --- src/Servant/Server/Internal.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index a8e97687..07da7df5 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -163,9 +163,6 @@ class HasServer layout where type Server' layout :: * route :: Proxy layout -> Server' layout -> RoutingApplication -canonicalize :: Canonicalize layout ~ t => Proxy layout -> Proxy t -canonicalize Proxy = Proxy - -- * Instances -- | A server for @a ':<|>' b@ first tries to match the request against the route From 8428e4bd7bda915161c0d144124139a1c2cd078e Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Mon, 9 Mar 2015 19:59:25 +0100 Subject: [PATCH 40/52] fix dumb error --- src/Servant/Server.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index 7329fecc..c87befd4 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -18,7 +18,7 @@ module Servant.Server import Data.Proxy (Proxy) import Network.Wai (Application) -import Servant.API (Canonicalize) +import Servant.API (Canonicalize, canonicalize) import Servant.Server.Internal From bd98844357b09a40d7db17495b5600b548525a90 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 10 Mar 2015 23:07:24 +0100 Subject: [PATCH 41/52] CHANGELOG update for PR #21. --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index f45412af..6a0b3e47 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,7 @@ * Add support for the `Patch` combinator * Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3* * 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) 0.2.4 ----- From f76c729a084fb5e4a8f1ff7cfbca207986200e7b Mon Sep 17 00:00:00 2001 From: Roland Schatz Date: Mon, 2 Mar 2015 22:23:56 +0100 Subject: [PATCH 42/52] Introduce `ServerT` to specify generic handlers. --- src/Servant/Server/Internal.hs | 69 +++++++++++++++++++++------------- 1 file changed, 42 insertions(+), 27 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 07da7df5..741ddc62 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -160,9 +160,12 @@ processedPathInfo r = where pinfo = parsePathInfo r class HasServer layout where - type Server' layout :: * + type ServerT layout (m :: * -> *) :: * route :: Proxy layout -> Server' layout -> RoutingApplication +type Server' layout = ServerT layout (EitherT (Int, String) IO) + + -- * Instances -- | A server for @a ':<|>' b@ first tries to match the request against the route @@ -177,7 +180,9 @@ class HasServer layout where -- > where listAllBooks = ... -- > postBook book = ... instance (HasServer a, HasServer b) => HasServer (a :<|> b) where - type Server' (a :<|> b) = Server' a :<|> Server' b + + type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m + route Proxy (a :<|> b) request respond = route pa a request $ \ mResponse -> if isMismatch mResponse @@ -210,8 +215,8 @@ captured _ = fromText instance (KnownSymbol capture, FromText a, HasServer sublayout) => HasServer (Capture capture a :> sublayout) where - type Server' (Capture capture a :> sublayout) = - a -> Server' sublayout + type ServerT (Capture capture a :> sublayout) m = + a -> ServerT sublayout m route Proxy subserver request respond = case processedPathInfo request of (first : rest) @@ -237,7 +242,8 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout) -- painlessly error out if the conditions for a successful deletion -- are not met. instance HasServer Delete where - type Server' Delete = EitherT (Int, String) IO () + + type ServerT Delete m = m () route Proxy action request respond | pathIsEmpty request && requestMethod request == methodDelete = do @@ -266,7 +272,9 @@ instance HasServer Delete where -- list. instance ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where - type Server' (Get ctypes a) = EitherT (Int, String) IO a + + type ServerT (Get ctypes a) m = m a + route Proxy action request respond | pathIsEmpty request && requestMethod request == methodGet = do e <- runEitherT action @@ -306,8 +314,8 @@ instance ( AllCTRender ctypes a instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (Header sym a :> sublayout) where - type Server' (Header sym a :> sublayout) = - Maybe a -> Server' sublayout + type ServerT (Header sym a :> sublayout) m = + Maybe a -> ServerT sublayout m route Proxy subserver request respond = do let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request) @@ -330,7 +338,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) -- list. instance ( AllCTRender ctypes a ) => HasServer (Post ctypes a) where - type Server' (Post ctypes a) = EitherT (Int, String) IO a + + type ServerT (Post ctypes a) m = m a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPost = do @@ -363,7 +372,8 @@ instance ( AllCTRender ctypes a -- list. instance ( AllCTRender ctypes a ) => HasServer (Put ctypes a) where - type Server' (Put ctypes a) = EitherT (Int, String) IO a + + type ServerT (Put ctypes a) m = m a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPut = do @@ -396,7 +406,8 @@ instance ( AllCTRender ctypes a instance ( AllCTRender ctypes a , Typeable a , ToJSON a) => HasServer (Patch ctypes a) where - type Server' (Patch ctypes a) = EitherT (Int, String) IO a + + type ServerT (Patch ctypes a) m = m a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPost = do @@ -440,8 +451,8 @@ instance ( AllCTRender ctypes a instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (QueryParam sym a :> sublayout) where - type Server' (QueryParam sym a :> sublayout) = - Maybe a -> Server' sublayout + type ServerT (QueryParam sym a :> sublayout) m = + Maybe a -> ServerT sublayout m route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request @@ -478,8 +489,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (QueryParams sym a :> sublayout) where - type Server' (QueryParams sym a :> sublayout) = - [a] -> Server' sublayout + type ServerT (QueryParams sym a :> sublayout) m = + [a] -> ServerT sublayout m route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request @@ -511,8 +522,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout) => HasServer (QueryFlag sym :> sublayout) where - type Server' (QueryFlag sym :> sublayout) = - Bool -> Server' sublayout + type ServerT (QueryFlag sym :> sublayout) m = + Bool -> ServerT sublayout m route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request @@ -554,8 +565,8 @@ parseMatrixText = parseQueryText instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (MatrixParam sym a :> sublayout) where - type Server' (MatrixParam sym a :> sublayout) = - Maybe a -> Server' sublayout + type ServerT (MatrixParam sym a :> sublayout) m = + Maybe a -> ServerT sublayout m route Proxy subserver request respond = case parsePathInfo request of (first : _) @@ -592,8 +603,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (MatrixParams sym a :> sublayout) where - type Server' (MatrixParams sym a :> sublayout) = - [a] -> Server' sublayout + type ServerT (MatrixParams sym a :> sublayout) m = + [a] -> ServerT sublayout m route Proxy subserver request respond = case parsePathInfo request of (first : _) @@ -626,8 +637,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout) => HasServer (MatrixFlag sym :> sublayout) where - type Server' (MatrixFlag sym :> sublayout) = - Bool -> Server' sublayout + type ServerT (MatrixFlag sym :> sublayout) m = + Bool -> ServerT sublayout m route Proxy subserver request respond = case parsePathInfo request of (first : _) @@ -654,7 +665,9 @@ instance (KnownSymbol sym, HasServer sublayout) -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images" instance HasServer Raw where - type Server' Raw = Application + + type ServerT Raw m = Application + route Proxy rawApplication request respond = rawApplication request (respond . succeedWith) @@ -681,8 +694,8 @@ instance HasServer Raw where instance ( AllCTUnrender list a, HasServer sublayout ) => HasServer (ReqBody list a :> sublayout) where - type Server' (ReqBody list a :> sublayout) = - a -> Server' sublayout + type ServerT (ReqBody list a :> sublayout) m = + a -> ServerT sublayout m route Proxy subserver request respond = do -- See HTTP RFC 2616, section 7.2.1 @@ -701,7 +714,9 @@ instance ( AllCTUnrender list a, HasServer sublayout -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @sublayout@. instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where - type Server' (path :> sublayout) = Server' sublayout + + type ServerT (path :> sublayout) m = ServerT sublayout m + route Proxy subserver request respond = case processedPathInfo request of (first : rest) | first == cs (symbolVal proxyPath) From bd9d476679dd54340616a639770153be0ef40e10 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 10 Mar 2015 23:07:24 +0100 Subject: [PATCH 43/52] CHANGELOG update for PR #21. --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index f45412af..6a0b3e47 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,7 @@ * Add support for the `Patch` combinator * Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3* * 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) 0.2.4 ----- From 837099d12d956095cd72324701aa4c1b34ef7222 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Mon, 9 Mar 2015 15:16:38 +0100 Subject: [PATCH 44/52] Canonicalize the API type to make sure that the following 'law' holds: Server (a :> (b :<|> c)) ~ Server (a :> b) :<|> Server (a :> c) --- src/Servant/Server/Internal.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 741ddc62..3b53efc9 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -165,7 +165,6 @@ class HasServer layout where type Server' layout = ServerT layout (EitherT (Int, String) IO) - -- * Instances -- | A server for @a ':<|>' b@ first tries to match the request against the route @@ -184,7 +183,7 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m route Proxy (a :<|> b) request respond = - route pa a request $ \ mResponse -> + route pa a request $ \mResponse -> if isMismatch mResponse then route pb b request $ \mResponse' -> respond (mResponse <> mResponse') else respond mResponse From c1ed47b35f94d9ca84ba402d24a2056b4269f106 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Wed, 11 Mar 2015 12:19:14 +0100 Subject: [PATCH 45/52] add changelog entry --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6a0b3e47..8246c2ba 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,7 @@ * Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3* * 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 typesy 0.2.4 ----- From 5eddb318a28fd066765dfb2ca4a03d5d5ae580f4 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 12 Mar 2015 18:29:57 +0100 Subject: [PATCH 46/52] Make Post and Put return NoContent when response is () --- src/Servant/Server/Internal.hs | 74 ++++++++++++--- test/Servant/ServerSpec.hs | 162 +++++++++++++++++++++++++++------ 2 files changed, 193 insertions(+), 43 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index df930374..b92036c6 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -4,12 +4,12 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverlappingInstances #-} {-# 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) @@ -286,6 +286,19 @@ instance ( AllCTRender ctypes a respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound +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 + -- | 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'. @@ -351,6 +364,19 @@ instance ( AllCTRender ctypes a 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 + -- | 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 @@ -382,7 +408,19 @@ instance ( AllCTRender ctypes a 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 -- | When implementing the handler for a 'Patch' endpoint, @@ -397,25 +435,35 @@ instance ( AllCTRender ctypes a -- a 'ToJSON' instance and servant takes care of encoding it for you, -- yielding status code 201 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 . 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 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 /= methodPost = + | 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 () -> responseLBS noContent204 [] "" + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | pathIsEmpty request && requestMethod request /= methodPatch = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index e73c565e..6b44e409 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -1,36 +1,40 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} 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) -import Data.Monoid ((<>)) -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, 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, request ) +import Control.Monad (when) +import Control.Monad.Trans.Either (EitherT, left) +import Data.Aeson (FromJSON, ToJSON, decode', encode) +import Data.Char (toUpper) +import Data.Monoid ((<>)) +import Data.Proxy (Proxy (Proxy)) +import Data.String (fromString) +import Data.String.Conversions (cs) +import GHC.Generics (Generic) +import Network.HTTP.Types (hContentType, methodDelete, + 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 (get, liftIO, matchStatus, post, + request, shouldRespondWith, with) -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(..)) +import Servant.API ((:<|>) (..), (:>), Capture, Delete, + Get, Header, JSON, MatrixFlag, + MatrixParam, MatrixParams, Patch, + Post, Put, QueryFlag, QueryParam, + QueryParams, Raw, ReqBody) +import Servant.Server (Server, serve) +import Servant.Server.Internal (RouteMismatch (..)) -- * test data types @@ -69,9 +73,11 @@ spec :: Spec spec = do captureSpec getSpec + postSpec + putSpec + patchSpec queryParamSpec matrixParamSpec - postSpec headerSpec rawSpec unionSpec @@ -105,13 +111,15 @@ 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 @@ -121,6 +129,10 @@ getSpec = do it "throws 405 (wrong method) on POSTs" $ do post "/" "" `shouldRespondWith` 405 + it "returns 204 if the type is '()'" $ do + get "empty" `shouldRespondWith` ""{ matchStatus = 204 } + + type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person @@ -291,13 +303,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 +334,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 From b35512c3d4b73f3bf4ba6701bec3893f7dbd5739 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 12 Mar 2015 18:37:08 +0100 Subject: [PATCH 47/52] Update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6a0b3e47..437c167d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,7 @@ * Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3* * 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) +* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28) 0.2.4 ----- From 622c77251e2613a3fd9b1e3bfde2ac3337c5a6ee Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 6 Apr 2015 16:12:28 +0200 Subject: [PATCH 48/52] Don't succeedWith when response content-type is unacceptable. --- src/Servant/Server/Internal.hs | 40 +++++++++++++++++----------------- test/Servant/ServerSpec.hs | 10 +++++++-- 2 files changed, 28 insertions(+), 22 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index b92036c6..064eddab 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -273,14 +273,14 @@ 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 - Left (status, message) -> + 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 @@ -351,14 +351,14 @@ 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 - Left (status, message) -> + 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 @@ -397,14 +397,14 @@ 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 - Left (status, message) -> + 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 @@ -441,14 +441,14 @@ instance ( AllCTRender ctypes a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPatch = 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 - Left (status, message) -> + 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 diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 6b44e409..03c7463c 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -15,6 +15,7 @@ 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 (hContentType, methodDelete, methodPatch, methodPost, methodPut, @@ -31,8 +32,9 @@ import Test.Hspec.Wai (get, liftIO, matchStatus, post, import Servant.API ((:<|>) (..), (:>), Capture, Delete, Get, Header, JSON, MatrixFlag, MatrixParam, MatrixParams, Patch, - Post, Put, QueryFlag, QueryParam, - QueryParams, Raw, ReqBody) + PlainText, Post, Put, QueryFlag, + QueryParam, QueryParams, Raw, + ReqBody) import Servant.Server (Server, serve) import Servant.Server.Internal (RouteMismatch (..)) @@ -483,6 +485,7 @@ rawSpec = do type AlternativeApi = "foo" :> Get '[JSON] Person :<|> "bar" :> Get '[JSON] Animal + :<|> "foo" :> Get '[PlainText] T.Text unionApi :: Proxy AlternativeApi unionApi = Proxy @@ -490,6 +493,7 @@ unionServer :: Server AlternativeApi unionServer = return alice :<|> return jerry + :<|> return "a string" unionSpec :: Spec unionSpec = do @@ -504,6 +508,8 @@ unionSpec = do liftIO $ do decode' (simpleBody response_) `shouldBe` Just jerry + it "checks all endpoints before returning 406" $ do + get "/foo" `shouldRespondWith` 200 -- | Test server error functionality. errorsSpec :: Spec From fed014e12024fe151bddbc5a58e627dc602a226b Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 6 Apr 2015 16:43:36 +0200 Subject: [PATCH 49/52] Pay back some test-debt --- test/Servant/ServerSpec.hs | 36 ++++++++++++++++++++++++++++-------- 1 file changed, 28 insertions(+), 8 deletions(-) diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 03c7463c..ab03ae95 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -17,7 +17,8 @@ import Data.String (fromString) import Data.String.Conversions (cs) import qualified Data.Text as T import GHC.Generics (Generic) -import Network.HTTP.Types (hContentType, methodDelete, +import Network.HTTP.Types (hAccept, hContentType, + methodDelete, methodGet, methodPatch, methodPost, methodPut, ok200, parseQuery, status409) import Network.Wai (Application, Request, pathInfo, @@ -43,7 +44,7 @@ import Servant.Server.Internal (RouteMismatch (..)) data Person = Person { name :: String, - age :: Integer + age :: Integer } deriving (Eq, Show, Generic) @@ -54,7 +55,7 @@ alice :: Person alice = Person "Alice" 42 data Animal = Animal { - species :: String, + species :: String, numberOfLegs :: Integer } deriving (Eq, Show, Generic) @@ -99,10 +100,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)) @@ -122,18 +126,23 @@ getSpec = do describe "Servant.API.Get" $ 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 @@ -486,6 +495,9 @@ 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 @@ -494,11 +506,15 @@ 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 @@ -508,9 +524,13 @@ unionSpec = do liftIO $ do decode' (simpleBody response_) `shouldBe` Just jerry - it "checks all endpoints before returning 406" $ do + + 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 + -- | Test server error functionality. errorsSpec :: Spec errorsSpec = do From 2ec477159f8a3272f0a5126a37f175cee8c537ea Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 13 Apr 2015 15:13:55 +0200 Subject: [PATCH 50/52] Add server support for response headers --- CHANGELOG.md | 1 + servant-server.cabal | 1 + src/Servant/Server/Internal.hs | 159 +++++++++++++++++++++++++-------- test/Servant/ServerSpec.hs | 60 +++++++++++-- 4 files changed, 177 insertions(+), 44 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 437c167d..9b9f30b6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,7 @@ * 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) * 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 ----- diff --git a/servant-server.cabal b/servant-server.cabal index 8061a0ba..75a54ba8 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -80,6 +80,7 @@ test-suite spec base == 4.* , aeson , bytestring + , bytestring-conversion , directory , either , exceptions diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 064eddab..9e64dafc 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -1,45 +1,53 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Servant.Server.Internal where -import Control.Applicative ((<$>)) -import Control.Monad.Trans.Either (EitherT, runEitherT) -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.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.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, (:>), (:<|>)(..)) -import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..) - , AllCTUnrender(..),) -import Servant.Common.Text (FromText, fromText) +import Control.Applicative ((<$>)) +import Control.Monad.Trans.Either (EitherT, runEitherT) +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, mappend, mempty) +import Data.String (fromString) +import Data.String.Conversions (cs, (<>)) +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, ResponseHeaders) +import Network.Wai (Application, Request, Response, + ResponseReceived, lazyRequestBody, + pathInfo, rawQueryString, + requestBody, requestHeaders, + requestMethod, responseLBS, + strictRequestBody) +import Servant.API ((:<|>) (..), (:>), Capture, + 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 @@ -286,6 +294,7 @@ instance ( AllCTRender ctypes a 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 @@ -299,6 +308,26 @@ instance HasServer (Get ctypes ()) where 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'. @@ -377,6 +406,26 @@ instance HasServer (Post ctypes ()) where 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 @@ -387,7 +436,7 @@ instance HasServer (Post ctypes ()) where -- -- 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 @@ -423,6 +472,26 @@ instance HasServer (Put ctypes ()) where 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, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' -- and 'Servant.API.Put.Put', the handler code runs in the @@ -433,7 +502,7 @@ instance HasServer (Put ctypes ()) 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. +-- yielding status code 200 along the way. instance ( AllCTRender ctypes a ) => HasServer (Patch ctypes a) where type ServerT (Patch ctypes a) m = m a @@ -467,6 +536,26 @@ instance HasServer (Patch ctypes ()) where 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 + -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @'Maybe' 'Text'@. diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index ab03ae95..58ef1244 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -3,13 +3,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# 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 (FromJSON, ToJSON, decode', encode) +import Data.ByteString.Conversion () import Data.Char (toUpper) import Data.Monoid ((<>)) import Data.Proxy (Proxy (Proxy)) @@ -27,15 +30,17 @@ import Network.Wai (Application, Request, pathInfo, import Network.Wai.Test (defaultRequest, request, runSession, simpleBody) import Test.Hspec (Spec, describe, it, shouldBe) -import Test.Hspec.Wai (get, liftIO, matchStatus, post, - request, shouldRespondWith, with) +import Test.Hspec.Wai (get, liftIO, matchHeaders, + matchStatus, post, request, + shouldRespondWith, with, (<:>)) -import Servant.API ((:<|>) (..), (:>), Capture, Delete, - Get, Header, JSON, MatrixFlag, - MatrixParam, MatrixParams, Patch, - PlainText, Post, Put, QueryFlag, - QueryParam, QueryParams, Raw, - ReqBody) +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 (..)) @@ -85,6 +90,7 @@ spec = do rawSpec unionSpec errorsSpec + responseHeadersSpec type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal @@ -531,6 +537,42 @@ unionSpec = do 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 From bf637865cd234f9809cc8c4862ed851d55aade6f Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Sun, 19 Apr 2015 12:06:31 +0200 Subject: [PATCH 51/52] fix inconsistencies from rebase --- src/Servant/Server/Internal.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 66bb422f..6c509fe8 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -303,7 +303,7 @@ instance ( AllCTRender ctypes a -- '()' ==> 204 No Content instance HasServer (Get ctypes ()) where - type ServerT (Get ctypes ()) m = m () + type ServerT' (Get ctypes ()) m = m () route Proxy action request respond | pathIsEmpty request && requestMethod request == methodGet = do e <- runEitherT action @@ -317,7 +317,7 @@ instance HasServer (Get ctypes ()) where -- 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) + 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 @@ -402,7 +402,7 @@ instance ( AllCTRender ctypes a | otherwise = respond $ failWith NotFound instance HasServer (Post ctypes ()) where - type ServerT (Post ctypes ()) m = m () + type ServerT' (Post ctypes ()) m = m () route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPost = do e <- runEitherT action @@ -416,7 +416,7 @@ instance HasServer (Post ctypes ()) where -- 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) + 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 @@ -469,7 +469,7 @@ instance ( AllCTRender ctypes a | otherwise = respond $ failWith NotFound instance HasServer (Put ctypes ()) where - type ServerT (Put ctypes ()) m = m () + type ServerT' (Put ctypes ()) m = m () route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPut = do e <- runEitherT action @@ -483,7 +483,7 @@ instance HasServer (Put ctypes ()) where -- 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) + 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 @@ -533,7 +533,7 @@ instance ( AllCTRender ctypes a | otherwise = respond $ failWith NotFound instance HasServer (Patch ctypes ()) where - type ServerT (Patch ctypes ()) m = m () + type ServerT' (Patch ctypes ()) m = m () route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPatch = do e <- runEitherT action @@ -547,7 +547,7 @@ instance HasServer (Patch ctypes ()) where -- 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) + 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 From ed502f5f21d0d39c683b06e37c16545dbd661b32 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 20 Apr 2015 11:13:18 +0200 Subject: [PATCH 52/52] Prepare merge --- .gitignore | 17 ------- .travis.yml | 50 ------------------- CHANGELOG.md => servant-server/CHANGELOG.md | 0 LICENSE => servant-server/LICENSE | 0 README.md => servant-server/README.md | 0 Setup.hs => servant-server/Setup.hs | 0 default.nix => servant-server/default.nix | 0 {example => servant-server/example}/README.md | 0 {example => servant-server/example}/greet.hs | 0 {example => servant-server/example}/greet.md | 0 .../servant-server.cabal | 0 {src => servant-server/src}/Servant.hs | 0 {src => servant-server/src}/Servant/Server.hs | 0 .../src}/Servant/Server/Internal.hs | 0 .../src}/Servant/Utils/StaticFiles.hs | 0 .../test}/Servant/ServerSpec.hs | 0 .../test}/Servant/Utils/StaticFilesSpec.hs | 0 {test => servant-server/test}/Spec.hs | 0 18 files changed, 67 deletions(-) delete mode 100644 .gitignore delete mode 100644 .travis.yml rename CHANGELOG.md => servant-server/CHANGELOG.md (100%) rename LICENSE => servant-server/LICENSE (100%) rename README.md => servant-server/README.md (100%) rename Setup.hs => servant-server/Setup.hs (100%) rename default.nix => servant-server/default.nix (100%) rename {example => servant-server/example}/README.md (100%) rename {example => servant-server/example}/greet.hs (100%) rename {example => servant-server/example}/greet.md (100%) rename servant-server.cabal => servant-server/servant-server.cabal (100%) rename {src => servant-server/src}/Servant.hs (100%) rename {src => servant-server/src}/Servant/Server.hs (100%) rename {src => servant-server/src}/Servant/Server/Internal.hs (100%) rename {src => servant-server/src}/Servant/Utils/StaticFiles.hs (100%) rename {test => servant-server/test}/Servant/ServerSpec.hs (100%) rename {test => servant-server/test}/Servant/Utils/StaticFilesSpec.hs (100%) rename {test => servant-server/test}/Spec.hs (100%) diff --git a/.gitignore b/.gitignore deleted file mode 100644 index 0855a79b..00000000 --- a/.gitignore +++ /dev/null @@ -1,17 +0,0 @@ -dist -cabal-dev -*.o -*.hi -*.chi -*.chs.h -*.dyn_o -*.dyn_hi -.virtualenv -.hpc -.hsenv -.cabal-sandbox/ -cabal.sandbox.config -cabal.config -*.prof -*.aux -*.hp diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index b6a1f304..00000000 --- a/.travis.yml +++ /dev/null @@ -1,50 +0,0 @@ -language: haskell - -env: -- GHCVER=7.8.3 - -before_install: - - | - if [ $GHCVER = `ghc --numeric-version` ]; then - travis/cabal-apt-install --enable-tests $MODE - export CABAL=cabal - else - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - travis_retry sudo apt-get update - travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy - export CABAL=cabal-1.18 - export PATH=/opt/ghc/$GHCVER/bin:$PATH - fi - - $CABAL update - - | - if [ $GHCVER = "head" ] || [ $GHCVER = "7.8.3" ]; then - $CABAL install happy alex - export PATH=$HOME/.cabal/bin:$PATH - fi - - git clone https://github.com/haskell-servant/servant.git - - cabal sandbox init - - cabal sandbox add-source servant - -install: - - cabal install --only-dependencies --enable-tests - -script: - - cabal configure --enable-tests --enable-library-coverage - - cabal build && cabal test - - cabal sdist - -after_script: - - cabal install hpc-coveralls - - export PATH=.cabal-sandbox/bin:$PATH - - hpc-coveralls --exclude-dir=test spec - -notifications: - irc: - channels: - - "irc.freenode.org#servant" - template: - - "%{repository}#%{build_number} - %{commit} on %{branch} by %{author}: %{message}" - - "Build details: %{build_url} - Change view: %{compare_url}" - skip_join: true - on_success: change - on_failure: always diff --git a/CHANGELOG.md b/servant-server/CHANGELOG.md similarity index 100% rename from CHANGELOG.md rename to servant-server/CHANGELOG.md diff --git a/LICENSE b/servant-server/LICENSE similarity index 100% rename from LICENSE rename to servant-server/LICENSE diff --git a/README.md b/servant-server/README.md similarity index 100% rename from README.md rename to servant-server/README.md diff --git a/Setup.hs b/servant-server/Setup.hs similarity index 100% rename from Setup.hs rename to servant-server/Setup.hs diff --git a/default.nix b/servant-server/default.nix similarity index 100% rename from default.nix rename to servant-server/default.nix diff --git a/example/README.md b/servant-server/example/README.md similarity index 100% rename from example/README.md rename to servant-server/example/README.md diff --git a/example/greet.hs b/servant-server/example/greet.hs similarity index 100% rename from example/greet.hs rename to servant-server/example/greet.hs diff --git a/example/greet.md b/servant-server/example/greet.md similarity index 100% rename from example/greet.md rename to servant-server/example/greet.md diff --git a/servant-server.cabal b/servant-server/servant-server.cabal similarity index 100% rename from servant-server.cabal rename to servant-server/servant-server.cabal diff --git a/src/Servant.hs b/servant-server/src/Servant.hs similarity index 100% rename from src/Servant.hs rename to servant-server/src/Servant.hs diff --git a/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs similarity index 100% rename from src/Servant/Server.hs rename to servant-server/src/Servant/Server.hs diff --git a/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs similarity index 100% rename from src/Servant/Server/Internal.hs rename to servant-server/src/Servant/Server/Internal.hs diff --git a/src/Servant/Utils/StaticFiles.hs b/servant-server/src/Servant/Utils/StaticFiles.hs similarity index 100% rename from src/Servant/Utils/StaticFiles.hs rename to servant-server/src/Servant/Utils/StaticFiles.hs diff --git a/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs similarity index 100% rename from test/Servant/ServerSpec.hs rename to servant-server/test/Servant/ServerSpec.hs diff --git a/test/Servant/Utils/StaticFilesSpec.hs b/servant-server/test/Servant/Utils/StaticFilesSpec.hs similarity index 100% rename from test/Servant/Utils/StaticFilesSpec.hs rename to servant-server/test/Servant/Utils/StaticFilesSpec.hs diff --git a/test/Spec.hs b/servant-server/test/Spec.hs similarity index 100% rename from test/Spec.hs rename to servant-server/test/Spec.hs