first shot at a server package
This commit is contained in:
Alp Mestanogullari
commit
e43532b71d
14 changed files with 1159 additions and 0 deletions
30
LICENSE
Normal file
30
LICENSE
Normal 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
25
README.md
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
# servant
|
||||
|
||||
[](http://travis-ci.org/haskell-servant/servant)
|
||||
|
||||
|
||||
|
||||
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
2
Setup.hs
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
2
example/README.md
Normal file
2
example/README.md
Normal 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
72
example/greet.hs
Normal 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
52
example/greet.md
Normal 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
95
servant-server.cabal
Normal 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
24
src/Servant.hs
Normal 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
39
src/Servant/Server.hs
Normal 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
459
src/Servant/Server/Internal.hs
Normal 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
36
src/Servant/Utils/StaticFiles.hs
Normal 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
258
test/Servant/ServerSpec.hs
Normal 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
64
test/Servant/Utils/StaticFilesSpec.hs
Normal 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
1
test/Spec.hs
Normal file
|
|
@ -0,0 +1 @@
|
|||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
Loading…
Reference in a new issue