Merge remote-tracking branch 'servant-server/prepare-merge' into merge
This commit is contained in:
Julian K. Arni
commit
29a54fe290
16 changed files with 1978 additions and 0 deletions
26
servant-server/CHANGELOG.md
Normal file
26
servant-server/CHANGELOG.md
Normal file
|
|
@ -0,0 +1,26 @@
|
|||
0.3
|
||||
---
|
||||
* Add a `RouteMismatch` constructor for arbitrary HTTP response codes (https://github.com/haskell-servant/servant-server/pull/22)
|
||||
* Add support for the `Patch` combinator
|
||||
* Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3*
|
||||
* Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29)
|
||||
* Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21)
|
||||
* Canonicalize API types before generating the handler types with `Server`
|
||||
* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)
|
||||
* Add server support for response headers
|
||||
|
||||
0.2.4
|
||||
-----
|
||||
* Added support for matrix parameters, see e.g. http://www.w3.org/DesignIssues/MatrixURIs.html
|
||||
* Add support for serializing based on Accept header
|
||||
(https://github.com/haskell-servant/servant-server/issues/9)
|
||||
* Ignore trailing slashes
|
||||
(https://github.com/haskell-servant/servant-server/issues/5)
|
||||
|
||||
|
||||
0.2.3
|
||||
-----
|
||||
|
||||
* Fix consuming request body issue
|
||||
(https://github.com/haskell-servant/servant/issues/3)
|
||||
* Make code sample in Servant.Server complete
|
||||
30
servant-server/LICENSE
Normal file
30
servant-server/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.
|
||||
20
servant-server/README.md
Normal file
20
servant-server/README.md
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
# servant-server
|
||||
|
||||
[](http://travis-ci.org/haskell-servant/servant-server)
|
||||
[](https://coveralls.io/r/haskell-servant/servant-server)
|
||||
|
||||
|
||||
|
||||
This library lets you *implement* an HTTP server with handlers for each endpoint of a servant API, handling most of the boilerplate for you.
|
||||
|
||||
## Getting started
|
||||
|
||||
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://hackage.haskell.org/package/servant)
|
||||
- Implementing an HTTP server for a webservice API with [servant-server](http://github.com/haskell-servant/servant-server) - [docs](http://hackage.haskell.org/package/servant-server)
|
||||
- (Haskell) client-side function generation with [servant-client](http://github.com/haskell-servant/servant-client) - [docs](http://hackage.haskell.org/package/servant-client)
|
||||
- (Javascript) client-side function generation with [servant-jquery](http://github.com/haskell-servant/servant-jquery) - [docs](http://hackage.haskell.org/package/servant-jquery)
|
||||
- API docs generation with [servant-docs](http://github.com/haskell-servant/servant-docs) - [docs](http://hackage.haskell.org/package/servant-docs)
|
||||
2
servant-server/Setup.hs
Normal file
2
servant-server/Setup.hs
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
15
servant-server/default.nix
Normal file
15
servant-server/default.nix
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
{ pkgs ? import <nixpkgs> { config.allowUnfree = true; }
|
||||
, src ? builtins.filterSource (path: type:
|
||||
type != "unknown" &&
|
||||
baseNameOf path != ".git" &&
|
||||
baseNameOf path != "result" &&
|
||||
baseNameOf path != "dist") ./.
|
||||
, servant ? import ../servant {}
|
||||
}:
|
||||
pkgs.haskellPackages.buildLocalCabalWithArgs {
|
||||
name = "servant-server";
|
||||
inherit src;
|
||||
args = {
|
||||
inherit servant;
|
||||
};
|
||||
}
|
||||
2
servant-server/example/README.md
Normal file
2
servant-server/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
servant-server/example/greet.hs
Normal file
72
servant-server/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 '[JSON] Greet
|
||||
|
||||
-- POST /greet with a Greet as JSON in the request body,
|
||||
-- returns a Greet as JSON
|
||||
:<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] 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
servant-server/example/greet.md
Normal file
52
servant-server/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
|
||||
101
servant-server/servant-server.cabal
Normal file
101
servant-server/servant-server.cabal
Normal file
|
|
@ -0,0 +1,101 @@
|
|||
name: servant-server
|
||||
version: 0.2.4
|
||||
synopsis: A family of combinators for defining webservices APIs and serving them
|
||||
description:
|
||||
A family of combinators for defining webservices APIs and serving them
|
||||
.
|
||||
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
|
||||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
README.md
|
||||
source-repository head
|
||||
type: git
|
||||
location: http://github.com/haskell-servant/servant-server.git
|
||||
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Servant
|
||||
Servant.Server
|
||||
Servant.Server.Internal
|
||||
Servant.Utils.StaticFiles
|
||||
build-depends:
|
||||
base >= 4.7 && < 5
|
||||
, aeson >= 0.7 && < 0.9
|
||||
, attoparsec >= 0.12 && < 0.13
|
||||
, bytestring >= 0.10 && < 0.11
|
||||
, either >= 4.3 && < 4.4
|
||||
, http-types >= 0.8 && < 0.9
|
||||
, network-uri >= 2.6 && < 2.7
|
||||
, safe >= 0.3 && < 0.4
|
||||
, servant >= 0.2 && < 0.4
|
||||
, split >= 0.2 && < 0.3
|
||||
, string-conversions >= 0.3 && < 0.4
|
||||
, system-filepath >= 0.4 && < 0.5
|
||||
, text >= 1.2 && < 1.3
|
||||
, transformers >= 0.3 && < 0.5
|
||||
, wai >= 3.0 && < 3.1
|
||||
, wai-app-static >= 3.0 && < 3.1
|
||||
, warp >= 3.0 && < 3.1
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
|
||||
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
|
||||
, bytestring-conversion
|
||||
, directory
|
||||
, either
|
||||
, exceptions
|
||||
, hspec == 2.*
|
||||
, hspec-wai
|
||||
, http-types
|
||||
, network >= 2.6
|
||||
, QuickCheck
|
||||
, parsec
|
||||
, servant
|
||||
, servant-server
|
||||
, string-conversions
|
||||
, temporary
|
||||
, text
|
||||
, transformers
|
||||
, wai
|
||||
, wai-extra
|
||||
, warp
|
||||
22
servant-server/src/Servant.hs
Normal file
22
servant-server/src/Servant.hs
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
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.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.Utils.Links
|
||||
import Servant.Utils.StaticFiles
|
||||
49
servant-server/src/Servant/Server.hs
Normal file
49
servant-server/src/Servant/Server.hs
Normal file
|
|
@ -0,0 +1,49 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | This module lets you implement 'Server's for defined APIs. You'll
|
||||
-- most likely just need 'serve'.
|
||||
module Servant.Server
|
||||
( -- * Run a wai application from an API
|
||||
serve
|
||||
|
||||
, -- * Construct a wai Application from an API
|
||||
toApplication
|
||||
|
||||
, -- * Handlers for all standard combinators
|
||||
HasServer(..)
|
||||
, Server
|
||||
, ServerT
|
||||
) where
|
||||
|
||||
import Data.Proxy (Proxy)
|
||||
import Network.Wai (Application)
|
||||
import Servant.API (Canonicalize, canonicalize)
|
||||
import Servant.Server.Internal
|
||||
|
||||
|
||||
-- * Implementing Servers
|
||||
|
||||
-- | 'serve' allows you to implement an API and produce a wai 'Application'.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
|
||||
-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = listAllBooks :<|> postBook
|
||||
-- > where listAllBooks = ...
|
||||
-- > postBook book = ...
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > app :: Application
|
||||
-- > app = serve myApi server
|
||||
-- >
|
||||
-- > main :: IO ()
|
||||
-- > main = Network.Wai.Handler.Warp.run 8080 app
|
||||
serve :: HasServer (Canonicalize layout) => Proxy layout -> Server layout -> Application
|
||||
serve p server = toApplication (route (canonicalize p) server)
|
||||
866
servant-server/src/Servant/Server/Internal.hs
Normal file
866
servant-server/src/Servant/Server/Internal.hs
Normal file
|
|
@ -0,0 +1,866 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Servant.Server.Internal where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Monad.Trans.Either (EitherT, runEitherT)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.IORef (newIORef, readIORef, writeIORef)
|
||||
import Data.List (unfoldr)
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
import Data.Monoid (Monoid, mappend, mempty)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs, (<>))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||
import Data.Typeable
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal)
|
||||
import Network.HTTP.Types hiding (Header, ResponseHeaders)
|
||||
import Network.Wai (Application, Request, Response,
|
||||
ResponseReceived, lazyRequestBody,
|
||||
pathInfo, rawQueryString,
|
||||
requestBody, requestHeaders,
|
||||
requestMethod, responseLBS,
|
||||
strictRequestBody)
|
||||
import Servant.API ((:<|>) (..), (:>), Capture,
|
||||
Canonicalize, Delete, Get, Header,
|
||||
MatrixFlag, MatrixParam, MatrixParams,
|
||||
Patch, Post, Put, QueryFlag,
|
||||
QueryParam, QueryParams, Raw,
|
||||
ReqBody)
|
||||
import Servant.API.ContentTypes (AcceptHeader (..),
|
||||
AllCTRender (..),
|
||||
AllCTUnrender (..))
|
||||
import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)
|
||||
import Servant.Common.Text (FromText, fromText)
|
||||
|
||||
data ReqBodyState = Uncalled
|
||||
| Called !B.ByteString
|
||||
| Done !B.ByteString
|
||||
|
||||
|
||||
toApplication :: RoutingApplication -> Application
|
||||
toApplication ra request respond = do
|
||||
reqBodyRef <- newIORef Uncalled
|
||||
-- We may need to consume the requestBody more than once. In order to
|
||||
-- maintain the illusion that 'requestBody' works as expected,
|
||||
-- 'ReqBodyState' is introduced, and the complete body is memoized and
|
||||
-- returned as many times as requested with empty "Done" marker chunks in
|
||||
-- between.
|
||||
-- See https://github.com/haskell-servant/servant/issues/3
|
||||
let memoReqBody = do
|
||||
ior <- readIORef reqBodyRef
|
||||
case ior of
|
||||
Uncalled -> do
|
||||
r <- BL.toStrict <$> strictRequestBody request
|
||||
writeIORef reqBodyRef $ Done r
|
||||
return r
|
||||
Called bs -> do
|
||||
writeIORef reqBodyRef $ Done bs
|
||||
return bs
|
||||
Done bs -> do
|
||||
writeIORef reqBodyRef $ Called bs
|
||||
return B.empty
|
||||
|
||||
ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
|
||||
where
|
||||
routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
|
||||
routingRespond (Left NotFound) =
|
||||
respond $ responseLBS notFound404 [] "not found"
|
||||
routingRespond (Left WrongMethod) =
|
||||
respond $ responseLBS methodNotAllowed405 [] "method not allowed"
|
||||
routingRespond (Left (InvalidBody err)) =
|
||||
respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
|
||||
routingRespond (Left UnsupportedMediaType) =
|
||||
respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
|
||||
routingRespond (Left (HttpError status body)) =
|
||||
respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
|
||||
routingRespond (Right response) =
|
||||
respond response
|
||||
|
||||
-- Note that the ordering of the constructors has great significance! It
|
||||
-- determines the Ord instance and, consequently, the monoid instance.
|
||||
-- * Route mismatch
|
||||
data RouteMismatch =
|
||||
NotFound -- ^ the usual "not found" error
|
||||
| WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
|
||||
| UnsupportedMediaType -- ^ request body has unsupported media type
|
||||
| InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
|
||||
| HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Monoid RouteMismatch where
|
||||
mempty = NotFound
|
||||
-- The following isn't great, since it picks @InvalidBody@ based on
|
||||
-- alphabetical ordering, but any choice would be arbitrary.
|
||||
--
|
||||
-- "As one judge said to the other, 'Be just and if you can't be just, be
|
||||
-- arbitrary'" -- William Burroughs
|
||||
mappend = max
|
||||
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | Like `null . pathInfo`, but works with redundant trailing slashes.
|
||||
pathIsEmpty :: Request -> Bool
|
||||
pathIsEmpty = f . processedPathInfo
|
||||
where
|
||||
f [] = True
|
||||
f [""] = True
|
||||
f _ = False
|
||||
|
||||
-- | If we get a `Right`, it has precedence over everything else.
|
||||
--
|
||||
-- This in particular means that if we could get several 'Right's,
|
||||
-- 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
|
||||
|
||||
splitMatrixParameters :: Text -> (Text, Text)
|
||||
splitMatrixParameters = T.break (== ';')
|
||||
|
||||
parsePathInfo :: Request -> [Text]
|
||||
parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo
|
||||
where mergePairs = concat . unfoldr pairToList
|
||||
pairToList [] = Nothing
|
||||
pairToList ((a, b):xs) = Just ([a, b], xs)
|
||||
|
||||
-- | Returns a processed pathInfo from the request.
|
||||
--
|
||||
-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be
|
||||
-- processed, so routing works as intended. Therefor this function should be used to access
|
||||
-- the pathInfo for routing purposes.
|
||||
processedPathInfo :: Request -> [Text]
|
||||
processedPathInfo r =
|
||||
case pinfo of
|
||||
(x:xs) | T.head x == ';' -> xs
|
||||
_ -> pinfo
|
||||
where pinfo = parsePathInfo r
|
||||
|
||||
class HasServer layout where
|
||||
type ServerT' layout (m :: * -> *) :: *
|
||||
|
||||
route :: Proxy layout -> Server' layout -> RoutingApplication
|
||||
|
||||
type Server layout = Server' (Canonicalize layout)
|
||||
type Server' layout = ServerT' layout (EitherT (Int, String) IO)
|
||||
type ServerT layout m = ServerT' (Canonicalize layout) m
|
||||
|
||||
-- * Instances
|
||||
|
||||
-- | A server for @a ':<|>' b@ first tries to match the request against the route
|
||||
-- represented by @a@ and if it fails tries @b@. You must provide a request
|
||||
-- handler for each route.
|
||||
--
|
||||
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
|
||||
-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = listAllBooks :<|> postBook
|
||||
-- > where listAllBooks = ...
|
||||
-- > postBook book = ...
|
||||
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
|
||||
|
||||
type ServerT' (a :<|> b) m = ServerT' a m :<|> ServerT' b m
|
||||
|
||||
route Proxy (a :<|> b) request respond =
|
||||
route pa a request $ \mResponse ->
|
||||
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 '[JSON] 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 ServerT' (Capture capture a :> sublayout) m =
|
||||
a -> ServerT' sublayout m
|
||||
|
||||
route Proxy subserver request respond = case processedPathInfo 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 ServerT' Delete m = m ()
|
||||
|
||||
route Proxy action request respond
|
||||
| pathIsEmpty request && requestMethod request == methodDelete = do
|
||||
e <- runEitherT action
|
||||
respond $ succeedWith $ case e of
|
||||
Right () ->
|
||||
responseLBS status204 [] ""
|
||||
Left (status, message) ->
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| pathIsEmpty 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 use the type-level list, combined
|
||||
-- with the request's @Accept@ header, to encode the value for you
|
||||
-- (returning a status code of 200). If there was no @Accept@ header or it
|
||||
-- was @*/*@, we return encode using the first @Content-Type@ type on the
|
||||
-- list.
|
||||
instance ( AllCTRender ctypes a
|
||||
) => HasServer (Get ctypes a) where
|
||||
|
||||
type ServerT' (Get ctypes a) m = m a
|
||||
|
||||
route Proxy action request respond
|
||||
| pathIsEmpty request && requestMethod request == methodGet = do
|
||||
e <- runEitherT action
|
||||
respond $ case e of
|
||||
Right output -> do
|
||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
|
||||
Nothing -> failWith UnsupportedMediaType
|
||||
Just (contentT, body) -> succeedWith $
|
||||
responseLBS ok200 [ ("Content-Type" , cs contentT)] body
|
||||
Left (status, message) -> succeedWith $
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| pathIsEmpty request && requestMethod request /= methodGet =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
||||
-- '()' ==> 204 No Content
|
||||
instance HasServer (Get ctypes ()) where
|
||||
type ServerT' (Get ctypes ()) m = m ()
|
||||
route Proxy action request respond
|
||||
| pathIsEmpty request && requestMethod request == methodGet = do
|
||||
e <- runEitherT action
|
||||
respond . succeedWith $ case e of
|
||||
Right () -> responseLBS noContent204 [] ""
|
||||
Left (status, message) ->
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| pathIsEmpty request && requestMethod request /= methodGet =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
||||
-- Add response headers
|
||||
instance ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where
|
||||
type ServerT' (Get ctypes (Headers h v)) m = m (Headers h v)
|
||||
route Proxy action request respond
|
||||
| pathIsEmpty request && requestMethod request == methodGet = do
|
||||
e <- runEitherT action
|
||||
respond $ case e of
|
||||
Right output -> do
|
||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
||||
headers = getHeaders output
|
||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
|
||||
Nothing -> failWith UnsupportedMediaType
|
||||
Just (contentT, body) -> succeedWith $
|
||||
responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
|
||||
Left (status, message) -> succeedWith $
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| pathIsEmpty request && requestMethod request /= methodGet =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
||||
-- | If you use 'Header' in one of the endpoints for your API,
|
||||
-- this automatically requires your server-side handler to be a function
|
||||
-- that takes an argument of the type specified by 'Header'.
|
||||
-- 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 '[JSON] 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 ServerT' (Header sym a :> sublayout) m =
|
||||
Maybe a -> ServerT' sublayout m
|
||||
|
||||
route Proxy subserver request respond = do
|
||||
let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
|
||||
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 use the type-level list, combined
|
||||
-- with the request's @Accept@ header, to encode the value for you
|
||||
-- (returning a status code of 201). If there was no @Accept@ header or it
|
||||
-- was @*/*@, we return encode using the first @Content-Type@ type on the
|
||||
-- list.
|
||||
instance ( AllCTRender ctypes a
|
||||
) => HasServer (Post ctypes a) where
|
||||
|
||||
type ServerT' (Post ctypes a) m = m a
|
||||
|
||||
route Proxy action request respond
|
||||
| pathIsEmpty request && requestMethod request == methodPost = do
|
||||
e <- runEitherT action
|
||||
respond $ case e of
|
||||
Right output -> do
|
||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
|
||||
Nothing -> failWith UnsupportedMediaType
|
||||
Just (contentT, body) -> succeedWith $
|
||||
responseLBS status201 [ ("Content-Type" , cs contentT)] body
|
||||
Left (status, message) -> succeedWith $
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| pathIsEmpty request && requestMethod request /= methodPost =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
||||
instance HasServer (Post ctypes ()) where
|
||||
type ServerT' (Post ctypes ()) m = m ()
|
||||
route Proxy action request respond
|
||||
| pathIsEmpty request && requestMethod request == methodPost = do
|
||||
e <- runEitherT action
|
||||
respond . succeedWith $ case e of
|
||||
Right () -> responseLBS noContent204 [] ""
|
||||
Left (status, message) ->
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| pathIsEmpty request && requestMethod request /= methodPost =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
||||
-- Add response headers
|
||||
instance ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where
|
||||
type ServerT' (Post ctypes (Headers h v)) m = m (Headers h v)
|
||||
route Proxy action request respond
|
||||
| pathIsEmpty request && requestMethod request == methodPost = do
|
||||
e <- runEitherT action
|
||||
respond $ case e of
|
||||
Right output -> do
|
||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
||||
headers = getHeaders output
|
||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
|
||||
Nothing -> failWith UnsupportedMediaType
|
||||
Just (contentT, body) -> succeedWith $
|
||||
responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
|
||||
Left (status, message) -> succeedWith $
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| pathIsEmpty request && requestMethod request /= methodPost =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
||||
-- | When implementing the handler for a 'Put' endpoint,
|
||||
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
|
||||
-- and 'Servant.API.Post.Post', the handler code runs in the
|
||||
-- @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 use the type-level list, combined
|
||||
-- with the request's @Accept@ header, to encode the value for you
|
||||
-- (returning a status code of 200). If there was no @Accept@ header or it
|
||||
-- was @*/*@, we return encode using the first @Content-Type@ type on the
|
||||
-- list.
|
||||
instance ( AllCTRender ctypes a
|
||||
) => HasServer (Put ctypes a) where
|
||||
|
||||
type ServerT' (Put ctypes a) m = m a
|
||||
|
||||
route Proxy action request respond
|
||||
| pathIsEmpty request && requestMethod request == methodPut = do
|
||||
e <- runEitherT action
|
||||
respond $ case e of
|
||||
Right output -> do
|
||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
|
||||
Nothing -> failWith UnsupportedMediaType
|
||||
Just (contentT, body) -> succeedWith $
|
||||
responseLBS status200 [ ("Content-Type" , cs contentT)] body
|
||||
Left (status, message) -> succeedWith $
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| pathIsEmpty request && requestMethod request /= methodPut =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
||||
instance HasServer (Put ctypes ()) where
|
||||
type ServerT' (Put ctypes ()) m = m ()
|
||||
route Proxy action request respond
|
||||
| pathIsEmpty request && requestMethod request == methodPut = do
|
||||
e <- runEitherT action
|
||||
respond . succeedWith $ case e of
|
||||
Right () -> responseLBS noContent204 [] ""
|
||||
Left (status, message) ->
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| pathIsEmpty request && requestMethod request /= methodPut =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
||||
-- Add response headers
|
||||
instance ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where
|
||||
type ServerT' (Put ctypes (Headers h v)) m = m (Headers h v)
|
||||
route Proxy action request respond
|
||||
| pathIsEmpty request && requestMethod request == methodPut = do
|
||||
e <- runEitherT action
|
||||
respond $ case e of
|
||||
Right output -> do
|
||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
||||
headers = getHeaders output
|
||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
|
||||
Nothing -> failWith UnsupportedMediaType
|
||||
Just (contentT, body) -> succeedWith $
|
||||
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
|
||||
Left (status, message) -> succeedWith $
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| pathIsEmpty request && requestMethod request /= methodPut =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
||||
-- | When implementing the handler for a 'Patch' endpoint,
|
||||
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
|
||||
-- and 'Servant.API.Put.Put', the handler code runs in the
|
||||
-- @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 ( AllCTRender ctypes a
|
||||
) => HasServer (Patch ctypes a) where
|
||||
type ServerT' (Patch ctypes a) m = m a
|
||||
|
||||
route Proxy action request respond
|
||||
| pathIsEmpty request && requestMethod request == methodPatch = do
|
||||
e <- runEitherT action
|
||||
respond $ case e of
|
||||
Right output -> do
|
||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
|
||||
Nothing -> failWith UnsupportedMediaType
|
||||
Just (contentT, body) -> succeedWith $
|
||||
responseLBS status200 [ ("Content-Type" , cs contentT)] body
|
||||
Left (status, message) -> succeedWith $
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| pathIsEmpty request && requestMethod request /= methodPatch =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
||||
instance HasServer (Patch ctypes ()) where
|
||||
type ServerT' (Patch ctypes ()) m = m ()
|
||||
route Proxy action request respond
|
||||
| pathIsEmpty request && requestMethod request == methodPatch = do
|
||||
e <- runEitherT action
|
||||
respond . succeedWith $ case e of
|
||||
Right () -> responseLBS noContent204 [] ""
|
||||
Left (status, message) ->
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| pathIsEmpty request && requestMethod request /= methodPatch =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
||||
-- Add response headers
|
||||
instance ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where
|
||||
type ServerT' (Patch ctypes (Headers h v)) m = m (Headers h v)
|
||||
route Proxy action request respond
|
||||
| pathIsEmpty request && requestMethod request == methodPatch = do
|
||||
e <- runEitherT action
|
||||
respond $ case e of
|
||||
Right outpatch -> do
|
||||
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
|
||||
headers = getHeaders outpatch
|
||||
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of
|
||||
Nothing -> failWith UnsupportedMediaType
|
||||
Just (contentT, body) -> succeedWith $
|
||||
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
|
||||
Left (status, message) -> succeedWith $
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| pathIsEmpty request && requestMethod request /= methodPatch =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
||||
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
|
||||
-- this automatically requires your server-side handler to be a function
|
||||
-- that takes an argument of type @'Maybe' 'Text'@.
|
||||
--
|
||||
-- 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 '[JSON] [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 ServerT' (QueryParam sym a :> sublayout) m =
|
||||
Maybe a -> ServerT' sublayout m
|
||||
|
||||
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 '[JSON] [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 ServerT' (QueryParams sym a :> sublayout) m =
|
||||
[a] -> ServerT' sublayout m
|
||||
|
||||
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 '[JSON] [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 ServerT' (QueryFlag sym :> sublayout) m =
|
||||
Bool -> ServerT' sublayout m
|
||||
|
||||
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
|
||||
|
||||
parseMatrixText :: B.ByteString -> QueryText
|
||||
parseMatrixText = parseQueryText
|
||||
|
||||
-- | If you use @'MatrixParam' "author" Text@ in one of the endpoints for your API,
|
||||
-- this automatically requires your server-side handler to be a function
|
||||
-- that takes an argument of type @'Maybe' 'Text'@.
|
||||
--
|
||||
-- This lets servant worry about looking it up in the query string
|
||||
-- and turning it into a value of the type you specify, enclosed
|
||||
-- in 'Maybe', because it may not be there and servant would then
|
||||
-- hand you 'Nothing'.
|
||||
--
|
||||
-- You can control how it'll be converted from 'Text' to your type
|
||||
-- by simply providing an instance of 'FromText' for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> MatrixParam "author" Text :> Get [Book]
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = getBooksBy
|
||||
-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]
|
||||
-- > getBooksBy Nothing = ...return all books...
|
||||
-- > getBooksBy (Just author) = ...return books by the given author...
|
||||
instance (KnownSymbol sym, FromText a, HasServer sublayout)
|
||||
=> HasServer (MatrixParam sym a :> sublayout) where
|
||||
|
||||
type ServerT' (MatrixParam sym a :> sublayout) m =
|
||||
Maybe a -> ServerT' sublayout m
|
||||
|
||||
route Proxy subserver request respond = case parsePathInfo request of
|
||||
(first : _)
|
||||
-> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first
|
||||
param = case lookup paramname querytext of
|
||||
Nothing -> Nothing -- param absent from the query string
|
||||
Just Nothing -> Nothing -- param present with no value -> Nothing
|
||||
Just (Just v) -> fromText v -- if present, we try to convert to
|
||||
-- the right type
|
||||
route (Proxy :: Proxy sublayout) (subserver param) request respond
|
||||
_ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond
|
||||
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- | If you use @'MatrixParams' "authors" Text@ in one of the endpoints for your API,
|
||||
-- this automatically requires your server-side handler to be a function
|
||||
-- that takes an argument of type @['Text']@.
|
||||
--
|
||||
-- This lets servant worry about looking up 0 or more values in the query string
|
||||
-- associated to @authors@ and turning each of them into a value of
|
||||
-- the type you specify.
|
||||
--
|
||||
-- You can control how the individual values are converted from 'Text' to your type
|
||||
-- by simply providing an instance of 'FromText' for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> MatrixParams "authors" Text :> Get [Book]
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = getBooksBy
|
||||
-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]
|
||||
-- > getBooksBy authors = ...return all books by these authors...
|
||||
instance (KnownSymbol sym, FromText a, HasServer sublayout)
|
||||
=> HasServer (MatrixParams sym a :> sublayout) where
|
||||
|
||||
type ServerT' (MatrixParams sym a :> sublayout) m =
|
||||
[a] -> ServerT' sublayout m
|
||||
|
||||
route Proxy subserver request respond = case parsePathInfo request of
|
||||
(first : _)
|
||||
-> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
|
||||
-- if sym is "foo", we look for matrix parameters
|
||||
-- named "foo" or "foo[]" and call fromText on the
|
||||
-- corresponding values
|
||||
parameters = filter looksLikeParam matrixtext
|
||||
values = catMaybes $ map (convert . snd) parameters
|
||||
route (Proxy :: Proxy sublayout) (subserver values) request respond
|
||||
_ -> route (Proxy :: Proxy sublayout) (subserver []) request respond
|
||||
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
|
||||
convert Nothing = Nothing
|
||||
convert (Just v) = fromText v
|
||||
|
||||
-- | If you use @'MatrixFlag' "published"@ in one of the endpoints for your API,
|
||||
-- this automatically requires your server-side handler to be a function
|
||||
-- that takes an argument of type 'Bool'.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> MatrixFlag "published" :> Get [Book]
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = getBooks
|
||||
-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book]
|
||||
-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
|
||||
instance (KnownSymbol sym, HasServer sublayout)
|
||||
=> HasServer (MatrixFlag sym :> sublayout) where
|
||||
|
||||
type ServerT' (MatrixFlag sym :> sublayout) m =
|
||||
Bool -> ServerT' sublayout m
|
||||
|
||||
route Proxy subserver request respond = case parsePathInfo request of
|
||||
(first : _)
|
||||
-> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
|
||||
param = case lookup paramname matrixtext of
|
||||
Just Nothing -> True -- param is there, with no value
|
||||
Just (Just v) -> examine v -- param with a value
|
||||
Nothing -> False -- param not in the query string
|
||||
|
||||
route (Proxy :: Proxy sublayout) (subserver param) request respond
|
||||
|
||||
_ -> route (Proxy :: Proxy sublayout) (subserver False) request respond
|
||||
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
examine v | v == "true" || v == "1" || v == "" = True
|
||||
| otherwise = False
|
||||
|
||||
-- | Just pass the request to the underlying application and serve its response.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "images" :> Raw
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = serveDirectory "/var/www/images"
|
||||
instance HasServer Raw where
|
||||
|
||||
type ServerT' Raw m = 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'.
|
||||
-- The @Content-Type@ header is inspected, and the list provided is used to
|
||||
-- attempt deserialization. If the request does not have a @Content-Type@
|
||||
-- header, it is treated as @application/octet-stream@.
|
||||
-- This lets servant worry about extracting it from the request and turning
|
||||
-- it into a value of the type you specify.
|
||||
--
|
||||
--
|
||||
-- All it asks is for a 'FromJSON' instance.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = postBook
|
||||
-- > where postBook :: Book -> EitherT (Int, String) IO Book
|
||||
-- > postBook book = ...insert into your db...
|
||||
instance ( AllCTUnrender list a, HasServer sublayout
|
||||
) => HasServer (ReqBody list a :> sublayout) where
|
||||
|
||||
type ServerT' (ReqBody list a :> sublayout) m =
|
||||
a -> ServerT' sublayout m
|
||||
|
||||
route Proxy subserver request respond = do
|
||||
-- See HTTP RFC 2616, section 7.2.1
|
||||
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
|
||||
-- See also "W3C Internet Media Type registration, consistency of use"
|
||||
-- http://www.w3.org/2001/tag/2002/0129-mime
|
||||
let contentTypeH = fromMaybe "application/octet-stream"
|
||||
$ lookup hContentType $ requestHeaders request
|
||||
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
|
||||
<$> lazyRequestBody request
|
||||
case mrqbody of
|
||||
Nothing -> respond . failWith $ UnsupportedMediaType
|
||||
Just (Left e) -> respond . failWith $ InvalidBody e
|
||||
Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond
|
||||
|
||||
-- | Make sure the incoming request starts with @"/path"@, strip it and
|
||||
-- pass the rest of the request path to @sublayout@.
|
||||
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
|
||||
|
||||
type ServerT' (path :> sublayout) m = ServerT' sublayout m
|
||||
|
||||
route Proxy subserver request respond = case processedPathInfo 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
servant-server/src/Servant/Utils/StaticFiles.hs
Normal file
36
servant-server/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 (staticApp, defaultFileServerSettings)
|
||||
import Servant.API.Raw (Raw)
|
||||
import Servant.Server (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 ++ "/")))
|
||||
619
servant-server/test/Servant/ServerSpec.hs
Normal file
619
servant-server/test/Servant/ServerSpec.hs
Normal file
|
|
@ -0,0 +1,619 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
module Servant.ServerSpec where
|
||||
|
||||
|
||||
import Control.Monad (forM_, when)
|
||||
import Control.Monad.Trans.Either (EitherT, left)
|
||||
import Data.Aeson (FromJSON, ToJSON, decode', encode)
|
||||
import Data.ByteString.Conversion ()
|
||||
import Data.Char (toUpper)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Types (hAccept, hContentType,
|
||||
methodDelete, methodGet,
|
||||
methodPatch, methodPost, methodPut,
|
||||
ok200, parseQuery, status409)
|
||||
import Network.Wai (Application, Request, pathInfo,
|
||||
queryString, rawQueryString,
|
||||
responseLBS)
|
||||
import Network.Wai.Test (defaultRequest, request,
|
||||
runSession, simpleBody)
|
||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||
import Test.Hspec.Wai (get, liftIO, matchHeaders,
|
||||
matchStatus, post, request,
|
||||
shouldRespondWith, with, (<:>))
|
||||
|
||||
import Servant.API ((:<|>) (..), (:>),
|
||||
AddHeader (addHeader), Capture,
|
||||
Delete, Get, Header (..), Headers,
|
||||
JSON, MatrixFlag, MatrixParam,
|
||||
MatrixParams, Patch, PlainText,
|
||||
Post, Put, QueryFlag, QueryParam,
|
||||
QueryParams, Raw, ReqBody)
|
||||
import Servant.Server (Server, serve)
|
||||
import Servant.Server.Internal (RouteMismatch (..))
|
||||
|
||||
|
||||
-- * 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
|
||||
postSpec
|
||||
putSpec
|
||||
patchSpec
|
||||
queryParamSpec
|
||||
matrixParamSpec
|
||||
headerSpec
|
||||
rawSpec
|
||||
unionSpec
|
||||
errorsSpec
|
||||
responseHeadersSpec
|
||||
|
||||
|
||||
type CaptureApi = Capture "legs" Integer :> Get '[JSON] 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 $ decode' (simpleBody response) `shouldBe` Just tweety
|
||||
|
||||
it "returns 404 if the decoding fails" $ do
|
||||
get "/notAnInt" `shouldRespondWith` 404
|
||||
|
||||
with (return (serve
|
||||
(Proxy :: Proxy (Capture "captured" String :> Raw))
|
||||
(\ "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 '[JSON] Person
|
||||
:<|> "empty" :> Get '[] ()
|
||||
getApi :: Proxy GetApi
|
||||
getApi = Proxy
|
||||
|
||||
getSpec :: Spec
|
||||
getSpec = do
|
||||
describe "Servant.API.Get" $ do
|
||||
let server = return alice :<|> return ()
|
||||
with (return $ serve getApi server) $ do
|
||||
|
||||
it "allows to GET a Person" $ do
|
||||
response <- get "/"
|
||||
return response `shouldRespondWith` 200
|
||||
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
|
||||
|
||||
it "throws 405 (wrong method) on POSTs" $ do
|
||||
post "/" "" `shouldRespondWith` 405
|
||||
post "/empty" "" `shouldRespondWith` 405
|
||||
|
||||
it "returns 204 if the type is '()'" $ do
|
||||
get "empty" `shouldRespondWith` ""{ matchStatus = 204 }
|
||||
|
||||
it "returns 415 if the Accept header is not supported" $ do
|
||||
Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
|
||||
`shouldRespondWith` 415
|
||||
|
||||
|
||||
|
||||
type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
|
||||
:<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
|
||||
:<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] 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"
|
||||
}
|
||||
|
||||
let params3'' = "?unknown="
|
||||
response3' <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params3'',
|
||||
queryString = parseQuery params3'',
|
||||
pathInfo = ["b"]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response3') `shouldBe` Just alice{
|
||||
name = "Alice"
|
||||
}
|
||||
|
||||
type MatrixParamApi = "a" :> MatrixParam "name" String :> Get '[JSON] Person
|
||||
:<|> "b" :> MatrixParams "names" String :> "bsub" :> MatrixParams "names" String :> Get '[JSON] Person
|
||||
:<|> "c" :> MatrixFlag "capitalize" :> Get '[JSON] Person
|
||||
:<|> "d" :> Capture "foo" Integer :> MatrixParam "name" String :> MatrixFlag "capitalize" :> "dsub" :> Get '[JSON] Person
|
||||
|
||||
matrixParamApi :: Proxy MatrixParamApi
|
||||
matrixParamApi = Proxy
|
||||
|
||||
mpServer :: Server MatrixParamApi
|
||||
mpServer = matrixParamServer :<|> mpNames :<|> mpCapitalize alice :<|> mpComplex
|
||||
where mpNames (_:name2:_) _ = return alice { name = name2 }
|
||||
mpNames _ _ = return alice
|
||||
|
||||
mpCapitalize p False = return p
|
||||
mpCapitalize p True = return p { name = map toUpper (name p) }
|
||||
|
||||
matrixParamServer (Just name) = return alice{name = name}
|
||||
matrixParamServer Nothing = return alice
|
||||
|
||||
mpAge age p = return p { age = age }
|
||||
mpComplex capture name cap = matrixParamServer name >>= flip mpCapitalize cap >>= mpAge capture
|
||||
|
||||
matrixParamSpec :: Spec
|
||||
matrixParamSpec = do
|
||||
describe "Servant.API.MatrixParam" $ do
|
||||
it "allows to retrieve simple matrix parameters" $
|
||||
(flip runSession) (serve matrixParamApi mpServer) $ do
|
||||
response1 <- Network.Wai.Test.request defaultRequest{
|
||||
pathInfo = ["a;name=bob"]
|
||||
}
|
||||
liftIO $ do
|
||||
decode' (simpleBody response1) `shouldBe` Just alice{
|
||||
name = "bob"
|
||||
}
|
||||
|
||||
it "allows to retrieve lists in matrix parameters" $
|
||||
(flip runSession) (serve matrixParamApi mpServer) $ do
|
||||
response2 <- Network.Wai.Test.request defaultRequest{
|
||||
pathInfo = ["b;names=bob;names=john", "bsub;names=anna;names=sarah"]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response2) `shouldBe` Just alice{
|
||||
name = "john"
|
||||
}
|
||||
|
||||
it "allows to retrieve value-less matrix parameters" $
|
||||
(flip runSession) (serve matrixParamApi mpServer) $ do
|
||||
response3 <- Network.Wai.Test.request defaultRequest{
|
||||
pathInfo = ["c;capitalize"]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response3) `shouldBe` Just alice{
|
||||
name = "ALICE"
|
||||
}
|
||||
|
||||
response3' <- Network.Wai.Test.request defaultRequest{
|
||||
pathInfo = ["c;capitalize="]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response3') `shouldBe` Just alice{
|
||||
name = "ALICE"
|
||||
}
|
||||
|
||||
it "allows to retrieve matrix parameters on captured segments" $
|
||||
(flip runSession) (serve matrixParamApi mpServer) $ do
|
||||
response4 <- Network.Wai.Test.request defaultRequest{
|
||||
pathInfo = ["d", "12;name=stephen;capitalize", "dsub"]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response4) `shouldBe` Just alice{
|
||||
name = "STEPHEN",
|
||||
age = 12
|
||||
}
|
||||
|
||||
response4' <- Network.Wai.Test.request defaultRequest{
|
||||
pathInfo = ["d;ignored=1", "5", "dsub"]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response4') `shouldBe` Just alice{
|
||||
name = "Alice",
|
||||
age = 5
|
||||
}
|
||||
|
||||
type PostApi =
|
||||
ReqBody '[JSON] Person :> Post '[JSON] Integer
|
||||
:<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
|
||||
:<|> "empty" :> Post '[] ()
|
||||
|
||||
postApi :: Proxy PostApi
|
||||
postApi = Proxy
|
||||
|
||||
postSpec :: Spec
|
||||
postSpec = do
|
||||
describe "Servant.API.Post and .ReqBody" $ do
|
||||
let server = return . age :<|> return . age :<|> return ()
|
||||
with (return $ serve postApi server) $ do
|
||||
let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
|
||||
, "application/json;charset=utf-8")]
|
||||
|
||||
it "allows to POST a Person" $ do
|
||||
post' "/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 201
|
||||
}
|
||||
|
||||
it "allows alternative routes if all have request bodies" $ do
|
||||
post' "/bla" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 201
|
||||
}
|
||||
|
||||
it "handles trailing '/' gracefully" $ do
|
||||
post' "/bla/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 201
|
||||
}
|
||||
|
||||
it "correctly rejects invalid request bodies with status 400" $ do
|
||||
post' "/" "some invalid body" `shouldRespondWith` 400
|
||||
|
||||
it "returns 204 if the type is '()'" $ do
|
||||
post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
|
||||
|
||||
it "responds with 415 if the requested media type is unsupported" $ do
|
||||
let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
|
||||
, "application/nonsense")]
|
||||
post'' "/" "anything at all" `shouldRespondWith` 415
|
||||
|
||||
type PutApi =
|
||||
ReqBody '[JSON] Person :> Put '[JSON] Integer
|
||||
:<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
|
||||
:<|> "empty" :> Put '[] ()
|
||||
|
||||
putApi :: Proxy PutApi
|
||||
putApi = Proxy
|
||||
|
||||
putSpec :: Spec
|
||||
putSpec = do
|
||||
describe "Servant.API.Put and .ReqBody" $ do
|
||||
let server = return . age :<|> return . age :<|> return ()
|
||||
with (return $ serve putApi server) $ do
|
||||
let put' x = Test.Hspec.Wai.request methodPut x [(hContentType
|
||||
, "application/json;charset=utf-8")]
|
||||
|
||||
it "allows to put a Person" $ do
|
||||
put' "/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "allows alternative routes if all have request bodies" $ do
|
||||
put' "/bla" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "handles trailing '/' gracefully" $ do
|
||||
put' "/bla/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "correctly rejects invalid request bodies with status 400" $ do
|
||||
put' "/" "some invalid body" `shouldRespondWith` 400
|
||||
|
||||
it "returns 204 if the type is '()'" $ do
|
||||
put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
|
||||
|
||||
it "responds with 415 if the requested media type is unsupported" $ do
|
||||
let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType
|
||||
, "application/nonsense")]
|
||||
put'' "/" "anything at all" `shouldRespondWith` 415
|
||||
|
||||
type PatchApi =
|
||||
ReqBody '[JSON] Person :> Patch '[JSON] Integer
|
||||
:<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer
|
||||
:<|> "empty" :> Patch '[] ()
|
||||
|
||||
patchApi :: Proxy PatchApi
|
||||
patchApi = Proxy
|
||||
|
||||
patchSpec :: Spec
|
||||
patchSpec = do
|
||||
describe "Servant.API.Patch and .ReqBody" $ do
|
||||
let server = return . age :<|> return . age :<|> return ()
|
||||
with (return $ serve patchApi server) $ do
|
||||
let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType
|
||||
, "application/json;charset=utf-8")]
|
||||
|
||||
it "allows to patch a Person" $ do
|
||||
patch' "/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "allows alternative routes if all have request bodies" $ do
|
||||
patch' "/bla" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "handles trailing '/' gracefully" $ do
|
||||
patch' "/bla/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "correctly rejects invalid request bodies with status 400" $ do
|
||||
patch' "/" "some invalid body" `shouldRespondWith` 400
|
||||
|
||||
it "returns 204 if the type is '()'" $ do
|
||||
patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
|
||||
|
||||
it "responds with 415 if the requested media type is unsupported" $ do
|
||||
let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
|
||||
, "application/nonsense")]
|
||||
patch'' "/" "anything at all" `shouldRespondWith` 415
|
||||
|
||||
type HeaderApi a = Header "MyHeader" a :> Delete
|
||||
headerApi :: Proxy (HeaderApi a)
|
||||
headerApi = Proxy
|
||||
|
||||
headerSpec :: Spec
|
||||
headerSpec = describe "Servant.API.Header" $ do
|
||||
|
||||
let expectsInt :: Maybe Int -> EitherT (Int,String) IO ()
|
||||
expectsInt (Just x) = when (x /= 5) $ error "Expected 5"
|
||||
expectsInt Nothing = error "Expected an int"
|
||||
|
||||
let expectsString :: Maybe String -> EitherT (Int,String) IO ()
|
||||
expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
|
||||
expectsString Nothing = error "Expected a string"
|
||||
|
||||
with (return (serve headerApi expectsInt)) $ do
|
||||
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")]
|
||||
|
||||
it "passes the header to the handler (Int)" $
|
||||
delete' "/" "" `shouldRespondWith` 204
|
||||
|
||||
with (return (serve headerApi expectsString)) $ do
|
||||
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")]
|
||||
|
||||
it "passes the header to the handler (String)" $
|
||||
delete' "/" "" `shouldRespondWith` 204
|
||||
|
||||
|
||||
type RawApi = "foo" :> Raw
|
||||
rawApi :: Proxy RawApi
|
||||
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 '[JSON] Person
|
||||
:<|> "bar" :> Get '[JSON] Animal
|
||||
:<|> "foo" :> Get '[PlainText] T.Text
|
||||
:<|> "bar" :> Post '[JSON] Animal
|
||||
:<|> "bar" :> Put '[JSON] Animal
|
||||
:<|> "bar" :> Delete
|
||||
unionApi :: Proxy AlternativeApi
|
||||
unionApi = Proxy
|
||||
|
||||
unionServer :: Server AlternativeApi
|
||||
unionServer =
|
||||
return alice
|
||||
:<|> return jerry
|
||||
:<|> return "a string"
|
||||
:<|> return jerry
|
||||
:<|> return jerry
|
||||
:<|> return ()
|
||||
|
||||
unionSpec :: Spec
|
||||
unionSpec = do
|
||||
describe "Servant.API.Alternative" $ do
|
||||
with (return $ serve unionApi unionServer) $ do
|
||||
|
||||
it "unions endpoints" $ do
|
||||
response <- get "/foo"
|
||||
liftIO $ do
|
||||
decode' (simpleBody response) `shouldBe`
|
||||
Just alice
|
||||
response_ <- get "/bar"
|
||||
liftIO $ do
|
||||
decode' (simpleBody response_) `shouldBe`
|
||||
Just jerry
|
||||
|
||||
it "checks all endpoints before returning 415" $ do
|
||||
get "/foo" `shouldRespondWith` 200
|
||||
|
||||
it "returns 404 if the path does not exist" $ do
|
||||
get "/nonexistent" `shouldRespondWith` 404
|
||||
|
||||
type ResponseHeadersApi =
|
||||
Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
|
||||
:<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
|
||||
:<|> Put '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
|
||||
:<|> Patch '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
|
||||
|
||||
|
||||
responseHeadersServer :: Server ResponseHeadersApi
|
||||
responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"
|
||||
in h :<|> h :<|> h :<|> h
|
||||
|
||||
|
||||
responseHeadersSpec :: Spec
|
||||
responseHeadersSpec = describe "ResponseHeaders" $ do
|
||||
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do
|
||||
|
||||
let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)]
|
||||
|
||||
it "includes the headers in the response" $
|
||||
forM_ methods $ \(method, expected) ->
|
||||
Test.Hspec.Wai.request method "/" [] ""
|
||||
`shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]
|
||||
, matchStatus = expected
|
||||
}
|
||||
|
||||
it "responds with not found for non-existent endpoints" $
|
||||
forM_ methods $ \(method,_) ->
|
||||
Test.Hspec.Wai.request method "blahblah" [] ""
|
||||
`shouldRespondWith` 404
|
||||
|
||||
it "returns 415 if the Accept header is not supported" $
|
||||
forM_ methods $ \(method,_) ->
|
||||
Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
|
||||
`shouldRespondWith` 415
|
||||
|
||||
|
||||
-- | Test server error functionality.
|
||||
errorsSpec :: Spec
|
||||
errorsSpec = do
|
||||
let he = HttpError status409 (Just "A custom error")
|
||||
let ib = InvalidBody "The body is invalid"
|
||||
let wm = WrongMethod
|
||||
let nf = NotFound
|
||||
|
||||
describe "Servant.Server.Internal.RouteMismatch" $ do
|
||||
it "HttpError > *" $ do
|
||||
ib <> he `shouldBe` he
|
||||
wm <> he `shouldBe` he
|
||||
nf <> he `shouldBe` he
|
||||
|
||||
he <> ib `shouldBe` he
|
||||
he <> wm `shouldBe` he
|
||||
he <> nf `shouldBe` he
|
||||
|
||||
it "HE > InvalidBody > (WM,NF)" $ do
|
||||
he <> ib `shouldBe` he
|
||||
wm <> ib `shouldBe` ib
|
||||
nf <> ib `shouldBe` ib
|
||||
|
||||
ib <> he `shouldBe` he
|
||||
ib <> wm `shouldBe` ib
|
||||
ib <> nf `shouldBe` ib
|
||||
|
||||
it "HE > IB > WrongMethod > NF" $ do
|
||||
he <> wm `shouldBe` he
|
||||
ib <> wm `shouldBe` ib
|
||||
nf <> wm `shouldBe` wm
|
||||
|
||||
wm <> he `shouldBe` he
|
||||
wm <> ib `shouldBe` ib
|
||||
wm <> nf `shouldBe` wm
|
||||
|
||||
it "* > NotFound" $ do
|
||||
he <> nf `shouldBe` he
|
||||
ib <> nf `shouldBe` ib
|
||||
wm <> nf `shouldBe` wm
|
||||
|
||||
nf <> he `shouldBe` he
|
||||
nf <> ib `shouldBe` ib
|
||||
nf <> wm `shouldBe` wm
|
||||
65
servant-server/test/Servant/Utils/StaticFilesSpec.hs
Normal file
65
servant-server/test/Servant/Utils/StaticFilesSpec.hs
Normal file
|
|
@ -0,0 +1,65 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Servant.Utils.StaticFilesSpec where
|
||||
|
||||
import Control.Exception (bracket)
|
||||
import Data.Proxy (Proxy(Proxy))
|
||||
import Network.Wai (Application)
|
||||
import System.Directory (getCurrentDirectory, setCurrentDirectory, createDirectory)
|
||||
import System.IO.Temp (withSystemTempDirectory)
|
||||
import Test.Hspec (Spec, describe, it, around_)
|
||||
import Test.Hspec.Wai (with, get, shouldRespondWith)
|
||||
|
||||
import Servant.API (JSON)
|
||||
import Servant.API.Alternative ((:<|>)((:<|>)))
|
||||
import Servant.API.Capture (Capture)
|
||||
import Servant.API.Get (Get)
|
||||
import Servant.API.Raw (Raw)
|
||||
import Servant.API.Sub ((:>))
|
||||
import Servant.Server (Server, serve)
|
||||
import Servant.ServerSpec (Person(Person))
|
||||
import Servant.Utils.StaticFiles (serveDirectory)
|
||||
|
||||
type Api =
|
||||
"dummy_api" :> Capture "person_name" String :> Get '[JSON] 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
servant-server/test/Spec.hs
Normal file
1
servant-server/test/Spec.hs
Normal file
|
|
@ -0,0 +1 @@
|
|||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
Loading…
Reference in a new issue