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

first shot at a server package

Browse Source
This commit is contained in:
Alp Mestanogullari 2014-12-10 16:10:57 +01:00
commit e43532b71d
14 changed files with 1159 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
LICENSE Normal file
View File

@ -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.

25
README.md Normal file
View File

@ -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/)

2
Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

2
example/README.md Normal file
View File

@ -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.

72
example/greet.hs Normal file
View File

@ -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

52
example/greet.md Normal file
View File

@ -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

95
servant-server.cabal Normal file
View File

@ -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 <http://haskell-servant.github.io/getting-started/ the getting started> guide.
.
<https://github.com/haskell-servant/servant-server/blob/master/example/greet.hs Here>'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

24
src/Servant.hs Normal file
View File

@ -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

39
src/Servant/Server.hs Normal file
View File

@ -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)

459
src/Servant/Server/Internal.hs Normal file
View File

@ -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

36
src/Servant/Utils/StaticFiles.hs Normal file
View File

@ -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\/\<something>@ and look for
-- @\<something>@ 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 ++ "/")))

258
test/Servant/ServerSpec.hs Normal file
View File

@ -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

64
test/Servant/Utils/StaticFilesSpec.hs Normal file
View File

@ -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"

1
test/Spec.hs Normal file
View File

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}