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

add split server-side bits into servant-server

Browse Source
This commit is contained in:
Alp Mestanogullari 2014-12-10 16:11:57 +01:00
parent 741da9fde1
commit 6836eb6bcc
21 changed files with 7 additions and 1208 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
example/README.md
View File

@ -1,2 +0,0 @@
- `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
View File

@ -1,72 +0,0 @@
{-# 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
View File

@ -1,52 +0,0 @@
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

130
servant.cabal
View File

@ -1,87 +1,13 @@
name: servant
version: 0.2
synopsis: A family of combinators for defining webservices APIs and serving them
version: 0.2.1
synopsis: A family of combinators for defining webservices APIs
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.
.
Here's a runnable example, with comments, that defines a dummy API and
implements a webserver that serves this API. You can find it <https://github.com/haskell-servant/servant/blob/master/example/greet.hs here> too.
.
> {-# 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
<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 the <http://hackage.haskell.org/package/servant-server servant-server> package.
homepage: http://haskell-servant.github.io/
Bug-reports: http://github.com/haskell-servant/servant/issues
license: BSD3
@ -99,7 +25,6 @@ source-repository head
library
exposed-modules:
Servant
Servant.API
Servant.API.Alternative
Servant.API.Capture
@ -114,45 +39,17 @@ library
Servant.API.Sub
Servant.Common.Text
Servant.QQ
Servant.Server
Servant.Utils.Links
Servant.Utils.StaticFiles
build-depends:
base >=4.7 && <5
, aeson
, attoparsec
, bytestring
, either
, http-types
, network-uri >= 2.6
, parsec
, safe
, split
, string-conversions
, system-filepath
, text >= 1
, template-haskell
, text
, transformers
, wai
, wai-app-static
, warp
, parsec >= 3.1
, string-conversions >= 0.3
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
, aeson
, warp
, wai
, text
test-suite spec
type: exitcode-stdio-1.0
ghc-options:
@ -162,22 +59,9 @@ test-suite spec
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
View File

@ -1,24 +0,0 @@
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

2
src/Servant/API.hs
View File

@ -29,7 +29,6 @@ module Servant.API (
-- * Untyped endpoints
-- | Plugging in a wai 'Network.Wai.Application', serving directories
module Servant.API.Raw,
module Servant.Utils.StaticFiles,
-- * Utilities
-- | QuasiQuotes for endpoints
@ -51,4 +50,3 @@ import Servant.API.ReqBody
import Servant.API.Sub
import Servant.QQ (sitemap)
import Servant.Utils.Links (mkLink)
import Servant.Utils.StaticFiles

28
src/Servant/API/Alternative.hs
View File

@ -1,12 +1,6 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.API.Alternative where
import Data.Monoid
import Data.Proxy
import Servant.Server
-- | Union of two APIs, first takes precedence in case of overlap.
--
-- Example:
@ -15,25 +9,3 @@ import Servant.Server
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
data a :<|> b = a :<|> b
infixr 8 :<|>
-- | 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

50
src/Servant/API/Capture.hs
View File

@ -1,19 +1,6 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.API.Capture (Capture) where
import Data.Proxy
import Data.Text
import GHC.TypeLits
import Network.Wai
import Servant.API.Sub
import Servant.Common.Text
import Servant.Server
-- | Capture a value from the request path under a certain type @a@.
--
-- Example:
@ -21,40 +8,3 @@ import Servant.Server
-- > -- GET /books/:isbn
-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book
data Capture sym a
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)

35
src/Servant/API/Delete.hs
View File

@ -1,16 +1,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Servant.API.Delete where
import Control.Monad.Trans.Either
import Data.Proxy
import Data.String.Conversions
import Data.Typeable
import Network.HTTP.Types
import Network.Wai
import Servant.Server
-- | Combinator for DELETE requests.
--
@ -20,29 +11,3 @@ import Servant.Server
-- > type MyApi = "books" :> Capture "isbn" Text :> Delete
data Delete
deriving Typeable
-- | 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

35
src/Servant/API/Get.hs
View File

@ -1,17 +1,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Servant.API.Get where
import Control.Monad.Trans.Either
import Data.Aeson
import Data.Proxy
import Data.String.Conversions
import Data.Typeable
import Network.HTTP.Types
import Network.Wai
import Servant.Server
-- | Endpoint for simple GET requests. Serves the result as JSON.
--
@ -20,28 +10,3 @@ import Servant.Server
-- > type MyApi = "books" :> Get [Book]
data Get a
deriving Typeable
-- | 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

43
src/Servant/API/Header.hs
View File

@ -1,18 +1,7 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.API.Header where
import Data.Proxy
import Data.String
import Data.Text.Encoding (decodeUtf8)
import GHC.TypeLits
import Network.Wai
import Servant.API.Sub
import Servant.Common.Text
import Servant.Server
-- | Extract the given header's value as a value of type @a@.
--
@ -24,35 +13,3 @@ import Servant.Server
-- > -- GET /view-my-referer
-- > type MyApi = "view-my-referer" :> Header "from" Referer :> Get Referer
data Header sym a
-- | 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)

36
src/Servant/API/Post.hs
View File

@ -1,17 +1,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Servant.API.Post where
import Control.Monad.Trans.Either
import Data.Aeson
import Data.Proxy
import Data.String.Conversions
import Data.Typeable
import Network.HTTP.Types
import Network.Wai
import Servant.Server
-- | Endpoint for POST requests. The type variable represents the type of the
-- response body (not the request body, use 'Servant.API.RQBody.RQBody' for
@ -25,29 +15,3 @@ import Servant.Server
-- > type MyApi = "books" :> ReqBody Book :> Post Book
data Post a
deriving Typeable
-- | 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

37
src/Servant/API/Put.hs
View File

@ -1,17 +1,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Servant.API.Put where
import Control.Monad.Trans.Either
import Data.Aeson
import Data.Proxy
import Data.String.Conversions
import Data.Typeable
import Network.HTTP.Types
import Network.Wai
import Servant.Server
-- | Endpoint for PUT requests, usually used to update a ressource.
-- The type @a@ is the type of the response body that's returned.
@ -23,30 +13,3 @@ import Servant.Server
-- > type MyApi = "books" :> Capture "isbn" Text :> ReqBody Book :> Put Book
data Put a
deriving Typeable
-- | 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

127
src/Servant/API/QueryParam.hs
View File

@ -1,22 +1,6 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.API.QueryParam where
import Data.Maybe
import Data.Proxy
import Data.String.Conversions
import GHC.TypeLits
import Network.HTTP.Types
import Network.Wai
import Servant.API.Sub
import Servant.Common.Text
import Servant.Server
-- | Lookup the value associated to the @sym@ query string parameter
-- and try to extract it as a value of type @a@.
--
@ -26,46 +10,6 @@ import Servant.Server
-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book]
data QueryParam sym a
-- | 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)
-- | Lookup the values associated to the @sym@ query string parameter
-- and try to extract it as a value of type @[a]@. This is typically
-- meant to support query string parameters of the form
@ -79,46 +23,6 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book]
data QueryParams sym a
-- | 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
-- | Lookup a potentially value-less query string parameter
-- with boolean semantics. If the param @sym@ is there without any value,
-- or if it's there with value "true" or "1", it's interpreted as 'True'.
@ -129,34 +33,3 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
-- > -- /books?published
-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book]
data QueryFlag sym
-- | 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

20
src/Servant/API/Raw.hs
View File

@ -1,12 +1,5 @@
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Servant.API.Raw where
import Data.Proxy
import Network.Wai
import Servant.Server
-- | Endpoint for plugging in your own Wai 'Application's.
--
-- The given 'Application' will get the request as received by the server, potentially with
@ -17,16 +10,3 @@ import Servant.Server
-- static files stored in a particular directory on your filesystem, or to serve
-- your API's documentation with 'Servant.Utils.StaticFiles.serveDocumentation'.
data Raw
-- | 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)

40
src/Servant/API/ReqBody.hs
View File

@ -1,17 +1,5 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.API.ReqBody where
import Control.Applicative
import Data.Aeson
import Data.Proxy
import Network.Wai
import Servant.API.Sub
import Servant.Server
-- | Extract the request body as a value of type @a@.
--
-- Example:
@ -19,31 +7,3 @@ import Servant.Server
-- > -- POST /books
-- > type MyApi = "books" :> ReqBody Book :> Post Book
data ReqBody a
-- | 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

19
src/Servant/API/Sub.hs
View File

@ -1,14 +1,9 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.API.Sub where
import Data.Proxy
import Data.String.Conversions
import GHC.TypeLits
import Network.Wai
import Servant.Server
-- | The contained API (second argument) can be found under @("/" ++ path)@
-- (path being the first argument).
@ -20,17 +15,3 @@ import Servant.Server
-- > type MyApi = "hello" :> "world" :> Get World
data (path :: k) :> a = Proxy path :> a
infixr 9 :>
-- | 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

105
src/Servant/Server.hs
View File

@ -1,105 +0,0 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
-- | This module lets you implement 'Server's for defined APIs. You'll
-- most likely just need 'serve'.
module Servant.Server where
import Data.Monoid
import Data.Proxy
import Network.HTTP.Types
import Network.Wai
-- * 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)
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

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

@ -1,36 +0,0 @@
-- | 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
-- | 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
View File

@ -1,258 +0,0 @@
{-# 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
View File

@ -1,64 +0,0 @@
{-# 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"