Built from d9d94e6f4e
This commit is contained in:
Alp Mestanogullari
parent
d9d94e6f4e
commit
cec89c1cd0
28 changed files with 0 additions and 2039 deletions
30
LICENSE
30
LICENSE
|
|
@ -1,30 +0,0 @@
|
|||
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.
|
||||
2
Setup.hs
2
Setup.hs
|
|
@ -1,2 +0,0 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
- `greet.hs` shows how to write a simple webservice, run it, query it with automatically-derived haskell functions and print the (generated) markdown documentation for the API.
|
||||
- `greet.md` contains the aforementionned generated documentation.
|
||||
|
|
@ -1,72 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Monoid
|
||||
import Data.Proxy
|
||||
import Data.Text
|
||||
import GHC.Generics
|
||||
import Network.Wai
|
||||
import Network.Wai.Handler.Warp
|
||||
|
||||
import Servant
|
||||
|
||||
-- * Example
|
||||
|
||||
-- | A greet message data type
|
||||
newtype Greet = Greet { msg :: Text }
|
||||
deriving (Generic, Show)
|
||||
|
||||
instance FromJSON Greet
|
||||
instance ToJSON Greet
|
||||
|
||||
-- API specification
|
||||
type TestApi =
|
||||
-- GET /hello/:name?capital={true, false} returns a Greet as JSON
|
||||
"hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
|
||||
|
||||
-- POST /greet with a Greet as JSON in the request body,
|
||||
-- returns a Greet as JSON
|
||||
:<|> "greet" :> ReqBody Greet :> Post Greet
|
||||
|
||||
-- DELETE /greet/:greetid
|
||||
:<|> "greet" :> Capture "greetid" Text :> Delete
|
||||
|
||||
testApi :: Proxy TestApi
|
||||
testApi = Proxy
|
||||
|
||||
-- Server-side handlers.
|
||||
--
|
||||
-- There's one handler per endpoint, which, just like in the type
|
||||
-- that represents the API, are glued together using :<|>.
|
||||
--
|
||||
-- Each handler runs in the 'EitherT (Int, String) IO' monad.
|
||||
server :: Server TestApi
|
||||
server = helloH :<|> postGreetH :<|> deleteGreetH
|
||||
|
||||
where helloH name Nothing = helloH name (Just False)
|
||||
helloH name (Just False) = return . Greet $ "Hello, " <> name
|
||||
helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
|
||||
|
||||
postGreetH greet = return greet
|
||||
|
||||
deleteGreetH _ = return ()
|
||||
|
||||
-- Turn the server into a WAI app. 'serve' is provided by servant,
|
||||
-- more precisely by the Servant.Server module.
|
||||
test :: Application
|
||||
test = serve testApi server
|
||||
|
||||
-- Run the server.
|
||||
--
|
||||
-- 'run' comes from Network.Wai.Handler.Warp
|
||||
runTestServer :: Port -> IO ()
|
||||
runTestServer port = run port test
|
||||
|
||||
-- Put this all to work!
|
||||
main :: IO ()
|
||||
main = runTestServer 8001
|
||||
|
|
@ -1,52 +0,0 @@
|
|||
POST /greet
|
||||
-----------
|
||||
|
||||
**Request Body**:
|
||||
|
||||
``` javascript
|
||||
{"msg":"Hello, haskeller!"}
|
||||
```
|
||||
|
||||
**Response**:
|
||||
|
||||
- Status code 201
|
||||
- Response body as below.
|
||||
|
||||
``` javascript
|
||||
{"msg":"Hello, haskeller!"}
|
||||
```
|
||||
|
||||
GET /hello/:name
|
||||
----------------
|
||||
|
||||
**Captures**:
|
||||
|
||||
- *name*: name of the person to greet
|
||||
|
||||
**GET Parameters**:
|
||||
|
||||
- capital
|
||||
- **Values**: *true, false*
|
||||
- **Description**: Get the greeting message in uppercase (true) or not (false). Default is false.
|
||||
|
||||
|
||||
**Response**:
|
||||
|
||||
- Status code 200
|
||||
- Response body as below.
|
||||
|
||||
``` javascript
|
||||
{"msg":"Hello, haskeller!"}
|
||||
```
|
||||
|
||||
DELETE /greet/:greetid
|
||||
----------------------
|
||||
|
||||
**Captures**:
|
||||
|
||||
- *greetid*: identifier of the greet msg to remove
|
||||
|
||||
**Response**:
|
||||
|
||||
- Status code 204
|
||||
- No response body
|
||||
|
|
@ -1,97 +0,0 @@
|
|||
name: servant
|
||||
version: 0.2
|
||||
-- synopsis:
|
||||
-- description:
|
||||
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
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Servant
|
||||
Servant.API
|
||||
Servant.API.Alternative
|
||||
Servant.API.Capture
|
||||
Servant.API.Delete
|
||||
Servant.API.Get
|
||||
Servant.API.Post
|
||||
Servant.API.Put
|
||||
Servant.API.QueryParam
|
||||
Servant.API.Raw
|
||||
Servant.API.ReqBody
|
||||
Servant.API.Sub
|
||||
Servant.Common.Text
|
||||
Servant.QQ
|
||||
Servant.Server
|
||||
Servant.Utils.Links
|
||||
Servant.Utils.StaticFiles
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, aeson
|
||||
, attoparsec
|
||||
, bytestring
|
||||
, either
|
||||
, http-types
|
||||
, network-uri >= 2.6
|
||||
, parsec
|
||||
, safe
|
||||
, split
|
||||
, string-conversions
|
||||
, system-filepath
|
||||
, template-haskell
|
||||
, text
|
||||
, transformers
|
||||
, wai
|
||||
, wai-app-static
|
||||
, warp
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -O0 -Wall
|
||||
|
||||
executable greet
|
||||
main-is: greet.hs
|
||||
hs-source-dirs: example
|
||||
ghc-options: -O0 -Wall
|
||||
default-language: Haskell2010
|
||||
build-depends:
|
||||
base
|
||||
, servant
|
||||
, 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
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
module Servant (
|
||||
-- | This module and its submodules can be used to define servant APIs. Note
|
||||
-- that these API definitions don't directly implement a server (or anything
|
||||
-- else).
|
||||
module Servant.API,
|
||||
-- | For implementing servers for servant APIs.
|
||||
module Servant.Server,
|
||||
-- | Using your types in request paths and query string parameters
|
||||
module Servant.Common.Text,
|
||||
-- | Utilities on top of the servant core
|
||||
module Servant.QQ,
|
||||
module Servant.Utils.Links,
|
||||
module Servant.Utils.StaticFiles,
|
||||
-- | Useful re-exports
|
||||
Proxy(..),
|
||||
) where
|
||||
|
||||
import Data.Proxy
|
||||
import Servant.API
|
||||
import Servant.Common.Text
|
||||
import Servant.Server
|
||||
import Servant.QQ
|
||||
import Servant.Utils.Links
|
||||
import Servant.Utils.StaticFiles
|
||||
|
|
@ -1,51 +0,0 @@
|
|||
module Servant.API (
|
||||
|
||||
-- * Combinators
|
||||
-- | Type-level combinator for expressing subrouting: @':>'@
|
||||
module Servant.API.Sub,
|
||||
-- | Type-level combinator for alternative endpoints: @':<|>'@
|
||||
module Servant.API.Alternative,
|
||||
|
||||
-- * Accessing information from the request
|
||||
-- | Capturing parts of the url path as parsed values: @'Capture'@
|
||||
module Servant.API.Capture,
|
||||
-- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@
|
||||
module Servant.API.QueryParam,
|
||||
-- | Accessing the request body as a JSON-encoded type: @'ReqBody'@
|
||||
module Servant.API.ReqBody,
|
||||
|
||||
-- * Actual endpoints, distinguished by HTTP method
|
||||
-- | GET requests
|
||||
module Servant.API.Get,
|
||||
-- | POST requests
|
||||
module Servant.API.Post,
|
||||
-- | DELETE requests
|
||||
module Servant.API.Delete,
|
||||
-- | PUT requests
|
||||
module Servant.API.Put,
|
||||
|
||||
-- * Untyped endpoints
|
||||
-- | Plugging in a wai 'Network.Wai.Application', serving directories
|
||||
module Servant.API.Raw,
|
||||
module Servant.Utils.StaticFiles,
|
||||
|
||||
-- * Utilities
|
||||
-- | QuasiQuotes for endpoints
|
||||
module Servant.QQ,
|
||||
-- | Type-safe internal URLs
|
||||
module Servant.Utils.Links,
|
||||
) where
|
||||
|
||||
import Servant.API.Alternative
|
||||
import Servant.API.Capture
|
||||
import Servant.API.Delete
|
||||
import Servant.API.Get
|
||||
import Servant.API.Post
|
||||
import Servant.API.Put
|
||||
import Servant.API.QueryParam
|
||||
import Servant.API.Raw
|
||||
import Servant.API.ReqBody
|
||||
import Servant.API.Sub
|
||||
import Servant.QQ (sitemap)
|
||||
import Servant.Utils.Links (mkLink)
|
||||
import Servant.Utils.StaticFiles
|
||||
|
|
@ -1,39 +0,0 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Servant.API.Alternative where
|
||||
|
||||
import Data.Monoid
|
||||
import Data.Proxy
|
||||
import Servant.Server
|
||||
|
||||
-- | Union of two APIs, first takes precedence in case of overlap.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> Get [Book] -- GET /books
|
||||
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
|
||||
data a :<|> b = a :<|> b
|
||||
infixr 8 :<|>
|
||||
|
||||
-- | A server for @a ':<|>' b@ first tries to match the request again the route
|
||||
-- represented by @a@ and if it fails tries @b@. You must provide a request
|
||||
-- handler for each route.
|
||||
--
|
||||
-- > type MyApi = "books" :> Get [Book] -- GET /books
|
||||
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = listAllBooks :<|> postBook
|
||||
-- > where listAllBooks = ...
|
||||
-- > postBook book = ...
|
||||
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
|
||||
type Server (a :<|> b) = Server a :<|> Server b
|
||||
route Proxy (a :<|> b) request respond =
|
||||
route pa a request $ \ mResponse ->
|
||||
if isMismatch mResponse
|
||||
then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
|
||||
else respond mResponse
|
||||
|
||||
where pa = Proxy :: Proxy a
|
||||
pb = Proxy :: Proxy b
|
||||
|
|
@ -1,60 +0,0 @@
|
|||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Servant.API.Capture (Capture) where
|
||||
|
||||
import Data.Proxy
|
||||
import Data.Text
|
||||
import GHC.TypeLits
|
||||
import Network.Wai
|
||||
import Servant.API.Sub
|
||||
import Servant.Common.Text
|
||||
import Servant.Server
|
||||
|
||||
-- | Capture a value from the request path under a certain type @a@.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > -- GET /books/:isbn
|
||||
-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book
|
||||
data Capture sym a
|
||||
|
||||
captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
|
||||
captured _ = fromText
|
||||
|
||||
-- | If you use 'Capture' in one of the endpoints for your API,
|
||||
-- this automatically requires your server-side handler to be a function
|
||||
-- that takes an argument of the type specified by the 'Capture'.
|
||||
-- This lets servant worry about getting it from the URL and turning
|
||||
-- it into a value of the type you specify.
|
||||
--
|
||||
-- You can control how it'll be converted from 'Text' to your type
|
||||
-- by simply providing an instance of 'FromText' for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = getBook
|
||||
-- > where getBook :: Text -> EitherT (Int, String) IO Book
|
||||
-- > getBook isbn = ...
|
||||
instance (KnownSymbol capture, FromText a, HasServer sublayout)
|
||||
=> HasServer (Capture capture a :> sublayout) where
|
||||
|
||||
type Server (Capture capture a :> sublayout) =
|
||||
a -> Server sublayout
|
||||
|
||||
route Proxy subserver request respond = case pathInfo request of
|
||||
(first : rest)
|
||||
-> case captured captureProxy first of
|
||||
Nothing -> respond $ failWith NotFound
|
||||
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{
|
||||
pathInfo = rest
|
||||
} respond
|
||||
_ -> respond $ failWith NotFound
|
||||
|
||||
where captureProxy = Proxy :: Proxy (Capture capture a)
|
||||
|
|
@ -1,48 +0,0 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
module Servant.API.Delete where
|
||||
|
||||
import Control.Monad.Trans.Either
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
import Data.Typeable
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Servant.Server
|
||||
|
||||
-- | Combinator for DELETE requests.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > -- DELETE /books/:isbn
|
||||
-- > type MyApi = "books" :> Capture "isbn" Text :> Delete
|
||||
data Delete
|
||||
deriving Typeable
|
||||
|
||||
-- | If you have a 'Delete' endpoint in your API,
|
||||
-- the handler for this endpoint is meant to delete
|
||||
-- a resource.
|
||||
--
|
||||
-- The code of the handler will, just like
|
||||
-- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and
|
||||
-- 'Servant.API.Put.Put', run in @EitherT (Int, String) IO ()@.
|
||||
-- The 'Int' represents the status code and the 'String' a message
|
||||
-- to be returned. You can use 'Control.Monad.Trans.Either.left' to
|
||||
-- painlessly error out if the conditions for a successful deletion
|
||||
-- are not met.
|
||||
instance HasServer Delete where
|
||||
type Server Delete = EitherT (Int, String) IO ()
|
||||
|
||||
route Proxy action request respond
|
||||
| null (pathInfo request) && requestMethod request == methodDelete = do
|
||||
e <- runEitherT action
|
||||
respond $ succeedWith $ case e of
|
||||
Right () ->
|
||||
responseLBS status204 [] ""
|
||||
Left (status, message) ->
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| null (pathInfo request) && requestMethod request /= methodDelete =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
module Servant.API.Get where
|
||||
|
||||
import Control.Monad.Trans.Either
|
||||
import Data.Aeson
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
import Data.Typeable
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Servant.Server
|
||||
|
||||
-- | Endpoint for simple GET requests. Serves the result as JSON.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> Get [Book]
|
||||
data Get a
|
||||
deriving Typeable
|
||||
|
||||
-- | When implementing the handler for a 'Get' endpoint,
|
||||
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
|
||||
-- and 'Servant.API.Put.Put', the handler code runs in the
|
||||
-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
|
||||
-- the status code and the 'String' a message, returned in case of
|
||||
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
|
||||
-- to quickly fail if some conditions are not met.
|
||||
--
|
||||
-- If successfully returning a value, we just require that its type has
|
||||
-- a 'ToJSON' instance and servant takes care of encoding it for you,
|
||||
-- yielding status code 200 along the way.
|
||||
instance ToJSON result => HasServer (Get result) where
|
||||
type Server (Get result) = EitherT (Int, String) IO result
|
||||
route Proxy action request respond
|
||||
| null (pathInfo request) && requestMethod request == methodGet = do
|
||||
e <- runEitherT action
|
||||
respond . succeedWith $ case e of
|
||||
Right output ->
|
||||
responseLBS ok200 [("Content-Type", "application/json")] (encode output)
|
||||
Left (status, message) ->
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| null (pathInfo request) && requestMethod request /= methodGet =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
|
@ -1,53 +0,0 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
module Servant.API.Post where
|
||||
|
||||
import Control.Monad.Trans.Either
|
||||
import Data.Aeson
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
import Data.Typeable
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Servant.Server
|
||||
|
||||
-- | Endpoint for POST requests. The type variable represents the type of the
|
||||
-- response body (not the request body, use 'Servant.API.RQBody.RQBody' for
|
||||
-- that).
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > -- POST /books
|
||||
-- > -- with a JSON encoded Book as the request body
|
||||
-- > -- returning the just-created Book
|
||||
-- > type MyApi = "books" :> ReqBody Book :> Post Book
|
||||
data Post a
|
||||
deriving Typeable
|
||||
|
||||
-- | When implementing the handler for a 'Post' endpoint,
|
||||
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
|
||||
-- and 'Servant.API.Put.Put', the handler code runs in the
|
||||
-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
|
||||
-- the status code and the 'String' a message, returned in case of
|
||||
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
|
||||
-- to quickly fail if some conditions are not met.
|
||||
--
|
||||
-- If successfully returning a value, we just require that its type has
|
||||
-- a 'ToJSON' instance and servant takes care of encoding it for you,
|
||||
-- yielding status code 201 along the way.
|
||||
instance ToJSON a => HasServer (Post a) where
|
||||
type Server (Post a) = EitherT (Int, String) IO a
|
||||
|
||||
route Proxy action request respond
|
||||
| null (pathInfo request) && requestMethod request == methodPost = do
|
||||
e <- runEitherT action
|
||||
respond . succeedWith $ case e of
|
||||
Right out ->
|
||||
responseLBS status201 [("Content-Type", "application/json")] (encode out)
|
||||
Left (status, message) ->
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| null (pathInfo request) && requestMethod request /= methodPost =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
|
@ -1,52 +0,0 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
module Servant.API.Put where
|
||||
|
||||
import Control.Monad.Trans.Either
|
||||
import Data.Aeson
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
import Data.Typeable
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Servant.Server
|
||||
|
||||
-- | Endpoint for PUT requests, usually used to update a ressource.
|
||||
-- The type @a@ is the type of the response body that's returned.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > -- PUT /books/:isbn
|
||||
-- > -- with a Book as request body, returning the updated Book
|
||||
-- > type MyApi = "books" :> Capture "isbn" Text :> ReqBody Book :> Put Book
|
||||
data Put a
|
||||
deriving Typeable
|
||||
|
||||
-- | When implementing the handler for a 'Put' endpoint,
|
||||
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
|
||||
-- and 'Servant.API.Post.Post', the handler code runs in the
|
||||
-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
|
||||
-- the status code and the 'String' a message, returned in case of
|
||||
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
|
||||
-- to quickly fail if some conditions are not met.
|
||||
--
|
||||
-- If successfully returning a value, we just require that its type has
|
||||
-- a 'ToJSON' instance and servant takes care of encoding it for you,
|
||||
-- yielding status code 200 along the way.
|
||||
instance ToJSON a => HasServer (Put a) where
|
||||
type Server (Put a) = EitherT (Int, String) IO a
|
||||
|
||||
route Proxy action request respond
|
||||
| null (pathInfo request) && requestMethod request == methodPut = do
|
||||
e <- runEitherT action
|
||||
respond . succeedWith $ case e of
|
||||
Right out ->
|
||||
responseLBS ok200 [("Content-Type", "application/json")] (encode out)
|
||||
Left (status, message) ->
|
||||
responseLBS (mkStatus status (cs message)) [] (cs message)
|
||||
| null (pathInfo request) && requestMethod request /= methodPut =
|
||||
respond $ failWith WrongMethod
|
||||
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
|
@ -1,162 +0,0 @@
|
|||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Servant.API.QueryParam where
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
import GHC.TypeLits
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Servant.API.Sub
|
||||
import Servant.Common.Text
|
||||
import Servant.Server
|
||||
|
||||
-- | Lookup the value associated to the @sym@ query string parameter
|
||||
-- and try to extract it as a value of type @a@.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > -- /books?author=<author name>
|
||||
-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book]
|
||||
data QueryParam sym a
|
||||
|
||||
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
|
||||
-- this automatically requires your server-side handler to be a function
|
||||
-- that takes an argument of type @'Maybe' 'Text'@.
|
||||
--
|
||||
-- This lets servant worry about looking it up in the query string
|
||||
-- and turning it into a value of the type you specify, enclosed
|
||||
-- in 'Maybe', because it may not be there and servant would then
|
||||
-- hand you 'Nothing'.
|
||||
--
|
||||
-- You can control how it'll be converted from 'Text' to your type
|
||||
-- by simply providing an instance of 'FromText' for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book]
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = getBooksBy
|
||||
-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]
|
||||
-- > getBooksBy Nothing = ...return all books...
|
||||
-- > getBooksBy (Just author) = ...return books by the given author...
|
||||
instance (KnownSymbol sym, FromText a, HasServer sublayout)
|
||||
=> HasServer (QueryParam sym a :> sublayout) where
|
||||
|
||||
type Server (QueryParam sym a :> sublayout) =
|
||||
Maybe a -> Server sublayout
|
||||
|
||||
route Proxy subserver request respond = do
|
||||
let querytext = parseQueryText $ rawQueryString request
|
||||
param =
|
||||
case lookup paramname querytext of
|
||||
Nothing -> Nothing -- param absent from the query string
|
||||
Just Nothing -> Nothing -- param present with no value -> Nothing
|
||||
Just (Just v) -> fromText v -- if present, we try to convert to
|
||||
-- the right type
|
||||
|
||||
route (Proxy :: Proxy sublayout) (subserver param) request respond
|
||||
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- | Lookup the values associated to the @sym@ query string parameter
|
||||
-- and try to extract it as a value of type @[a]@. This is typically
|
||||
-- meant to support query string parameters of the form
|
||||
-- @param[]=val1¶m[]=val2@ and so on. Note that servant doesn't actually
|
||||
-- require the @[]@s and will fetch the values just fine with
|
||||
-- @param=val1¶m=val2@, too.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > -- /books?authors[]=<author1>&authors[]=<author2>&...
|
||||
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book]
|
||||
data QueryParams sym a
|
||||
|
||||
-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
|
||||
-- this automatically requires your server-side handler to be a function
|
||||
-- that takes an argument of type @['Text']@.
|
||||
--
|
||||
-- This lets servant worry about looking up 0 or more values in the query string
|
||||
-- associated to @authors@ and turning each of them into a value of
|
||||
-- the type you specify.
|
||||
--
|
||||
-- You can control how the individual values are converted from 'Text' to your type
|
||||
-- by simply providing an instance of 'FromText' for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book]
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = getBooksBy
|
||||
-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]
|
||||
-- > getBooksBy authors = ...return all books by these authors...
|
||||
instance (KnownSymbol sym, FromText a, HasServer sublayout)
|
||||
=> HasServer (QueryParams sym a :> sublayout) where
|
||||
|
||||
type Server (QueryParams sym a :> sublayout) =
|
||||
[a] -> Server sublayout
|
||||
|
||||
route Proxy subserver request respond = do
|
||||
let querytext = parseQueryText $ rawQueryString request
|
||||
-- if sym is "foo", we look for query string parameters
|
||||
-- named "foo" or "foo[]" and call fromText on the
|
||||
-- corresponding values
|
||||
parameters = filter looksLikeParam querytext
|
||||
values = catMaybes $ map (convert . snd) parameters
|
||||
|
||||
route (Proxy :: Proxy sublayout) (subserver values) request respond
|
||||
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
|
||||
convert Nothing = Nothing
|
||||
convert (Just v) = fromText v
|
||||
|
||||
-- | Lookup a potentially value-less query string parameter
|
||||
-- with boolean semantics. If the param @sym@ is there without any value,
|
||||
-- or if it's there with value "true" or "1", it's interpreted as 'True'.
|
||||
-- Otherwise, it's interpreted as 'False'.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > -- /books?published
|
||||
-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book]
|
||||
data QueryFlag sym
|
||||
|
||||
-- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API,
|
||||
-- this automatically requires your server-side handler to be a function
|
||||
-- that takes an argument of type 'Bool'.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book]
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = getBooks
|
||||
-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book]
|
||||
-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
|
||||
instance (KnownSymbol sym, HasServer sublayout)
|
||||
=> HasServer (QueryFlag sym :> sublayout) where
|
||||
|
||||
type Server (QueryFlag sym :> sublayout) =
|
||||
Bool -> Server sublayout
|
||||
|
||||
route Proxy subserver request respond = do
|
||||
let querytext = parseQueryText $ rawQueryString request
|
||||
param = case lookup paramname querytext of
|
||||
Just Nothing -> True -- param is there, with no value
|
||||
Just (Just v) -> examine v -- param with a value
|
||||
Nothing -> False -- param not in the query string
|
||||
|
||||
route (Proxy :: Proxy sublayout) (subserver param) request respond
|
||||
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
examine v | v == "true" || v == "1" || v == "" = True
|
||||
| otherwise = False
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Servant.API.Raw where
|
||||
|
||||
import Data.Proxy
|
||||
import Network.Wai
|
||||
import Servant.Server
|
||||
|
||||
-- | Endpoint for plugging in your own Wai 'Application's.
|
||||
--
|
||||
-- The given 'Application' will get the request as received by the server, potentially with
|
||||
-- a modified (stripped) 'pathInfo' if the 'Application' is being routed with 'Servant.API.Sub.:>'.
|
||||
--
|
||||
-- In addition to just letting you plug in your existing WAI 'Application's,
|
||||
-- this can also be used with 'Servant.Utils.StaticFiles.serveDirectory' to serve
|
||||
-- static files stored in a particular directory on your filesystem, or to serve
|
||||
-- your API's documentation with 'Servant.Utils.StaticFiles.serveDocumentation'.
|
||||
data Raw
|
||||
|
||||
-- | Just pass the request to the underlying application and serve its response.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "images" :> Raw
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = serveDirectory "/var/www/images"
|
||||
instance HasServer Raw where
|
||||
type Server Raw = Application
|
||||
route Proxy rawApplication request respond =
|
||||
rawApplication request (respond . succeedWith)
|
||||
|
|
@ -1,49 +0,0 @@
|
|||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Servant.API.ReqBody where
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Aeson
|
||||
import Data.Proxy
|
||||
import Network.Wai
|
||||
import Servant.API.Sub
|
||||
import Servant.Server
|
||||
|
||||
-- | Extract the request body as a value of type @a@.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > -- POST /books
|
||||
-- > type MyApi = "books" :> ReqBody Book :> Post Book
|
||||
data ReqBody a
|
||||
|
||||
-- | If you use 'ReqBody' in one of the endpoints for your API,
|
||||
-- this automatically requires your server-side handler to be a function
|
||||
-- that takes an argument of the type specified by 'ReqBody'.
|
||||
-- This lets servant worry about extracting it from the request and turning
|
||||
-- it into a value of the type you specify.
|
||||
--
|
||||
-- All it asks is for a 'FromJSON' instance.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> ReqBody Book :> Post Book
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = postBook
|
||||
-- > where postBook :: Book -> EitherT (Int, String) IO Book
|
||||
-- > postBook book = ...insert into your db...
|
||||
instance (FromJSON a, HasServer sublayout)
|
||||
=> HasServer (ReqBody a :> sublayout) where
|
||||
|
||||
type Server (ReqBody a :> sublayout) =
|
||||
a -> Server sublayout
|
||||
|
||||
route Proxy subserver request respond = do
|
||||
mrqbody <- decode' <$> lazyRequestBody request
|
||||
case mrqbody of
|
||||
Nothing -> respond $ failWith InvalidBody
|
||||
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
|
||||
|
|
@ -1,36 +0,0 @@
|
|||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Servant.API.Sub where
|
||||
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
import GHC.TypeLits
|
||||
import Network.Wai
|
||||
import Servant.Server
|
||||
|
||||
-- | The contained API (second argument) can be found under @("/" ++ path)@
|
||||
-- (path being the first argument).
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > -- GET /hello/world
|
||||
-- > -- returning a JSON encoded World value
|
||||
-- > type MyApi = "hello" :> "world" :> Get World
|
||||
data (path :: k) :> a = Proxy path :> a
|
||||
infixr 9 :>
|
||||
|
||||
-- | Make sure the incoming request starts with @"/path"@, strip it and
|
||||
-- pass the rest of the request path to @sublayout@.
|
||||
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
|
||||
type Server (path :> sublayout) = Server sublayout
|
||||
route Proxy subserver request respond = case pathInfo request of
|
||||
(first : rest)
|
||||
| first == cs (symbolVal proxyPath)
|
||||
-> route (Proxy :: Proxy sublayout) subserver request{
|
||||
pathInfo = rest
|
||||
} respond
|
||||
_ -> respond $ failWith NotFound
|
||||
|
||||
where proxyPath = Proxy :: Proxy path
|
||||
|
|
@ -1,130 +0,0 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
module Servant.Common.Text
|
||||
( FromText(..)
|
||||
, ToText(..)
|
||||
) where
|
||||
|
||||
import Data.String.Conversions
|
||||
import Data.Int
|
||||
import Data.Text
|
||||
import Data.Text.Read
|
||||
import Data.Word
|
||||
|
||||
-- | For getting values from url captures and query string parameters
|
||||
class FromText a where
|
||||
fromText :: Text -> Maybe a
|
||||
|
||||
-- | For putting values in paths and query string parameters
|
||||
class ToText a where
|
||||
toText :: a -> Text
|
||||
|
||||
instance FromText Text where
|
||||
fromText = Just
|
||||
|
||||
instance ToText Text where
|
||||
toText = id
|
||||
|
||||
instance FromText String where
|
||||
fromText = Just . cs
|
||||
|
||||
instance ToText String where
|
||||
toText = cs
|
||||
|
||||
-- |
|
||||
-- > fromText "true" = Just True
|
||||
-- > fromText "false" = Just False
|
||||
-- > fromText _ = Nothing
|
||||
instance FromText Bool where
|
||||
fromText "true" = Just True
|
||||
fromText "false" = Just False
|
||||
fromText _ = Nothing
|
||||
|
||||
-- |
|
||||
-- > toText True = "true"
|
||||
-- > toText False = "false"
|
||||
instance ToText Bool where
|
||||
toText True = "true"
|
||||
toText False = "false"
|
||||
|
||||
instance FromText Int where
|
||||
fromText = runReader (signed decimal)
|
||||
|
||||
instance ToText Int where
|
||||
toText = cs . show
|
||||
|
||||
instance FromText Int8 where
|
||||
fromText = runReader (signed decimal)
|
||||
|
||||
instance ToText Int8 where
|
||||
toText = cs . show
|
||||
|
||||
instance FromText Int16 where
|
||||
fromText = runReader (signed decimal)
|
||||
|
||||
instance ToText Int16 where
|
||||
toText = cs . show
|
||||
|
||||
instance FromText Int32 where
|
||||
fromText = runReader (signed decimal)
|
||||
|
||||
instance ToText Int32 where
|
||||
toText = cs . show
|
||||
|
||||
instance FromText Int64 where
|
||||
fromText = runReader (signed decimal)
|
||||
|
||||
instance ToText Int64 where
|
||||
toText = cs . show
|
||||
|
||||
instance FromText Word where
|
||||
fromText = runReader decimal
|
||||
|
||||
instance ToText Word where
|
||||
toText = cs . show
|
||||
|
||||
instance FromText Word8 where
|
||||
fromText = runReader decimal
|
||||
|
||||
instance ToText Word8 where
|
||||
toText = cs . show
|
||||
|
||||
instance FromText Word16 where
|
||||
fromText = runReader decimal
|
||||
|
||||
instance ToText Word16 where
|
||||
toText = cs . show
|
||||
|
||||
instance FromText Word32 where
|
||||
fromText = runReader decimal
|
||||
|
||||
instance ToText Word32 where
|
||||
toText = cs . show
|
||||
|
||||
instance FromText Word64 where
|
||||
fromText = runReader decimal
|
||||
|
||||
instance ToText Word64 where
|
||||
toText = cs . show
|
||||
|
||||
instance FromText Integer where
|
||||
fromText = runReader decimal
|
||||
|
||||
instance ToText Integer where
|
||||
toText = cs . show
|
||||
|
||||
instance FromText Double where
|
||||
fromText = runReader rational
|
||||
|
||||
instance ToText Double where
|
||||
toText = cs . show
|
||||
|
||||
instance FromText Float where
|
||||
fromText = runReader rational
|
||||
|
||||
instance ToText Float where
|
||||
toText = cs . show
|
||||
|
||||
runReader :: Reader a -> Text -> Maybe a
|
||||
runReader reader t = either (const Nothing) (Just . fst) $ reader t
|
||||
|
|
@ -1,198 +0,0 @@
|
|||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
|
||||
-- | QuasiQuoting utilities for API types.
|
||||
--
|
||||
-- 'sitemap' allows you to write your type in a very natural way:
|
||||
--
|
||||
-- @
|
||||
-- [sitemap|
|
||||
-- PUT hello String -> ()
|
||||
-- POST hello/p:Int String -> ()
|
||||
-- GET hello/?name:String Int
|
||||
-- |]
|
||||
-- @
|
||||
--
|
||||
-- Will generate:
|
||||
--
|
||||
-- @
|
||||
-- "hello" :> ReqBody String :> Put ()
|
||||
-- :\<|> "hello" :> Capture "p" Int :> ReqBody String :> Post ()
|
||||
-- :\<|> "hello" :> QueryParam "name" String :> Get Int
|
||||
-- @
|
||||
--
|
||||
-- Note the @/@ before a @QueryParam@!
|
||||
module Servant.QQ where
|
||||
|
||||
import Control.Monad (void)
|
||||
import Control.Applicative hiding (many, (<|>), optional)
|
||||
import Language.Haskell.TH.Quote
|
||||
import Language.Haskell.TH
|
||||
import Text.ParserCombinators.Parsec
|
||||
|
||||
import Servant.API.Capture
|
||||
import Servant.API.Get
|
||||
import Servant.API.Post
|
||||
import Servant.API.Put
|
||||
import Servant.API.Delete
|
||||
import Servant.API.QueryParam
|
||||
import Servant.API.ReqBody
|
||||
import Servant.API.Sub
|
||||
import Servant.API.Alternative
|
||||
|
||||
-- | Finally-tagless encoding for our DSL.
|
||||
-- Keeping 'repr'' and 'repr' distinct when writing functions with an
|
||||
-- @ExpSYM@ context ensures certain invariants (for instance, that there is
|
||||
-- only one of 'get', 'post', 'put', and 'delete' in a value), but
|
||||
-- sometimes requires a little more work.
|
||||
class ExpSYM repr' repr | repr -> repr', repr' -> repr where
|
||||
lit :: String -> repr' -> repr
|
||||
capture :: String -> String -> repr -> repr
|
||||
reqBody :: String -> repr -> repr
|
||||
queryParam :: String -> String -> repr -> repr
|
||||
conj :: repr' -> repr -> repr
|
||||
get :: String -> repr
|
||||
post :: String -> repr
|
||||
put :: String -> repr
|
||||
delete :: String -> repr
|
||||
|
||||
|
||||
infixr 6 >:
|
||||
|
||||
(>:) :: Type -> Type -> Type
|
||||
(>:) = conj
|
||||
|
||||
|
||||
instance ExpSYM Type Type where
|
||||
lit name r = LitT (StrTyLit name) >: r
|
||||
capture name typ r = AppT (AppT (ConT ''Capture) (LitT (StrTyLit name)))
|
||||
(ConT $ mkName typ) >: r
|
||||
reqBody typ r = AppT (ConT ''ReqBody) (ConT $ mkName typ) >: r
|
||||
queryParam name typ r = AppT (AppT (ConT ''QueryParam) (LitT (StrTyLit name)))
|
||||
(ConT $ mkName typ) >: r
|
||||
conj x = AppT (AppT (ConT ''(:>)) x)
|
||||
get typ = AppT (ConT ''Get) (ConT $ mkName typ)
|
||||
post typ = AppT (ConT ''Post) (ConT $ mkName typ)
|
||||
put typ = AppT (ConT ''Put) (ConT $ mkName typ)
|
||||
delete "()" = ConT ''Delete
|
||||
delete _ = error "Delete does not return a request body"
|
||||
|
||||
parseMethod :: ExpSYM repr' repr => Parser (String -> repr)
|
||||
parseMethod = try (string "GET" >> return get)
|
||||
<|> try (string "POST" >> return post)
|
||||
<|> try (string "PUT" >> return put)
|
||||
<|> try (string "DELETE" >> return delete)
|
||||
|
||||
parseUrlSegment :: ExpSYM repr repr => Parser (repr -> repr)
|
||||
parseUrlSegment = try parseCapture
|
||||
<|> try parseQueryParam
|
||||
<|> try parseLit
|
||||
where
|
||||
parseCapture = do
|
||||
cname <- many (noneOf " ?/:")
|
||||
char ':'
|
||||
ctyp <- many (noneOf " ?/:")
|
||||
return $ capture cname ctyp
|
||||
parseQueryParam = do
|
||||
char '?'
|
||||
cname <- many (noneOf " ?/:")
|
||||
char ':'
|
||||
ctyp <- many (noneOf " ?/:")
|
||||
return $ queryParam cname ctyp
|
||||
parseLit = lit <$> many (noneOf " ?/:")
|
||||
|
||||
parseUrl :: ExpSYM repr repr => Parser (repr -> repr)
|
||||
parseUrl = do
|
||||
optional $ char '/'
|
||||
url <- parseUrlSegment `sepBy1` char '/'
|
||||
return $ foldr1 (.) url
|
||||
|
||||
data Typ = Val String
|
||||
| ReqArgVal String String
|
||||
|
||||
parseTyp :: Parser Typ
|
||||
parseTyp = do
|
||||
f <- many (noneOf "-{\n\r")
|
||||
spaces
|
||||
s <- optionMaybe (try parseRet)
|
||||
try $ optional inlineComment
|
||||
try $ optional blockComment
|
||||
case s of
|
||||
Nothing -> return $ Val (stripTr f)
|
||||
Just s' -> return $ ReqArgVal (stripTr f) (stripTr s')
|
||||
where
|
||||
parseRet :: Parser String
|
||||
parseRet = do
|
||||
string "->"
|
||||
spaces
|
||||
many (noneOf "-{\n\r")
|
||||
stripTr = reverse . dropWhile (== ' ') . reverse
|
||||
|
||||
|
||||
parseEntry :: ExpSYM repr repr => Parser repr
|
||||
parseEntry = do
|
||||
met <- parseMethod
|
||||
spaces
|
||||
url <- parseUrl
|
||||
spaces
|
||||
typ <- parseTyp
|
||||
case typ of
|
||||
Val s -> return $ url (met s)
|
||||
ReqArgVal i o -> return $ url $ reqBody i (met o)
|
||||
|
||||
blockComment :: Parser ()
|
||||
blockComment = do
|
||||
string "{-"
|
||||
manyTill anyChar (try $ string "-}")
|
||||
return ()
|
||||
|
||||
inlineComment :: Parser ()
|
||||
inlineComment = do
|
||||
string "--"
|
||||
manyTill anyChar (try $ lookAhead eol)
|
||||
return ()
|
||||
|
||||
eol :: Parser String
|
||||
eol = try (string "\n\r")
|
||||
<|> try (string "\r\n")
|
||||
<|> string "\n"
|
||||
<|> string "\r"
|
||||
<?> "end of line"
|
||||
|
||||
eols :: Parser ()
|
||||
eols = skipMany $ void eol <|> blockComment <|> inlineComment
|
||||
|
||||
parseAll :: Parser Type
|
||||
parseAll = do
|
||||
eols
|
||||
entries <- parseEntry `endBy` eols
|
||||
return $ foldr1 union entries
|
||||
where union :: Type -> Type -> Type
|
||||
union a = AppT (AppT (ConT ''(:<|>)) a)
|
||||
|
||||
-- | The sitemap QuasiQuoter.
|
||||
--
|
||||
-- * @.../<var>:<type>/...@ becomes a capture
|
||||
-- * @.../?<var>:<type>@ becomes a query parameter
|
||||
-- * @<method> ... <typ>@ becomes a method returning @<typ>@
|
||||
-- * @<method> ... <typ1> -> <typ2>@ becomes a method with request
|
||||
-- body of @<typ1>@ and returning @<typ2>@
|
||||
--
|
||||
-- Comments are allowed, and have the standard Haskell format
|
||||
--
|
||||
-- * @--@ for inline
|
||||
-- * @{- ... -}@ for block
|
||||
--
|
||||
sitemap :: QuasiQuoter
|
||||
sitemap = QuasiQuoter { quoteExp = undefined
|
||||
, quotePat = undefined
|
||||
, quoteType = \x -> case parse parseAll "" x of
|
||||
Left err -> error $ show err
|
||||
Right st -> return st
|
||||
, quoteDec = undefined
|
||||
}
|
||||
|
||||
|
|
@ -1,105 +0,0 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | This module lets you implement 'Server's for defined APIs. You'll
|
||||
-- most likely just need 'serve'.
|
||||
module Servant.Server where
|
||||
|
||||
import Data.Monoid
|
||||
import Data.Proxy
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
|
||||
-- * Implementing Servers
|
||||
|
||||
-- | 'serve' allows you to implement an API and produce a wai 'Application'.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> Get [Book] -- GET /books
|
||||
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = listAllBooks :<|> postBook
|
||||
-- > where listAllBooks = ...
|
||||
-- > postBook book = ...
|
||||
-- >
|
||||
-- > app :: Application
|
||||
-- > app = serve myApi server
|
||||
-- >
|
||||
-- > main :: IO ()
|
||||
-- > main = Network.Wai.Handler.Warp.run 8080 app
|
||||
serve :: HasServer layout => Proxy layout -> Server layout -> Application
|
||||
serve p server = toApplication (route p server)
|
||||
|
||||
toApplication :: RoutingApplication -> Application
|
||||
toApplication ra request respond = do
|
||||
ra request (routingRespond . routeResult)
|
||||
where
|
||||
routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
|
||||
routingRespond (Left NotFound) =
|
||||
respond $ responseLBS notFound404 [] "not found"
|
||||
routingRespond (Left WrongMethod) =
|
||||
respond $ responseLBS methodNotAllowed405 [] "method not allowed"
|
||||
routingRespond (Left InvalidBody) =
|
||||
respond $ responseLBS badRequest400 [] "Invalid JSON in request body"
|
||||
routingRespond (Right response) =
|
||||
respond response
|
||||
|
||||
-- * Route mismatch
|
||||
data RouteMismatch =
|
||||
NotFound -- ^ the usual "not found" error
|
||||
| WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
|
||||
| InvalidBody -- ^ an even more informative "your json request body wasn't valid" error
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- |
|
||||
-- @
|
||||
-- > mempty = NotFound
|
||||
-- >
|
||||
-- > NotFound `mappend` x = x
|
||||
-- > WrongMethod `mappend` InvalidBody = InvalidBody
|
||||
-- > WrongMethod `mappend` _ = WrongMethod
|
||||
-- > InvalidBody `mappend` _ = InvalidBody
|
||||
-- @
|
||||
instance Monoid RouteMismatch where
|
||||
mempty = NotFound
|
||||
|
||||
NotFound `mappend` x = x
|
||||
WrongMethod `mappend` InvalidBody = InvalidBody
|
||||
WrongMethod `mappend` _ = WrongMethod
|
||||
InvalidBody `mappend` _ = InvalidBody
|
||||
|
||||
-- | A wrapper around @'Either' 'RouteMismatch' a@.
|
||||
newtype RouteResult a =
|
||||
RR { routeResult :: Either RouteMismatch a }
|
||||
deriving (Eq, Show)
|
||||
|
||||
failWith :: RouteMismatch -> RouteResult a
|
||||
failWith = RR . Left
|
||||
|
||||
succeedWith :: a -> RouteResult a
|
||||
succeedWith = RR . Right
|
||||
|
||||
isMismatch :: RouteResult a -> Bool
|
||||
isMismatch (RR (Left _)) = True
|
||||
isMismatch _ = False
|
||||
|
||||
-- | If we get a `Right`, it has precedence over everything else.
|
||||
--
|
||||
-- This in particular means that if we could get several 'Right's,
|
||||
-- only the first we encounter would be taken into account.
|
||||
instance Monoid (RouteResult a) where
|
||||
mempty = RR $ Left mempty
|
||||
|
||||
RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
|
||||
RR (Left _) `mappend` RR (Right y) = RR $ Right y
|
||||
r `mappend` _ = r
|
||||
|
||||
type RoutingApplication =
|
||||
Request -- ^ the request, the field 'pathInfo' may be modified by url routing
|
||||
-> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
|
||||
|
||||
class HasServer layout where
|
||||
type Server layout :: *
|
||||
route :: Proxy layout -> Server layout -> RoutingApplication
|
||||
|
|
@ -1,110 +0,0 @@
|
|||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
-- | Type safe internal links.
|
||||
--
|
||||
-- Provides the function 'mkLink':
|
||||
--
|
||||
-- @
|
||||
-- type API = Proxy ("hello" :> Get Int
|
||||
-- :<|> "bye" :> QueryParam "name" String :> Post Bool)
|
||||
--
|
||||
-- api :: API
|
||||
-- api = proxy
|
||||
--
|
||||
-- link1 :: Proxy ("hello" :> Get Int)
|
||||
-- link1 = proxy
|
||||
--
|
||||
-- link2 :: Proxy ("hello" :> Delete)
|
||||
-- link2 = proxy
|
||||
--
|
||||
-- mkLink link1 API -- typechecks, returns 'Link "/hello"'
|
||||
--
|
||||
-- mkLink link2 API -- doesn't typecheck
|
||||
-- @
|
||||
--
|
||||
-- That is, 'mkLink' takes two arguments, a link proxy and a sitemap, and
|
||||
-- returns a 'Link', but only typechecks if the link proxy is a valid link,
|
||||
-- and part of the sitemap.
|
||||
--
|
||||
-- __N.B.:__ 'mkLink' assumes a capture matches any string (without slashes).
|
||||
module Servant.Utils.Links where
|
||||
|
||||
import Data.Proxy
|
||||
import GHC.TypeLits
|
||||
|
||||
import Servant.API.Capture
|
||||
import Servant.API.ReqBody
|
||||
import Servant.API.QueryParam
|
||||
import Servant.API.Get
|
||||
import Servant.API.Post
|
||||
import Servant.API.Put
|
||||
import Servant.API.Delete
|
||||
import Servant.API.Sub
|
||||
import Servant.API.Alternative
|
||||
|
||||
|
||||
type family Or a b where
|
||||
Or 'False 'False = 'False
|
||||
Or 'True b = 'True
|
||||
Or a 'True = 'True
|
||||
|
||||
type family And a b where
|
||||
And 'True 'True = 'True
|
||||
And a 'False = 'False
|
||||
And 'False b = 'False
|
||||
|
||||
type family IsElem a s where
|
||||
IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb)
|
||||
IsElem (e :> sa) (e :> sb) = IsElem sa sb
|
||||
IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb
|
||||
IsElem sa (ReqBody x :> sb) = IsElem sa sb
|
||||
IsElem sa (QueryParam x y :> sb) = IsElem sa sb
|
||||
IsElem e e = 'True
|
||||
IsElem e a = 'False
|
||||
|
||||
type family IsLink'' l where
|
||||
IsLink'' (e :> Get x) = IsLink' e
|
||||
IsLink'' (e :> Post x) = IsLink' e
|
||||
IsLink'' (e :> Put x) = IsLink' e
|
||||
IsLink'' (e :> Delete) = IsLink' e
|
||||
IsLink'' a = 'False
|
||||
|
||||
type family IsLink' e where
|
||||
IsLink' (f :: Symbol) = 'True
|
||||
|
||||
type family IsLink e where
|
||||
IsLink (a :> b) = Or (And (IsLink' a) (IsLink'' b))
|
||||
(IsLink'' (a :> b))
|
||||
|
||||
|
||||
-- | The 'ValidLinkIn f s' constraint holds when 's' is an API that
|
||||
-- contains 'f', and 'f' is a link.
|
||||
class ValidLinkIn f s where
|
||||
mkLink :: f -> s -> Link -- ^ This function will only typecheck if `f`
|
||||
-- is an URI within `s`
|
||||
|
||||
instance ( IsElem f s ~ 'True
|
||||
, IsLink f ~ 'True
|
||||
, VLinkHelper f) => ValidLinkIn f s where
|
||||
mkLink _ _ = Link (vlh (Proxy :: Proxy f))
|
||||
|
||||
data Link = Link String deriving Show
|
||||
|
||||
class VLinkHelper f where
|
||||
vlh :: forall proxy. proxy f -> String
|
||||
|
||||
instance (KnownSymbol s, VLinkHelper e) => VLinkHelper (s :> e) where
|
||||
vlh _ = "/" ++ symbolVal (Proxy :: Proxy s) ++ vlh (Proxy :: Proxy e)
|
||||
|
||||
instance VLinkHelper (Get x) where
|
||||
vlh _ = ""
|
||||
|
||||
instance VLinkHelper (Post x) where
|
||||
vlh _ = ""
|
||||
|
||||
|
|
@ -1,36 +0,0 @@
|
|||
-- | This module defines a sever-side handler that lets you serve static files.
|
||||
--
|
||||
-- - 'serveDirectory' lets you serve anything that lives under a particular
|
||||
-- directory on your filesystem.
|
||||
module Servant.Utils.StaticFiles (
|
||||
serveDirectory,
|
||||
) where
|
||||
|
||||
import Filesystem.Path.CurrentOS (decodeString)
|
||||
import Network.Wai.Application.Static
|
||||
import Servant.API.Raw
|
||||
import Servant.Server
|
||||
|
||||
-- | Serve anything under the specified directory as a 'Raw' endpoint.
|
||||
--
|
||||
-- @
|
||||
-- type MyApi = "static" :> Raw
|
||||
--
|
||||
-- server :: Server MyApi
|
||||
-- server = serveDirectory "\/var\/www"
|
||||
-- @
|
||||
--
|
||||
-- would capture any request to @\/static\/\<something>@ and look for
|
||||
-- @\<something>@ under @\/var\/www@.
|
||||
--
|
||||
-- It will do its best to guess the MIME type for that file, based on the extension,
|
||||
-- and send an appropriate /Content-Type/ header if possible.
|
||||
--
|
||||
-- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API
|
||||
-- as a webapp backend, you will most likely not want the static files to be hidden
|
||||
-- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectory'
|
||||
-- handler in the last position, because /servant/ will try to match the handlers
|
||||
-- in order.
|
||||
serveDirectory :: FilePath -> Server Raw
|
||||
serveDirectory documentRoot =
|
||||
staticApp (defaultFileServerSettings (decodeString (documentRoot ++ "/")))
|
||||
|
|
@ -1,177 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Servant.QQSpec where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
import Servant.API
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- Types for testing
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
-- Methods ---------------------------------------------------------------
|
||||
type SimpleGet = [sitemap|
|
||||
GET hello ()
|
||||
|]
|
||||
type SimpleGet' = "hello" :> Get ()
|
||||
type SimpleGet'' = "hello" :> Get Bool
|
||||
|
||||
type SimpleGet2 = [sitemap|
|
||||
GET hello Bool
|
||||
|]
|
||||
type SimpleGet2' = "hello" :> Get Bool
|
||||
type SimpleGet2'' = "hello" :> Get Int
|
||||
|
||||
type SimplePost = [sitemap|
|
||||
POST hello ()
|
||||
|]
|
||||
type SimplePost' = "hello" :> Post ()
|
||||
type SimplePost'' = "hello" :> Post Bool
|
||||
|
||||
type SimplePost2 = [sitemap|
|
||||
POST hello Bool
|
||||
|]
|
||||
type SimplePost2' = "hello" :> Post Bool
|
||||
type SimplePost2'' = "hello" :> Post ()
|
||||
|
||||
type SimplePut = [sitemap|
|
||||
PUT hello ()
|
||||
|]
|
||||
type SimplePut' = "hello" :> Put ()
|
||||
type SimplePut'' = "hello" :> Put Bool
|
||||
|
||||
type SimplePut2 = [sitemap|
|
||||
PUT hello Bool
|
||||
|]
|
||||
type SimplePut2' = "hello" :> Put Bool
|
||||
type SimplePut2'' = "hello" :> Put ()
|
||||
|
||||
-- Parameters ------------------------------------------------------------
|
||||
|
||||
type SimpleReqBody = [sitemap|
|
||||
POST hello () -> Bool
|
||||
|]
|
||||
type SimpleReqBody' = "hello" :> ReqBody () :> Post Bool
|
||||
type SimpleReqBody'' = "hello" :> ReqBody Bool :> Post ()
|
||||
|
||||
type SimpleCapture = [sitemap|
|
||||
POST hello/p:Int Bool
|
||||
|]
|
||||
type SimpleCapture' = "hello" :> Capture "p" Int :> Post Bool
|
||||
type SimpleCapture'' = "hello" :> Capture "r" Int :> Post Bool
|
||||
type SimpleCapture''' = "hello" :> Capture "p" Bool :> Post Bool
|
||||
|
||||
type SimpleQueryParam = [sitemap|
|
||||
POST hello/?p:Int Bool
|
||||
|]
|
||||
type SimpleQueryParam' = "hello" :> QueryParam "p" Int :> Post Bool
|
||||
type SimpleQueryParam'' = "hello" :> QueryParam "r" Int :> Post Bool
|
||||
type SimpleQueryParam''' = "hello" :> QueryParam "p" Bool :> Post Bool
|
||||
|
||||
-- Combinations ----------------------------------------------------------
|
||||
|
||||
type TwoPaths = [sitemap|
|
||||
POST hello Bool
|
||||
GET hello Bool
|
||||
|]
|
||||
type TwoPaths' = ("hello" :> Post Bool) :<|> ("hello" :> Get Bool)
|
||||
|
||||
type WithInlineComments = [sitemap|
|
||||
GET hello Bool -- This is a comment
|
||||
|]
|
||||
type WithInlineComments' = "hello" :> Get Bool
|
||||
|
||||
type WithInlineComments2 = [sitemap|
|
||||
GET hello Bool
|
||||
-- This is a comment
|
||||
|]
|
||||
type WithInlineComments2' = "hello" :> Get Bool
|
||||
|
||||
|
||||
type WithBlockComments = [sitemap|
|
||||
GET hello Bool {-
|
||||
POST hello Bool
|
||||
-}
|
||||
|]
|
||||
type WithBlockComments' = "hello" :> Get Bool
|
||||
|
||||
type WithBlockComments2 = [sitemap|
|
||||
GET hello Bool {-
|
||||
POST hello Bool
|
||||
-}
|
||||
POST hello Bool
|
||||
|]
|
||||
type WithBlockComments2' = ("hello" :> Get Bool) :<|> ("hello" :> Post Bool)
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- Spec
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "'sitemap' QuasiQuoter" $ do
|
||||
it "Handles simple GET types" $ do
|
||||
(u::SimpleGet) ~= (u::SimpleGet' ) ~> True
|
||||
(u::SimpleGet) ~= (u::SimpleGet'' ) ~> False
|
||||
(u::SimpleGet2) ~= (u::SimpleGet2' ) ~> True
|
||||
(u::SimpleGet2) ~= (u::SimpleGet2'') ~> False
|
||||
it "Handles simple POST types" $ do
|
||||
(u::SimplePost) ~= (u::SimplePost' ) ~> True
|
||||
(u::SimplePost) ~= (u::SimplePost'' ) ~> False
|
||||
(u::SimplePost2) ~= (u::SimplePost2' ) ~> True
|
||||
(u::SimplePost2) ~= (u::SimplePost2'') ~> False
|
||||
it "Handles simple PUT types" $ do
|
||||
(u::SimplePut) ~= (u::SimplePut' ) ~> True
|
||||
(u::SimplePut) ~= (u::SimplePut'' ) ~> False
|
||||
(u::SimplePut2) ~= (u::SimplePut2' ) ~> True
|
||||
(u::SimplePut2) ~= (u::SimplePut2'') ~> False
|
||||
it "Handles simple request body types" $ do
|
||||
(u::SimpleReqBody) ~= (u::SimpleReqBody' ) ~> True
|
||||
(u::SimpleReqBody) ~= (u::SimpleReqBody'') ~> False
|
||||
it "Handles simple captures" $ do
|
||||
(u::SimpleCapture) ~= (u::SimpleCapture' ) ~> True
|
||||
(u::SimpleCapture) ~= (u::SimpleCapture'') ~> False
|
||||
(u::SimpleCapture) ~= (u::SimpleCapture''') ~> False
|
||||
it "Handles simple querystring parameters" $ do
|
||||
(u::SimpleQueryParam) ~= (u::SimpleQueryParam' ) ~> True
|
||||
(u::SimpleQueryParam) ~= (u::SimpleQueryParam'') ~> False
|
||||
(u::SimpleQueryParam) ~= (u::SimpleQueryParam''') ~> False
|
||||
it "Handles multiples paths" $ do
|
||||
(u::TwoPaths) ~= (u::TwoPaths') ~> True
|
||||
it "Ignores inline comments" $ do
|
||||
(u::WithInlineComments) ~= (u::WithInlineComments') ~> True
|
||||
(u::WithInlineComments2) ~= (u::WithInlineComments2') ~> True
|
||||
it "Ignores inline comments" $ do
|
||||
(u::WithBlockComments) ~= (u::WithBlockComments') ~> True
|
||||
(u::WithBlockComments2) ~= (u::WithBlockComments2') ~> True
|
||||
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- Utilities
|
||||
--------------------------------------------------------------------------
|
||||
data HTrue
|
||||
data HFalse
|
||||
|
||||
-- Kiselyov's Type Equality predicate
|
||||
class TypeEq x y b | x y -> b where { areEq :: x -> y -> Bool }
|
||||
instance TypeEq x x HTrue where { areEq _ _ = True }
|
||||
instance b ~ HFalse => TypeEq x y b where { areEq _ _ = False}
|
||||
|
||||
infix 4 ~=
|
||||
(~=) :: TypeEq x y b => x -> y -> Bool
|
||||
(~=) = areEq
|
||||
|
||||
u :: a
|
||||
u = undefined
|
||||
|
||||
infix 3 ~>
|
||||
(~>) :: (Show a, Eq a) => a -> a -> Expectation
|
||||
(~>) = shouldBe
|
||||
|
|
@ -1,258 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Servant.ServerSpec where
|
||||
|
||||
|
||||
import Control.Monad.Trans.Either
|
||||
import Data.Aeson
|
||||
import Data.Char
|
||||
import Data.Proxy
|
||||
import Data.String
|
||||
import Data.String.Conversions
|
||||
import GHC.Generics
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Wai
|
||||
|
||||
import Servant.API.Capture
|
||||
import Servant.API.Get
|
||||
import Servant.API.ReqBody
|
||||
import Servant.API.Post
|
||||
import Servant.API.QueryParam
|
||||
import Servant.API.Raw
|
||||
import Servant.API.Sub
|
||||
import Servant.API.Alternative
|
||||
import Servant.Server
|
||||
|
||||
|
||||
-- * test data types
|
||||
|
||||
data Person = Person {
|
||||
name :: String,
|
||||
age :: Integer
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON Person
|
||||
instance FromJSON Person
|
||||
|
||||
alice :: Person
|
||||
alice = Person "Alice" 42
|
||||
|
||||
data Animal = Animal {
|
||||
species :: String,
|
||||
numberOfLegs :: Integer
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON Animal
|
||||
instance FromJSON Animal
|
||||
|
||||
jerry :: Animal
|
||||
jerry = Animal "Mouse" 4
|
||||
|
||||
tweety :: Animal
|
||||
tweety = Animal "Bird" 2
|
||||
|
||||
|
||||
-- * specs
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
captureSpec
|
||||
getSpec
|
||||
queryParamSpec
|
||||
postSpec
|
||||
rawSpec
|
||||
unionSpec
|
||||
|
||||
|
||||
type CaptureApi = Capture "legs" Integer :> Get Animal
|
||||
captureApi :: Proxy CaptureApi
|
||||
captureApi = Proxy
|
||||
captureServer :: Integer -> EitherT (Int, String) IO Animal
|
||||
captureServer legs = case legs of
|
||||
4 -> return jerry
|
||||
2 -> return tweety
|
||||
_ -> left (404, "not found")
|
||||
|
||||
captureSpec :: Spec
|
||||
captureSpec = do
|
||||
describe "Servant.API.Capture" $ do
|
||||
with (return (serve captureApi captureServer)) $ do
|
||||
it "can capture parts of the 'pathInfo'" $ do
|
||||
response <- get "/2"
|
||||
liftIO $ do
|
||||
decode' (simpleBody response) `shouldBe` Just tweety
|
||||
|
||||
with (return (serve
|
||||
(Proxy :: Proxy (Capture "captured" String :> Raw))
|
||||
(\ "captured" request respond ->
|
||||
respond $ responseLBS ok200 [] (cs $ show $ pathInfo request)))) $ do
|
||||
it "strips the captured path snippet from pathInfo" $ do
|
||||
get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
|
||||
|
||||
|
||||
type GetApi = Get Person
|
||||
getApi :: Proxy GetApi
|
||||
getApi = Proxy
|
||||
|
||||
getSpec :: Spec
|
||||
getSpec = do
|
||||
describe "Servant.API.Get" $ do
|
||||
with (return (serve getApi (return alice))) $ do
|
||||
it "allows to GET a Person" $ do
|
||||
response <- get "/"
|
||||
return response `shouldRespondWith` 200
|
||||
liftIO $ do
|
||||
decode' (simpleBody response) `shouldBe` Just alice
|
||||
|
||||
it "throws 405 (wrong method) on POSTs" $ do
|
||||
post "/" "" `shouldRespondWith` 405
|
||||
|
||||
|
||||
type QueryParamApi = QueryParam "name" String :> Get Person
|
||||
:<|> "a" :> QueryParams "names" String :> Get Person
|
||||
:<|> "b" :> QueryFlag "capitalize" :> Get Person
|
||||
|
||||
queryParamApi :: Proxy QueryParamApi
|
||||
queryParamApi = Proxy
|
||||
|
||||
qpServer :: Server QueryParamApi
|
||||
qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize
|
||||
|
||||
where qpNames (_:name2:_) = return alice { name = name2 }
|
||||
qpNames _ = return alice
|
||||
|
||||
qpCapitalize False = return alice
|
||||
qpCapitalize True = return alice { name = map toUpper (name alice) }
|
||||
|
||||
queryParamServer (Just name) = return alice{name = name}
|
||||
queryParamServer Nothing = return alice
|
||||
|
||||
queryParamSpec :: Spec
|
||||
queryParamSpec = do
|
||||
describe "Servant.API.QueryParam" $ do
|
||||
it "allows to retrieve simple GET parameters" $
|
||||
(flip runSession) (serve queryParamApi qpServer) $ do
|
||||
let params1 = "?name=bob"
|
||||
response1 <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params1,
|
||||
queryString = parseQuery params1
|
||||
}
|
||||
liftIO $ do
|
||||
decode' (simpleBody response1) `shouldBe` Just alice{
|
||||
name = "bob"
|
||||
}
|
||||
|
||||
it "allows to retrieve lists in GET parameters" $
|
||||
(flip runSession) (serve queryParamApi qpServer) $ do
|
||||
let params2 = "?names[]=bob&names[]=john"
|
||||
response2 <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params2,
|
||||
queryString = parseQuery params2,
|
||||
pathInfo = ["a"]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response2) `shouldBe` Just alice{
|
||||
name = "john"
|
||||
}
|
||||
|
||||
it "allows to retrieve value-less GET parameters" $
|
||||
(flip runSession) (serve queryParamApi qpServer) $ do
|
||||
let params3 = "?capitalize"
|
||||
response3 <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params3,
|
||||
queryString = parseQuery params3,
|
||||
pathInfo = ["b"]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response3) `shouldBe` Just alice{
|
||||
name = "ALICE"
|
||||
}
|
||||
|
||||
let params3' = "?capitalize="
|
||||
response3' <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params3',
|
||||
queryString = parseQuery params3',
|
||||
pathInfo = ["b"]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response3') `shouldBe` Just alice{
|
||||
name = "ALICE"
|
||||
}
|
||||
|
||||
type PostApi = ReqBody Person :> Post Integer
|
||||
postApi :: Proxy PostApi
|
||||
postApi = Proxy
|
||||
|
||||
postSpec :: Spec
|
||||
postSpec = do
|
||||
describe "Servant.API.Post and .ReqBody" $ do
|
||||
with (return (serve postApi (return . age))) $ do
|
||||
it "allows to POST a Person" $ do
|
||||
post "/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 201
|
||||
}
|
||||
|
||||
it "correctly rejects invalid request bodies with status 400" $ do
|
||||
post "/" "some invalid body" `shouldRespondWith` 400
|
||||
|
||||
|
||||
type RawApi = "foo" :> Raw
|
||||
rawApi :: Proxy RawApi
|
||||
rawApi = Proxy
|
||||
rawApplication :: Show a => (Request -> a) -> Application
|
||||
rawApplication f request respond = respond $ responseLBS ok200 [] (cs $ show $ f request)
|
||||
|
||||
rawSpec :: Spec
|
||||
rawSpec = do
|
||||
describe "Servant.API.Raw" $ do
|
||||
it "runs applications" $ do
|
||||
(flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
|
||||
response <- Network.Wai.Test.request defaultRequest{
|
||||
pathInfo = ["foo"]
|
||||
}
|
||||
liftIO $ do
|
||||
simpleBody response `shouldBe` "42"
|
||||
|
||||
it "gets the pathInfo modified" $ do
|
||||
(flip runSession) (serve rawApi (rawApplication pathInfo)) $ do
|
||||
response <- Network.Wai.Test.request defaultRequest{
|
||||
pathInfo = ["foo", "bar"]
|
||||
}
|
||||
liftIO $ do
|
||||
simpleBody response `shouldBe` cs (show ["bar" :: String])
|
||||
|
||||
|
||||
type AlternativeApi =
|
||||
"foo" :> Get Person
|
||||
:<|> "bar" :> Get Animal
|
||||
unionApi :: Proxy AlternativeApi
|
||||
unionApi = Proxy
|
||||
|
||||
unionServer :: Server AlternativeApi
|
||||
unionServer =
|
||||
return alice
|
||||
:<|> return jerry
|
||||
|
||||
unionSpec :: Spec
|
||||
unionSpec = do
|
||||
describe "Servant.API.Alternative" $ do
|
||||
with (return $ serve unionApi unionServer) $ do
|
||||
it "unions endpoints" $ do
|
||||
response <- get "/foo"
|
||||
liftIO $ do
|
||||
decode' (simpleBody response) `shouldBe`
|
||||
Just alice
|
||||
response <- get "/bar"
|
||||
liftIO $ do
|
||||
decode' (simpleBody response) `shouldBe`
|
||||
Just jerry
|
||||
|
|
@ -1,52 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Servant.Utils.LinksSpec where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
import Servant.API
|
||||
import Servant.QQSpec ( (~>) )
|
||||
import Servant.Utils.Links (IsElem, IsLink)
|
||||
|
||||
type TestApi =
|
||||
"hello" :> Capture "name" String :> QueryParam "capital" Bool :> Get Bool
|
||||
:<|> "greet" :> ReqBody 'True :> Post Bool
|
||||
|
||||
type TestLink = "hello" :> "hi" :> Get Bool
|
||||
type TestLink2 = "greet" :> Post Bool
|
||||
|
||||
type BadTestLink = "hallo" :> "hi" :> Get Bool
|
||||
type BadTestLink2 = "greet" :> Get Bool
|
||||
|
||||
type NotALink = "hello" :> Capture "x" Bool :> Get Bool
|
||||
type NotALink2 = "hello" :> ReqBody 'True :> Get Bool
|
||||
|
||||
data Proxy x = Proxy
|
||||
class ReflectT (x::Bool) where { reflected :: Proxy x -> Bool }
|
||||
instance ReflectT 'True where { reflected _ = True }
|
||||
instance ReflectT 'False where { reflected _ = False }
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Servant.API.Elem" $ do
|
||||
isElem
|
||||
isLink
|
||||
|
||||
isElem :: Spec
|
||||
isElem = describe "IsElem" $ do
|
||||
it "is True when the first argument is an url within the second" $ do
|
||||
reflected (Proxy::Proxy (IsElem TestLink TestApi)) ~> True
|
||||
reflected (Proxy::Proxy (IsElem TestLink2 TestApi)) ~> True
|
||||
it "is False when the first argument is not an url within the second" $ do
|
||||
reflected (Proxy::Proxy (IsElem BadTestLink TestApi)) ~> False
|
||||
reflected (Proxy::Proxy (IsElem BadTestLink2 TestApi)) ~> False
|
||||
|
||||
isLink :: Spec
|
||||
isLink = describe "IsLink" $ do
|
||||
it "is True when all Subs are paths and the last is a method" $ do
|
||||
reflected (Proxy::Proxy (IsLink TestLink)) ~> True
|
||||
reflected (Proxy::Proxy (IsLink TestLink2)) ~> True
|
||||
it "is False of anything with captures" $ do
|
||||
reflected (Proxy::Proxy (IsLink NotALink)) ~> False
|
||||
reflected (Proxy::Proxy (IsLink NotALink2)) ~> False
|
||||
|
||||
|
|
@ -1,64 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Servant.Utils.StaticFilesSpec where
|
||||
|
||||
import Control.Exception
|
||||
import Data.Proxy
|
||||
import Network.Wai
|
||||
import System.Directory
|
||||
import System.IO.Temp
|
||||
import Test.Hspec hiding (pending)
|
||||
import Test.Hspec.Wai
|
||||
|
||||
import Servant.API.Alternative
|
||||
import Servant.API.Capture
|
||||
import Servant.API.Get
|
||||
import Servant.API.Raw
|
||||
import Servant.API.Sub
|
||||
import Servant.Server
|
||||
import Servant.ServerSpec
|
||||
import Servant.Utils.StaticFiles
|
||||
|
||||
type Api =
|
||||
"dummy_api" :> Capture "person_name" String :> Get Person
|
||||
:<|> "static" :> Raw
|
||||
|
||||
|
||||
api :: Proxy Api
|
||||
api = Proxy
|
||||
|
||||
app :: Application
|
||||
app = serve api server
|
||||
|
||||
server :: Server Api
|
||||
server =
|
||||
(\ name -> return (Person name 42))
|
||||
:<|> serveDirectory "static"
|
||||
|
||||
withStaticFiles :: IO () -> IO ()
|
||||
withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir ->
|
||||
bracket (setup tmpDir) teardown (const action)
|
||||
where
|
||||
setup tmpDir = do
|
||||
outer <- getCurrentDirectory
|
||||
setCurrentDirectory tmpDir
|
||||
createDirectory "static"
|
||||
writeFile "static/foo.txt" "bar"
|
||||
writeFile "static/index.html" "index"
|
||||
return outer
|
||||
|
||||
teardown outer = do
|
||||
setCurrentDirectory outer
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
around_ withStaticFiles $ with (return app) $ do
|
||||
describe "serveDirectory" $ do
|
||||
it "successfully serves files" $ do
|
||||
get "/static/foo.txt" `shouldRespondWith` "bar"
|
||||
|
||||
it "serves the contents of index.html when requesting the root of a directory" $ do
|
||||
get "/static" `shouldRespondWith` "index"
|
||||
|
|
@ -1 +0,0 @@
|
|||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
Loading…
Reference in a new issue