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

Merge branch 'master' into servant-dates

Browse source 
# Conflicts:
#	servant-server/servant-server.cabal
#	servant-server/test/Servant/ServerSpec.hs
This commit is contained in:
Alex Mason 2016-01-11 17:08:43 +11:00
commit 13c2b8e077
66 changed files with 1045 additions and 1325 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

79
CONTRIBUTING.md Normal file
View file

@ -0,0 +1,79 @@
# Contributing Guidelines
Contributions are very welcome! To hack on the github version, clone the
repository. You can use `cabal`:
```shell
./scripts/start-sandbox.sh # Initialize the sandbox and add-source the packages
./scripts/test-all.sh # Run all the tests
```
`stack`:
```shell
stack build # Install and build packages
stack test # Run all the tests
```
Or `nix`:
```shell
./scripts/generate-nix-files.sh # Get up-to-date shell.nix files
```
## General
Some things we like:
- Explicit imports
- Upper and lower bounds for packages
- Few dependencies
- -Werror-compatible (for both 7.8 and 7.10)
Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs`
files in the repository provide a good baseline for consistency.
Please include a description of the changes in your PR in the `CHANGELOG.md` of
the packages you've changed. And of course, write tests!
## PR process
We try to give timely reviews to PRs that pass CI. If CI for your PR fails, we
may close the PR if it has been open for too long (though you should feel free
to reopen when the issues have been fixed).
We require two +1 from the maintainers of the repo. If you feel like there has
not been a timely response to a PR, you can ping the Maintainers group (with
`@Maintainers`).
## New combinators
We encourage people to experiment with new combinators and instances - it is
one of the most powerful ways of using `servant`, and a wonderful way of
getting to know it better. If you do write a new combinator, we would love to
know about it! Either hop on #servant on freenode and let us know, or open an
issue with the `news` tag (which we will close when we read it).
As for adding them to the main repo: maintaining combinators can be expensive,
since official combinators must have instances for all classes (and new classes
come along fairly frequently). We therefore have to be quite selective about
those that we accept. If you're considering writing a new combinator, open an
issue to discuss it first! (You could release your combinator as a separate
package, of course.)
## New classes
The main benefit of having a new class and package in the main servant repo is
that we get to see via CI whether changes to other packages break the build.
Open an issue to discuss whether a package should be added to the main repo. If
we decide that it can, you can still keep maintainership over it.
Whether or not you want your package to be in the repo, create an issue with
the `news` label if you make a new package so we can know about it!
## Release policy
We are currently moving to a more aggresive release policy, so that you can get
what you contribute from Hackage fairly soon. However, note that prior to major
releases it may take some time in between releases.

27
README.md
View file

@ -17,29 +17,4 @@ list](https://groups.google.com/forum/#!forum/haskell-servant).
## Contributing
Contributions are very welcome! To hack on the github version, clone the
repository. You can use `cabal`:
```shell
./scripts/start-sandbox.sh # Initialize the sandbox and add-source the packages
./scripts/test-all.sh # Run all the tests
```
`stack`:
```shell
stack build # Install and build packages
stack test # Run all the tests
```
Or `nix`:
```shell
./scripts/generate-nix-files.sh # Get up-to-date shell.nix files
```
Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs`
files in the repository provide a good baseline for consistency.
Please include a description of the changes in your PR in the `CHANGELOG.md` of
the packages you've changed. And of course, write tests!
See `CONTRIBUTING.md`

2
scripts/bump-versions.sh
View file

@ -1,4 +1,4 @@
#!/bin/bash -
#!/usr/bin/env bash
#===============================================================================
#
# FILE: bump-versions.sh

2
scripts/clear-sandbox.sh
View file

@ -1,4 +1,4 @@
#!/bin/bash -
#!/usr/bin/env bash
#===============================================================================
#
# FILE: clear-sandbox.sh

2
scripts/generate-nix-files.sh
View file

@ -1,4 +1,4 @@
#!/bin/bash -
#!/usr/bin/env bash
#===============================================================================
#
# FILE: generate-nix-files.sh

2
scripts/start-sandbox.sh
View file

@ -1,4 +1,4 @@
#!/bin/bash -
#!/usr/bin/env bash
#===============================================================================
#
# FILE: start-sandbox.sh

2
scripts/test-all.sh
View file

@ -1,4 +1,4 @@
#!/bin/bash -
#!/usr/bin/env bash
#===============================================================================
#
# FILE: test-all.sh

2
scripts/upload.sh
View file

@ -1,4 +1,4 @@
#!/bin/bash -
#!/usr/bin/env bash
#===============================================================================
#
# FILE: upload.sh

8
servant-blaze/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

3
servant-blaze/servant-blaze.cabal
View file

@ -13,7 +13,7 @@ maintainer: jkarni@gmail.com
-- copyright:
category: Web
build-type: Simple
-- extra-source-files:
extra-source-files: include/*.h
cabal-version: >=1.10
bug-reports: http://github.com/haskell-servant/servant/issues
source-repository head
@ -30,3 +30,4 @@ library
, blaze-html
hs-source-dirs: src
default-language: Haskell2010
include-dirs: include

16
servant-blaze/src/Servant/HTML/Blaze.hs
View file

@ -3,10 +3,8 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
#include "overlapping-compat.h"
-- | An @HTML@ empty data type with `MimeRender` instances for @blaze-html@'s
-- `ToMarkup` class and `Html` datatype.
-- You should only need to import this module for it's instances and the
@ -29,17 +27,9 @@ data HTML deriving Typeable
instance Accept HTML where
contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
ToMarkup a => MimeRender HTML a where
instance OVERLAPPABLE_ ToMarkup a => MimeRender HTML a where
mimeRender _ = renderHtml . toHtml
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
MimeRender HTML Html where
instance OVERLAPPING_ MimeRender HTML Html where
mimeRender _ = renderHtml

8
servant-cassava/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

3
servant-cassava/servant-cassava.cabal
View file

@ -13,7 +13,7 @@ maintainer: jkarni@gmail.com
-- copyright:
-- category:
build-type: Simple
-- extra-source-files:
extra-source-files: include/*.h
cabal-version: >=1.10
library
@ -27,3 +27,4 @@ library
, vector
hs-source-dirs: src
default-language: Haskell2010
include-dirs: include

29
servant-cassava/src/Servant/CSV/Cassava.hs
View file

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
@ -16,10 +17,13 @@
-- >>> type EgDefault = Get '[CSV] [(Int, String)]
module Servant.CSV.Cassava where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Data.Csv
import Data.Proxy (Proxy (..))
import Data.Typeable (Typeable)
import Data.Vector (Vector)
import Data.Vector (Vector, toList)
import GHC.Generics (Generic)
import qualified Network.HTTP.Media as M
import Servant.API (Accept (..), MimeRender (..),
@ -50,6 +54,18 @@ instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt
mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p)
where p = Proxy :: Proxy opt
-- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining
-- the order of headers and fields.
instance ( ToNamedRecord a, EncodeOpts opt
) => MimeRender (CSV', opt) (Header, Vector a) where
mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr (toList vals)
where p = Proxy :: Proxy opt
-- | Encode with 'encodeDefaultOrderedByNameWith'
instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt
) => MimeRender (CSV', opt) (Vector a) where
mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) . toList
where p = Proxy :: Proxy opt
-- ** Encode Options
@ -66,6 +82,17 @@ instance EncodeOpts DefaultEncodeOpts where
-- ** Instances
-- | Decode with 'decodeByNameWith'
instance ( FromNamedRecord a, DecodeOpts opt
) => MimeUnrender (CSV', opt) (Header, [a]) where
mimeUnrender _ bs = fmap toList <$> decodeByNameWith (decodeOpts p) bs
where p = Proxy :: Proxy opt
-- | Decode with 'decodeWith'. Assumes data has headers, which are stripped.
instance ( FromRecord a, DecodeOpts opt
) => MimeUnrender (CSV', opt) [a] where
mimeUnrender _ bs = toList <$> decodeWith (decodeOpts p) HasHeader bs
where p = Proxy :: Proxy opt
instance ( FromNamedRecord a, DecodeOpts opt
) => MimeUnrender (CSV', opt) (Header, Vector a) where
mimeUnrender _ = decodeByNameWith (decodeOpts p)

8
servant-client/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

2
servant-client/servant-client.cabal
View file

@ -15,6 +15,7 @@ maintainer: alpmestan@gmail.com
copyright: 2014 Zalora South East Asia Pte Ltd
category: Web
build-type: Simple
extra-source-files: include/*.h
cabal-version: >=1.10
tested-with: GHC >= 7.8
homepage: http://haskell-servant.github.io/
@ -49,6 +50,7 @@ library
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
include-dirs: include
test-suite spec
type: exitcode-stdio-1.0

227
servant-client/src/Servant/Client.hs
View file

@ -4,13 +4,13 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
#include "overlapping-compat.h"
-- | This module provides 'client' which can automatically generate
-- querying functions for each endpoint just from the type representing your
-- API.
@ -24,7 +24,6 @@ module Servant.Client
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad
import Control.Monad.Trans.Except
import Data.ByteString.Lazy (ByteString)
import Data.List
@ -45,7 +44,7 @@ import Servant.Common.Req
-- | 'client' allows you to produce operations to query an API from a client.
--
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books
-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
@ -119,80 +118,48 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
where p = unpack (toUrlPiece val)
-- | If you have a 'Delete' endpoint in your API, the client
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where
type Client (Delete cts' a) = ExceptT ServantError IO a
instance OVERLAPPABLE_
-- Note [Non-Empty Content Types]
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' a) where
type Client (Verb method status cts' a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager
snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager
where method = reflectMethod (Proxy :: Proxy method)
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasClient (Delete cts ()) where
type Client (Delete cts ()) = ExceptT ServantError IO ()
instance OVERLAPPING_
(ReflectMethod method) => HasClient (Verb method status cts NoContent) where
type Client (Verb method status cts NoContent) = ExceptT ServantError IO NoContent
clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodDelete req baseurl manager
performRequestNoBody method req baseurl manager >> return NoContent
where method = reflectMethod (Proxy :: Proxy method)
-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts)
) => HasClient (Delete cts' (Headers ls a)) where
type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
instance OVERLAPPING_
-- Note [Non-Empty Content Types]
( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' (Headers ls a)) where
type Client (Verb method status cts' (Headers ls a))
= ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager
let method = reflectMethod (Proxy :: Proxy method)
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl manager
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
-- | If you have a 'Get' endpoint in your API, the client
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
type Client (Get (ct ': cts) result) = ExceptT ServantError IO result
clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasClient (Get (ct ': cts) ()) where
type Client (Get (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager =
performRequestNoBody H.methodGet req baseurl manager
-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Get (ct ': cts) (Headers ls a)) where
type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
instance OVERLAPPING_
( BuildHeadersTo ls, ReflectMethod method
) => HasClient (Verb method status cts (Headers ls NoContent)) where
type Client (Verb method status cts (Headers ls NoContent))
= ExceptT ServantError IO (Headers ls NoContent)
clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager
return $ Headers { getResponse = resp
let method = reflectMethod (Proxy :: Proxy method)
hdrs <- performRequestNoBody method req baseurl manager
return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo hdrs
}
-- | If you use a 'Header' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'Header',
@ -236,117 +203,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
where hname = symbolVal (Proxy :: Proxy sym)
-- | If you have a 'Post' endpoint in your API, the client
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
type Client (Post (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasClient (Post (ct ': cts) ()) where
type Client (Post (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodPost req baseurl manager
-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Post (ct ': cts) (Headers ls a)) where
type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
-- | If you have a 'Put' endpoint in your API, the client
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
type Client (Put (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasClient (Put (ct ': cts) ()) where
type Client (Put (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodPut req baseurl manager
-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Put (ct ': cts) (Headers ls a)) where
type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl manager= do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
-- | If you have a 'Patch' endpoint in your API, the client
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasClient (Patch (ct ': cts) ()) where
type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodPatch req baseurl manager
-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Patch (ct ': cts) (Headers ls a)) where
type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
-- | If you use a 'QueryParam' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'QueryParam',
@ -549,3 +405,20 @@ instance HasClient api => HasClient (IsSecure :> api) where
clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy api) req baseurl manager
{- Note [Non-Empty Content Types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Rather than have
instance (..., cts' ~ (ct ': cts)) => ... cts' ...
It may seem to make more sense to have:
instance (...) => ... (ct ': cts) ...
But this means that if another instance exists that does *not* require
non-empty lists, but is otherwise more specific, no instance will be overall
more specific. This in turn generally means adding yet another instance (one
for empty and one for non-empty lists).
-}

19
servant-client/src/Servant/Common/Req.hs
View file

@ -142,7 +142,7 @@ performRequest reqMethod req reqHost manager = do
Right response -> do
let status = Client.responseStatus response
body = Client.responseBody response
hrds = Client.responseHeaders response
hdrs = Client.responseHeaders response
status_code = statusCode status
ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream"
@ -151,23 +151,26 @@ performRequest reqMethod req reqHost manager = do
Just t' -> pure t'
unless (status_code >= 200 && status_code < 300) $
throwE $ FailureResponse status ct body
return (status_code, body, ct, hrds, response)
return (status_code, body, ct, hdrs, response)
performRequestCT :: MimeUnrender ct result =>
Proxy ct -> Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result)
Proxy ct -> Method -> Req -> BaseUrl -> Manager
-> ExceptT ServantError IO ([HTTP.Header], result)
performRequestCT ct reqMethod req reqHost manager = do
let acceptCT = contentType ct
(_status, respBody, respCT, hrds, _response) <-
(_status, respBody, respCT, hdrs, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager
unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of
Left err -> throwE $ DecodeFailure err respCT respBody
Right val -> return (hrds, val)
Right val -> return (hdrs, val)
performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ()
performRequestNoBody reqMethod req reqHost manager =
void $ performRequest reqMethod req reqHost manager
performRequestNoBody :: Method -> Req -> BaseUrl -> Manager
-> ExceptT ServantError IO [HTTP.Header]
performRequestNoBody reqMethod req reqHost manager = do
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager
return hdrs
catchConnectionError :: IO a -> IO (Either ServantError a)
catchConnectionError action =

38
servant-client/test/Servant/ClientSpec.hs
View file

@ -6,9 +6,6 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
@ -20,6 +17,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
#include "overlapping-compat.h"
module Servant.ClientSpec where
#if !MIN_VERSION_base(4,8,0)
@ -92,7 +90,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
type Api =
"get" :> Get '[JSON] Person
:<|> "deleteEmpty" :> Delete '[] ()
:<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
:<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
:<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
@ -107,14 +105,14 @@ type Api =
ReqBody '[JSON] [(String, [Rational])] :>
Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
:<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
:<|> "deleteContentType" :> Delete '[JSON] ()
:<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
api :: Proxy Api
api = Proxy
server :: Application
server = serve api (
return alice
:<|> return ()
:<|> return NoContent
:<|> (\ name -> return $ Person name 0)
:<|> return
:<|> (\ name -> case name of
@ -127,7 +125,7 @@ server = serve api (
:<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True)
:<|> return ()
:<|> return NoContent
)
@ -159,11 +157,11 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do
let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager
(left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right ()
(left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right NoContent
it "allows content type" $ \(_, baseUrl) -> do
let getDeleteContentType = getLast $ client api baseUrl manager
(left show <$> runExceptT getDeleteContentType) `shouldReturn` Right ()
(left show <$> runExceptT getDeleteContentType) `shouldReturn` Right NoContent
it "Servant.API.Capture" $ \(_, baseUrl) -> do
let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager
@ -285,7 +283,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where
WrappedApi :: (HasServer api, Server api ~ ExceptT ServantErr IO a,
WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a,
HasClient api, Client api ~ ExceptT ServantError IO ()) =>
Proxy api -> WrappedApi
@ -323,33 +321,21 @@ pathGen = fmap NonEmpty path
class GetNth (n :: Nat) a b | n a -> b where
getNth :: Proxy n -> a -> b
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
instance OVERLAPPING_
GetNth 0 (x :<|> y) x where
getNth _ (x :<|> _) = x
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
instance OVERLAPPING_
(GetNth (n - 1) x y) => GetNth n (a :<|> x) y where
getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x
class GetLast a b | a -> b where
getLast :: a -> b
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
instance OVERLAPPING_
(GetLast b c) => GetLast (a :<|> b) c where
getLast (_ :<|> b) = getLast b
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
instance OVERLAPPING_
GetLast a a where
getLast a = a

2
servant-docs/README.md
View file

@ -6,7 +6,7 @@ Generate API docs for your *servant* webservice. Feel free to also take a look a
## Example
See [here](https://github.com/haskell-servant/servant/tree/master/servant-docs/blob/master/example/greet.md) for the output of the following program.
See [here](https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.md) for the output of the following program.
``` haskell
{-# LANGUAGE DataKinds #-}

8
servant-docs/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

5
servant-docs/servant-docs.cabal
View file

@ -19,6 +19,7 @@ tested-with: GHC >= 7.8
homepage: http://haskell-servant.github.io/
Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files:
include/*.h
CHANGELOG.md
README.md
source-repository head
@ -29,8 +30,11 @@ library
exposed-modules:
Servant.Docs
, Servant.Docs.Internal
, Servant.Docs.Internal.Pretty
build-depends:
base >=4.7 && <5
, aeson
, aeson-pretty
, bytestring
, bytestring-conversion
, case-insensitive
@ -46,6 +50,7 @@ library
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
include-dirs: include
executable greet-docs
main-is: greet.hs

6
servant-docs/src/Servant/Docs.hs
View file

@ -23,7 +23,7 @@
-- See example/greet.hs for an example.
module Servant.Docs
( -- * 'HasDocs' class and key functions
HasDocs(..), docs, markdown
HasDocs(..), docs, pretty, markdown
-- * Generating docs with extra information
, docsWith, docsWithIntros, docsWithOptions
, ExtraInfo(..), extraInfo
@ -41,8 +41,7 @@ module Servant.Docs
, ToCapture(..)
, -- * ADTs to represent an 'API'
Method(..)
, Endpoint, path, method, defEndpoint
Endpoint, path, method, defEndpoint
, API, apiIntros, apiEndpoints, emptyAPI
, DocCapture(..), capSymbol, capDesc
, DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind
@ -54,3 +53,4 @@ module Servant.Docs
) where
import Servant.Docs.Internal
import Servant.Docs.Internal.Pretty

200
servant-docs/src/Servant/Docs/Internal.hs
View file

@ -16,9 +16,8 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
#include "overlapping-compat.h"
module Servant.Docs.Internal where
import Control.Applicative
@ -37,7 +36,7 @@ import Data.Monoid
import Data.Ord (comparing)
import Data.Proxy (Proxy(Proxy))
import Data.String.Conversions (cs)
import Data.Text (Text, pack, unpack)
import Data.Text (Text, unpack)
import GHC.Exts (Constraint)
import GHC.Generics
import GHC.TypeLits
@ -50,21 +49,6 @@ import qualified Data.Text as T
import qualified Network.HTTP.Media as M
import qualified Network.HTTP.Types as HTTP
-- | Supported HTTP request methods
data Method = DocDELETE -- ^ the DELETE method
| DocGET -- ^ the GET method
| DocPOST -- ^ the POST method
| DocPUT -- ^ the PUT method
deriving (Eq, Ord, Generic)
instance Show Method where
show DocGET = "GET"
show DocPOST = "POST"
show DocDELETE = "DELETE"
show DocPUT = "PUT"
instance Hashable Method
-- | An 'Endpoint' type that holds the 'path' and the 'method'.
--
-- Gets used as the key in the 'API' hashmap. Modify 'defEndpoint'
@ -76,12 +60,12 @@ instance Hashable Method
-- GET /
-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
-- GET /foo
-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'
-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'
-- POST /foo
-- @
data Endpoint = Endpoint
{ _path :: [String] -- type collected
, _method :: Method -- type collected
, _method :: HTTP.Method -- type collected
} deriving (Eq, Ord, Generic)
instance Show Endpoint where
@ -95,7 +79,7 @@ showPath :: [String] -> String
showPath [] = "/"
showPath ps = concatMap ('/' :) ps
-- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET'
-- | An 'Endpoint' whose path is `"/"` and whose method is @GET@
--
-- Here's how you can modify it:
--
@ -104,11 +88,11 @@ showPath ps = concatMap ('/' :) ps
-- GET /
-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
-- GET /foo
-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'
-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'
-- POST /foo
-- @
defEndpoint :: Endpoint
defEndpoint = Endpoint [] DocGET
defEndpoint = Endpoint [] HTTP.methodGet
instance Hashable Endpoint
@ -477,8 +461,8 @@ instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
-- | Synthesise a sample value of a type, encoded in the specified media types.
sampleByteString
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
=> Proxy ctypes
:: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
=> Proxy (ct ': cts)
-> Proxy a
-> [(M.MediaType, ByteString)]
sampleByteString ctypes@Proxy Proxy =
@ -487,8 +471,8 @@ sampleByteString ctypes@Proxy Proxy =
-- | Synthesise a list of sample values of a particular type, encoded in the
-- specified media types.
sampleByteStrings
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
=> Proxy ctypes
:: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
=> Proxy (ct ': cts)
-> Proxy a
-> [(Text, M.MediaType, ByteString)]
sampleByteStrings ctypes@Proxy Proxy =
@ -661,10 +645,7 @@ markdown api = unlines $
-- | The generated docs for @a ':<|>' b@ just appends the docs
-- for @a@ with the docs for @b@.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
instance OVERLAPPABLE_
(HasDocs layout1, HasDocs layout2)
=> HasDocs (layout1 :<|> layout2) where
@ -692,149 +673,38 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)
symP = Proxy :: Proxy sym
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLe #-}
#endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a)
=> HasDocs (Delete cts a) where
instance OVERLAPPABLE_
(ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
, ReflectMethod method)
=> HasDocs (Verb method status (ct ': cts) a) where
docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action'
where endpoint' = endpoint & method .~ DocDELETE
where endpoint' = endpoint & method .~ method'
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t
t = Proxy :: Proxy cts
& response.respStatus .~ status
t = Proxy :: Proxy (ct ': cts)
method' = reflectMethod (Proxy :: Proxy method)
status = fromInteger $ natVal (Proxy :: Proxy status)
p = Proxy :: Proxy a
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a
, AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Delete cts (Headers ls a)) where
instance OVERLAPPING_
(ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
, ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls))
=> HasDocs (Verb method status (ct ': cts) (Headers ls a)) where
docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action'
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocDELETE
where endpoint' = endpoint & method .~ method'
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t
& response.respStatus .~ status
& response.respHeaders .~ hdrs
t = Proxy :: Proxy cts
p = Proxy :: Proxy a
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLe #-}
#endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a)
=> HasDocs (Get cts a) where
docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action'
where endpoint' = endpoint & method .~ DocGET
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t
t = Proxy :: Proxy cts
p = Proxy :: Proxy a
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a
, AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Get cts (Headers ls a)) where
docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action'
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocGET
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t
& response.respHeaders .~ hdrs
t = Proxy :: Proxy cts
p = Proxy :: Proxy a
instance (KnownSymbol sym, HasDocs sublayout)
=> HasDocs (Header sym a :> sublayout) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action')
where sublayoutP = Proxy :: Proxy sublayout
action' = over headers (|> headername) action
headername = pack $ symbolVal (Proxy :: Proxy sym)
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a)
=> HasDocs (Post cts a) where
docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action'
where endpoint' = endpoint & method .~ DocPOST
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t
& response.respStatus .~ 201
t = Proxy :: Proxy cts
p = Proxy :: Proxy a
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a
, AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Post cts (Headers ls a)) where
docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action'
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocPOST
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t
& response.respStatus .~ 201
& response.respHeaders .~ hdrs
t = Proxy :: Proxy cts
p = Proxy :: Proxy a
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a)
=> HasDocs (Put cts a) where
docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action'
where endpoint' = endpoint & method .~ DocPUT
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t
& response.respStatus .~ 200
t = Proxy :: Proxy cts
p = Proxy :: Proxy a
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( ToSample a, IsNonEmpty cts, AllMimeRender cts a,
AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Put cts (Headers ls a)) where
docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action'
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocPUT
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t
& response.respStatus .~ 200
& response.respHeaders .~ hdrs
t = Proxy :: Proxy cts
t = Proxy :: Proxy (ct ': cts)
hdrs = allHeaderToSample (Proxy :: Proxy ls)
method' = reflectMethod (Proxy :: Proxy method)
status = fromInteger $ natVal (Proxy :: Proxy status)
p = Proxy :: Proxy a
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
@ -877,8 +747,8 @@ instance HasDocs Raw where
-- example data. However, there's no reason to believe that the instances of
-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
-- both are even defined) for any particular type.
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
=> HasDocs (ReqBody cts a :> sublayout) where
instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout)
=> HasDocs (ReqBody (ct ': cts) a :> sublayout) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action')
@ -886,7 +756,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
where sublayoutP = Proxy :: Proxy sublayout
action' = action & rqbody .~ sampleByteString t p
& rqtypes .~ allMime t
t = Proxy :: Proxy cts
t = Proxy :: Proxy (ct ': cts)
p = Proxy :: Proxy a
instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where

48
servant-docs/src/Servant/Docs/Internal/Pretty.hs Normal file
View file

@ -0,0 +1,48 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
module Servant.Docs.Internal.Pretty where
import Data.Aeson (ToJSON(..))
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Proxy (Proxy(Proxy))
import Network.HTTP.Media ((//))
import Servant.API
-- | PrettyJSON content type.
data PrettyJSON
instance Accept PrettyJSON where
contentType _ = "application" // "json"
instance ToJSON a => MimeRender PrettyJSON a where
mimeRender _ = encodePretty
-- | Prettify generated JSON documentation.
--
-- @
-- 'docs' ('pretty' ('Proxy' :: 'Proxy' MyAPI))
-- @
pretty :: Proxy layout -> Proxy (Pretty layout)
pretty Proxy = Proxy
-- | Replace all JSON content types with PrettyJSON.
-- Kind-polymorphic so it can operate on kinds @*@ and @[*]@.
type family Pretty (layout :: k) :: k where
Pretty (x :<|> y) = Pretty x :<|> Pretty y
Pretty (x :> y) = Pretty x :> Pretty y
Pretty (Get cs r) = Get (Pretty cs) r
Pretty (Post cs r) = Post (Pretty cs) r
Pretty (Put cs r) = Put (Pretty cs) r
Pretty (Delete cs r) = Delete (Pretty cs) r
Pretty (Patch cs r) = Patch (Pretty cs) r
Pretty (ReqBody cs r) = ReqBody (Pretty cs) r
Pretty (JSON ': xs) = PrettyJSON ': xs
Pretty (x ': xs) = x ': Pretty xs
Pretty x = x

1
servant-docs/test/Servant/DocsSpec.hs
View file

@ -71,7 +71,6 @@ spec = describe "Servant.Docs" $ do
it "mentions status codes" $ do
md `shouldContain` "Status code 200"
md `shouldContain` "Status code 201"
it "mentions methods" $ do
md `shouldContain` "POST"

8
servant-examples/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

8
servant-foreign/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

4
servant-foreign/servant-foreign.cabal
View file

@ -18,6 +18,7 @@ category: Web
build-type: Simple
cabal-version: >=1.10
extra-source-files:
include/*.h
CHANGELOG.md
README.md
source-repository head
@ -30,15 +31,18 @@ library
, lens == 4.*
, servant == 0.5.*
, text >= 1.2 && < 1.3
, http-types
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
include-dirs: include
test-suite spec
type: exitcode-stdio-1.0
hs-source-dirs: test
ghc-options: -Wall
include-dirs: include
main-is: Spec.hs
other-modules:
Servant.ForeignSpec

56
servant-foreign/src/Servant/Foreign/Internal.hs
View file

@ -13,6 +13,7 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
-- | Generalizes all the data needed to make code generation work with
-- arbitrary programming languages.
@ -22,8 +23,10 @@ import Control.Lens (makeLenses, (%~), (&), (.~), (<>~))
import qualified Data.Char as C
import Data.Proxy
import Data.Text
import Data.Text.Encoding (decodeUtf8)
import GHC.Exts (Constraint)
import GHC.TypeLits
import qualified Network.HTTP.Types as HTTP
import Prelude hiding (concat)
import Servant.API
@ -86,11 +89,10 @@ defUrl :: Url
defUrl = Url [] []
type FunctionName = [Text]
type Method = Text
data Req = Req
{ _reqUrl :: Url
, _reqMethod :: Method
, _reqMethod :: HTTP.Method
, _reqHeaders :: [HeaderArg]
, _reqBody :: Maybe ForeignType
, _reqReturnType :: ForeignType
@ -185,27 +187,18 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (str, typeFor lang (Proxy :: Proxy a))
instance (Elem JSON list, HasForeignType lang a)
=> HasForeign lang (Delete list a) where
type Foreign (Delete list a) = Req
instance (Elem JSON list, HasForeignType lang a, ReflectMethod method)
=> HasForeign lang (Verb method status list a) where
type Foreign (Verb method status list a) = Req
foreignFor lang Proxy req =
req & funcName %~ ("delete" :)
& reqMethod .~ "DELETE"
& reqReturnType .~ retType
where
retType = typeFor lang (Proxy :: Proxy a)
instance (Elem JSON list, HasForeignType lang a)
=> HasForeign lang (Get list a) where
type Foreign (Get list a) = Req
foreignFor lang Proxy req =
req & funcName %~ ("get" :)
& reqMethod .~ "GET"
req & funcName %~ (methodLC :)
& reqMethod .~ method
& reqReturnType .~ retType
where
retType = typeFor lang (Proxy :: Proxy a)
method = reflectMethod (Proxy :: Proxy method)
methodLC = toLower $ decodeUtf8 method
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
=> HasForeign lang (Header sym a :> sublayout) where
@ -220,28 +213,6 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
arg = (hname, typeFor lang (Proxy :: Proxy a))
subP = Proxy :: Proxy sublayout
instance (Elem JSON list, HasForeignType lang a)
=> HasForeign lang (Post list a) where
type Foreign (Post list a) = Req
foreignFor lang Proxy req =
req & funcName %~ ("post" :)
& reqMethod .~ "POST"
& reqReturnType .~ retType
where
retType = typeFor lang (Proxy :: Proxy a)
instance (Elem JSON list, HasForeignType lang a)
=> HasForeign lang (Put list a) where
type Foreign (Put list a) = Req
foreignFor lang Proxy req =
req & funcName %~ ("put" :)
& reqMethod .~ "PUT"
& reqReturnType .~ retType
where
retType = typeFor lang (Proxy :: Proxy a)
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
=> HasForeign lang (QueryParam sym a :> sublayout) where
type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout
@ -279,10 +250,10 @@ instance (KnownSymbol sym, HasForeignType lang a, a ~ Bool, HasForeign lang subl
arg = (str, typeFor lang (Proxy :: Proxy a))
instance HasForeign lang Raw where
type Foreign Raw = Method -> Req
type Foreign Raw = HTTP.Method -> Req
foreignFor _ Proxy req method =
req & funcName %~ ((toLower method) :)
req & funcName %~ ((toLower $ decodeUtf8 method) :)
& reqMethod .~ method
instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout)
@ -346,4 +317,3 @@ instance (GenerateList start, GenerateList rest) => GenerateList (start :<|> res
-- describing one endpoint from your API type.
listFromAPI :: (HasForeign lang api, GenerateList (Foreign api)) => Proxy lang -> Proxy api -> [Req]
listFromAPI lang p = generateList (foreignFor lang p defReq)

9
servant-foreign/test/Servant/ForeignSpec.hs
View file

@ -7,9 +7,8 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#endif
#include "overlapping-compat.h"
module Servant.ForeignSpec where
@ -41,9 +40,9 @@ instance HasForeignType LangX Int where
typeFor _ _ = "intX"
instance HasForeignType LangX Bool where
typeFor _ _ = "boolX"
instance {-# Overlapping #-} HasForeignType LangX String where
instance OVERLAPPING_ HasForeignType LangX String where
typeFor _ _ = "stringX"
instance {-# Overlappable #-} HasForeignType LangX a => HasForeignType LangX [a] where
instance OVERLAPPABLE_ HasForeignType LangX a => HasForeignType LangX [a] where
typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a)
type TestApi

8
servant-js/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

2
servant-js/servant-js.cabal
View file

@ -22,6 +22,7 @@ cabal-version: >=1.10
homepage: http://haskell-servant.github.io/
Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files:
include/*.h
CHANGELOG.md
README.md
source-repository head
@ -49,6 +50,7 @@ library
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
include-dirs: include
executable counter
main-is: counter.hs

3
servant-js/src/Servant/JS/Angular.hs
View file

@ -6,6 +6,7 @@ import Data.Maybe (isJust)
import Data.Monoid
import qualified Data.Text as T
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Servant.Foreign
import Servant.JS.Internal
@ -68,7 +69,7 @@ generateAngularJSWith ngOptions opts req = "\n" <>
<> " { url: " <> url <> "\n"
<> dataBody
<> reqheaders
<> " , method: '" <> method <> "'\n"
<> " , method: '" <> decodeUtf8 method <> "'\n"
<> " });\n"
<> "}\n"

3
servant-js/src/Servant/JS/Axios.hs
View file

@ -5,6 +5,7 @@ import Control.Lens
import Data.Maybe (isJust)
import Data.Monoid
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text as T
import Servant.Foreign
import Servant.JS.Internal
@ -117,7 +118,7 @@ generateAxiosJSWith aopts opts req = "\n" <>
fname = namespace <> (functionNameBuilder opts $ req ^. funcName)
method = T.toLower $ req ^. reqMethod
method = T.toLower . decodeUtf8 $ req ^. reqMethod
url = if url' == "'" then "'/'" else url'
url' = "'"
<> urlPrefix opts

3
servant-js/src/Servant/JS/JQuery.hs
View file

@ -6,6 +6,7 @@ import Data.Maybe (isJust)
import Data.Monoid
import qualified Data.Text as T
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Servant.Foreign
import Servant.JS.Internal
@ -35,7 +36,7 @@ generateJQueryJSWith opts req = "\n" <>
<> dataBody
<> reqheaders
<> " , error: " <> onError <> "\n"
<> " , type: '" <> method <> "'\n"
<> " , type: '" <> decodeUtf8 method <> "'\n"
<> " });\n"
<> "}\n"

10
servant-js/src/Servant/JS/Vanilla.hs
View file

@ -4,6 +4,7 @@ module Servant.JS.Vanilla where
import Control.Lens
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text as T
import Data.Monoid
import Servant.Foreign
@ -31,14 +32,19 @@ generateVanillaJSWith opts req = "\n" <>
fname <> " = function(" <> argsStr <> ")\n"
<> "{\n"
<> " var xhr = new XMLHttpRequest();\n"
<> " xhr.open('" <> method <> "', " <> url <> ", true);\n"
<> " xhr.open('" <> decodeUtf8 method <> "', " <> url <> ", true);\n"
<> reqheaders
<> " xhr.setRequestHeader(\"Accept\",\"application/json\");\n"
<> (if isJust (req ^. reqBody) then " xhr.setRequestHeader(\"Content-Type\",\"application/json\");\n" else "")
<> " xhr.onreadystatechange = function (e) {\n"
<> " if (xhr.readyState == 4) {\n"
<> " if (xhr.status == 204 || xhr.status == 205) {\n"
<> " onSuccess();\n"
<> " } else if (xhr.status >= 200 && xhr.status < 300) {\n"
<> " var value = JSON.parse(xhr.responseText);\n"
<> " if (xhr.status == 200 || xhr.status == 201) {\n"
<> " onSuccess(value);\n"
<> " } else {\n"
<> " var value = JSON.parse(xhr.responseText);\n"
<> " onError(value);\n"
<> " }\n"
<> " }\n"

8
servant-lucid/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

3
servant-lucid/servant-lucid.cabal
View file

@ -13,7 +13,7 @@ maintainer: jkarni@gmail.com
-- copyright:
category: Web
build-type: Simple
-- extra-source-files:
extra-source-files: include/*.h
cabal-version: >=1.10
bug-reports: http://github.com/haskell-servant/servant/issues
source-repository head
@ -30,3 +30,4 @@ library
, servant == 0.5.*
hs-source-dirs: src
default-language: Haskell2010
include-dirs: include

15
servant-lucid/src/Servant/HTML/Lucid.hs
View file

@ -3,9 +3,8 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
#include "overlapping-compat.h"
-- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s
-- `ToHtml` class and `Html` datatype.
@ -28,16 +27,10 @@ data HTML deriving Typeable
instance Accept HTML where
contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
instance OVERLAPPABLE_
ToHtml a => MimeRender HTML a where
mimeRender _ = renderBS . toHtml
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
instance OVERLAPPING_
MimeRender HTML (Html a) where
mimeRender _ = renderBS

8
servant-mock/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

4
servant-mock/servant-mock.cabal
View file

@ -13,6 +13,7 @@ maintainer: alpmestan@gmail.com
copyright: 2015 Alp Mestanogullari
category: Web
build-type: Simple
extra-source-files: include/*.h
cabal-version: >=1.10
flag example
@ -31,9 +32,10 @@ library
servant-server >= 0.4,
transformers >= 0.3 && <0.5,
QuickCheck >= 2.7 && <2.9,
wai >= 3.0 && <3.1
wai >= 3.0 && <3.3
hs-source-dirs: src
default-language: Haskell2010
include-dirs: include
executable mock-app
main-is: main.hs

15
servant-mock/src/Servant/Mock.hs
View file

@ -139,19 +139,8 @@ instance (KnownSymbol s, HasMock rest) => HasMock (QueryFlag s :> rest) where
instance (KnownSymbol h, FromHttpApiData a, HasMock rest) => HasMock (Header h a :> rest) where
mock _ = \_ -> mock (Proxy :: Proxy rest)
instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Delete ctypes a) where
mock _ = mockArbitrary
instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Get ctypes a) where
mock _ = mockArbitrary
instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Patch ctypes a) where
mock _ = mockArbitrary
instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Post ctypes a) where
mock _ = mockArbitrary
instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Put ctypes a) where
instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)
=> HasMock (Verb method status ctypes a) where
mock _ = mockArbitrary
instance HasMock Raw where

8
servant-server/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

7
servant-server/servant-server.cabal
View file

@ -23,6 +23,7 @@ build-type: Simple
cabal-version: >=1.10
tested-with: GHC >= 7.8
extra-source-files:
include/*.h
CHANGELOG.md
README.md
bug-reports: http://github.com/haskell-servant/servant/issues
@ -62,14 +63,15 @@ library
, text >= 1.2 && < 1.3
, transformers >= 0.3 && < 0.5
, transformers-compat>= 0.4
, wai >= 3.0 && < 3.1
, wai >= 3.0 && < 3.3
, wai-app-static >= 3.0 && < 3.2
, warp >= 3.0 && < 3.2
, warp >= 3.0 && < 3.3
, time >= 1.4 && < 1.6
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
include-dirs: include
executable greet
main-is: greet.hs
@ -136,3 +138,4 @@ test-suite doctests
buildable: True
default-language: Haskell2010
ghc-options: -threaded
include-dirs: include

279
servant-server/src/Servant/Server/Internal.hs
View file

@ -8,9 +8,8 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
#include "overlapping-compat.h"
module Servant.Server.Internal
( module Servant.Server.Internal
@ -28,20 +27,27 @@ import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import Data.Maybe (fromMaybe, mapMaybe)
import Data.String (fromString)
import Data.String.Conversions (ConvertibleStrings, cs, (<>))
import Data.String.Conversions (cs, (<>))
import Data.Text (Text)
import Data.Typeable
import GHC.TypeLits (KnownSymbol, symbolVal)
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
symbolVal)
import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Socket (SockAddr)
import Network.Wai (Application, lazyRequestBody,
rawQueryString, requestHeaders,
requestMethod, responseLBS, remoteHost,
isSecure, vault, httpVersion, Response,
Request, pathInfo)
import Network.Wai (Application, Request, Response,
httpVersion, isSecure,
lazyRequestBody, pathInfo,
rawQueryString, remoteHost,
requestHeaders, requestMethod,
responseLBS, vault)
import Web.HttpApiData (FromHttpApiData)
import Web.HttpApiData.Internal (parseHeaderMaybe,
parseQueryParamMaybe,
parseUrlPieceMaybe)
import Servant.API ((:<|>) (..), (:>), Capture,
Delete, Get, Header,
IsSecure(..), Patch, Post, Put,
Verb, ReflectMethod(reflectMethod),
IsSecure(..), Header,
QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody, Vault)
import Servant.API.ContentTypes (AcceptHeader (..),
@ -56,8 +62,6 @@ import Servant.Server.Internal.Router
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr
import Web.HttpApiData (FromHttpApiData)
import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe)
class HasServer layout where
@ -132,8 +136,7 @@ allowedMethodHead method request = method == methodGet && requestMethod request
allowedMethod :: Method -> Request -> Bool
allowedMethod method request = allowedMethodHead method request || requestMethod request == method
processMethodRouter :: forall a. ConvertibleStrings a B.ByteString
=> Maybe (a, BL.ByteString) -> Status -> Method
processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method
-> Maybe [(HeaderName, B.ByteString)]
-> Request -> RouteResult Response
processMethodRouter handleA status method headers request = case handleA of
@ -186,106 +189,26 @@ methodRouterHeaders method proxy status action = LeafRouter route'
processMethodRouter handleA status method (Just headers) request
| otherwise = respond $ Fail err404
methodRouterEmpty :: Method
-> Delayed (ExceptT ServantErr IO ())
-> Router
methodRouterEmpty method action = LeafRouter route'
where
route' request respond
| pathIsEmpty request = do
runAction (addMethodCheck action (methodCheck method request)) respond $ \ () ->
Route $! responseLBS noContent204 [] ""
| otherwise = respond $ Fail err404
instance OVERLAPPABLE_
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
) => HasServer (Verb method status ctypes a) where
-- | 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 @ExceptT ServantErr IO ()@.
-- The 'Int' represents the status code and the 'String' a message
-- to be returned. You can use 'Control.Monad.Trans.Except.throwE' to
-- painlessly error out if the conditions for a successful deletion
-- are not met.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( AllCTRender ctypes a
) => HasServer (Delete ctypes a) where
type ServerT (Verb method status ctypes a) m = m a
type ServerT (Delete ctypes a) m = m a
route Proxy = methodRouter method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200
instance OVERLAPPING_
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
, GetHeaders (Headers h a)
) => HasServer (Verb method status ctypes (Headers h a)) where
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasServer (Delete ctypes ()) where
type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
type ServerT (Delete ctypes ()) m = m ()
route Proxy = methodRouterEmpty methodDelete
-- Add response headers
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Delete ctypes (Headers h v)) where
type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200
-- | 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
-- @ExceptT ServantErr 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.Except.throwE'
-- 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
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( AllCTRender ctypes a ) => HasServer (Get ctypes a) where
type ServerT (Get ctypes a) m = m a
route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200
-- '()' ==> 204 No Content
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasServer (Get ctypes ()) where
type ServerT (Get ctypes ()) m = m ()
route Proxy = methodRouterEmpty methodGet
-- Add response headers
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Get ctypes (Headers h v)) where
type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200
route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
-- | If you use 'Header' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
@ -318,140 +241,6 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
in route (Proxy :: Proxy sublayout) (passToServer subserver mheader)
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
-- @ExceptT ServantErr 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.Except.throwE'
-- 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
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( AllCTRender ctypes a
) => HasServer (Post ctypes a) where
type ServerT (Post ctypes a) m = m a
route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasServer (Post ctypes ()) where
type ServerT (Post ctypes ()) m = m ()
route Proxy = methodRouterEmpty methodPost
-- Add response headers
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Post ctypes (Headers h v)) where
type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201
-- | 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
-- @ExceptT ServantErr 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.Except.throwE'
-- 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
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( AllCTRender ctypes a) => HasServer (Put ctypes a) where
type ServerT (Put ctypes a) m = m a
route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasServer (Put ctypes ()) where
type ServerT (Put ctypes ()) m = m ()
route Proxy = methodRouterEmpty methodPut
-- Add response headers
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Put ctypes (Headers h v)) where
type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200
-- | 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
-- @ExceptT ServantErr 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.Except.throwE'
-- 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
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( AllCTRender ctypes a) => HasServer (Patch ctypes a) where
type ServerT (Patch ctypes a) m = m a
route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasServer (Patch ctypes ()) where
type ServerT (Patch ctypes ()) m = m ()
route Proxy = methodRouterEmpty methodPatch
-- Add response headers
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Patch ctypes (Headers h v)) where
type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200
-- | 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'@.

2
servant-server/test/Doctests.hs
View file

@ -10,7 +10,7 @@ main :: IO ()
main = do
files <- find always (extension ==? ".hs") "src"
mCabalMacrosFile <- getCabalMacrosFile
doctest $ "-isrc" :
doctest $ "-isrc" : "-Iinclude" :
(maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++
"-XOverloadedStrings" :
"-XFlexibleInstances" :

2
servant-server/test/Servant/Server/ErrorSpec.hs
View file

@ -162,7 +162,7 @@ errorRetrySpec = describe "Handler search"
it "should continue when URLs don't match" $ do
request methodPost "" [jsonCT, jsonAccept] jsonBody
`shouldRespondWith` 201 { matchBody = Just $ encode (7 :: Int) }
`shouldRespondWith` 200 { matchBody = Just $ encode (7 :: Int) }
it "should continue when methods don't match" $ do
request methodGet "a" [jsonCT, jsonAccept] jsonBody

2
servant-server/test/Servant/Server/Internal/EnterSpec.hs
View file

@ -52,7 +52,7 @@ enterSpec = describe "Enter" $ do
it "allows running arbitrary monads" $ do
get "int" `shouldRespondWith` "1797"
post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 }
post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 }
with (return (serve combinedAPI combinedReaderServer)) $ do
it "allows combnation of enters" $ do

481
servant-server/test/Servant/ServerSpec.hs
View file

@ -3,8 +3,10 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
@ -13,7 +15,7 @@ module Servant.ServerSpec where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (forM_, when)
import Control.Monad (forM_, when, unless)
import Control.Monad.Trans.Except (ExceptT, throwE)
import Data.Aeson (FromJSON, ToJSON, decode', encode)
import Data.ByteString.Conversion ()
@ -23,30 +25,37 @@ 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, methodHead,
methodPatch, methodPost, methodPut,
ok200, parseQuery, Status(..))
import Network.HTTP.Types (Status (..), hAccept, hContentType,
methodDelete, methodGet,
methodHead, methodPatch,
methodPost, methodPut, ok200,
parseQuery)
import Network.Wai (Application, Request, pathInfo,
queryString, rawQueryString,
responseLBS, responseBuilder)
import Network.Wai.Internal (Response(ResponseBuilder))
responseBuilder, responseLBS)
import Network.Wai.Internal (Response (ResponseBuilder))
import Network.Wai.Test (defaultRequest, request,
runSession, simpleBody)
runSession, simpleBody,
simpleHeaders, simpleStatus)
import Servant.API ((:<|>) (..), (:>), Capture, Delete,
FTime(..),
Get, Header (..), Headers,
HttpVersion, IsSecure (..), JSON,
Patch, PlainText, Post, Put,
Get, FTime(..), Header (..),
Headers, HttpVersion,
IsSecure (..), JSON,
NoContent (..), Patch, PlainText,
Post, Put,
QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody,
addHeader)
import Servant.Server (Server, serve, ServantErr(..), err404)
import Test.Hspec (Spec, describe, it, shouldBe)
StdMethod (..), Verb, addHeader)
import Servant.Server (ServantErr (..), Server, err404,
serve)
import Test.Hspec (Spec, context, describe, it,
shouldBe, shouldContain)
import Test.Hspec.Wai (get, liftIO, matchHeaders,
matchStatus, post, request,
matchStatus, request,
shouldRespondWith, with, (<:>))
import Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(..))
import Servant.Server.Internal.RoutingApplication
(toApplication, RouteResult(..))
import Servant.Server.Internal.Router
(tweakResponse, runRouter,
Router, Router'(LeafRouter))
@ -55,55 +64,109 @@ import Data.Time.LocalTime (LocalTime(..), hoursToTimeZone,
localTimeToUTC, makeTimeOfDayValid)
import Data.Time.Clock (UTCTime)
import Data.ByteString.Lazy (ByteString)
-- * 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
-- *Specs
spec :: Spec
spec = do
verbSpec
captureSpec
captureTimeSpec
getSpec
headSpec
postSpec
putSpec
patchSpec
queryParamSpec
reqBodySpec
headerSpec
rawSpec
unionSpec
routerSpec
alternativeSpec
responseHeadersSpec
miscReqCombinatorsSpec
routerSpec
miscCombinatorSpec
------------------------------------------------------------------------------
-- * verbSpec {{{
------------------------------------------------------------------------------
type VerbApi method status
= Verb method status '[JSON] Person
:<|> "noContent" :> Verb method status '[JSON] NoContent
:<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)
:<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)
verbSpec :: Spec
verbSpec = describe "Servant.API.Verb" $ do
let server :: Server (VerbApi method status)
server = return alice
:<|> return NoContent
:<|> return (addHeader 5 alice)
:<|> return (addHeader 10 NoContent)
get200 = Proxy :: Proxy (VerbApi 'GET 200)
post210 = Proxy :: Proxy (VerbApi 'POST 210)
put203 = Proxy :: Proxy (VerbApi 'PUT 203)
delete280 = Proxy :: Proxy (VerbApi 'DELETE 280)
patch214 = Proxy :: Proxy (VerbApi 'PATCH 214)
wrongMethod m = if m == methodPatch then methodPost else methodPatch
test desc api method (status :: Int) = context desc $
with (return $ serve api server) $ do
-- HEAD and 214/215 need not return bodies
unless (status `elem` [214, 215] || method == methodHead) $
it "returns the person" $ do
response <- Test.Hspec.Wai.request method "/" [] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` status
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
it "returns no content on NoContent" $ do
response <- Test.Hspec.Wai.request method "/noContent" [] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` status
liftIO $ simpleBody response `shouldBe` ""
-- HEAD should not return body
when (method == methodHead) $
it "HEAD returns no content body" $ do
response <- Test.Hspec.Wai.request method "/" [] ""
liftIO $ simpleBody response `shouldBe` ""
it "throws 405 on wrong method " $ do
Test.Hspec.Wai.request (wrongMethod method) "/" [] ""
`shouldRespondWith` 405
it "returns headers" $ do
response1 <- Test.Hspec.Wai.request method "/header" [] ""
liftIO $ statusCode (simpleStatus response1) `shouldBe` status
liftIO $ simpleHeaders response1 `shouldContain` [("H", "5")]
response2 <- Test.Hspec.Wai.request method "/header" [] ""
liftIO $ statusCode (simpleStatus response2) `shouldBe` status
liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")]
it "handles trailing '/' gracefully" $ do
response <- Test.Hspec.Wai.request method "/headerNC/" [] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` status
it "returns 406 if the Accept header is not supported" $ do
Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 406
it "responds if the Accept header is supported" $ do
response <- Test.Hspec.Wai.request method ""
[(hAccept, "application/json")] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` status
it "sets the Content-Type header" $ do
response <- Test.Hspec.Wai.request method "" [] ""
liftIO $ simpleHeaders response `shouldContain`
[("Content-Type", "application/json")]
test "GET 200" get200 methodGet 200
test "POST 210" post210 methodPost 210
test "PUT 203" put203 methodPut 203
test "DELETE 280" delete280 methodDelete 280
test "PATCH 214" patch214 methodPatch 214
test "GET 200 with HEAD" get200 methodHead 200
-- }}}
------------------------------------------------------------------------------
-- * captureSpec {{{
------------------------------------------------------------------------------
type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
captureApi :: Proxy CaptureApi
@ -133,6 +196,11 @@ captureSpec = do
it "strips the captured path snippet from pathInfo" $ do
get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
-- }}}
------------------------------------------------------------------------------
-- * timeCaptureSpec {{{
------------------------------------------------------------------------------
type TimeFormatWSpace = "%Y-%m-%d %H:%M:%S%Z"
type CaptureTimeApi = (Capture "date" (FTime "%Y-%m-%d" Day) :> Get '[PlainText] String)
@ -177,64 +245,10 @@ captureTimeSpec = do
it "strips the captured path snippet from pathInfo" $ do
get "/2015-12-02%2012:34:56+1000/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
type GetApi = Get '[JSON] Person
:<|> "empty" :> Get '[] ()
:<|> "post" :> Post '[] ()
getApi :: Proxy GetApi
getApi = Proxy
getSpec :: Spec
getSpec = do
describe "Servant.API.Get" $ do
let server = return alice :<|> return () :<|> 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 406 if the Accept header is not supported" $ do
Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 406
headSpec :: Spec
headSpec = do
describe "Servant.API.Head" $ do
let server = return alice :<|> return () :<|> return ()
with (return $ serve getApi server) $ do
it "allows to GET a Person" $ do
response <- Test.Hspec.Wai.request methodHead "/" [] ""
return response `shouldRespondWith` 200
liftIO $ decode' (simpleBody response) `shouldBe` (Nothing :: Maybe Person)
it "does not allow HEAD to POST route" $ do
response <- Test.Hspec.Wai.request methodHead "/post" [] ""
return response `shouldRespondWith` 405
it "throws 405 (wrong method) on POSTs" $ do
post "/" "" `shouldRespondWith` 405
post "/empty" "" `shouldRespondWith` 405
it "returns 204 if the type is '()'" $ do
response <- Test.Hspec.Wai.request methodHead "/empty" [] ""
return response `shouldRespondWith` ""{ matchStatus = 204 }
it "returns 406 if the Accept header is not supported" $ do
Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 406
-- }}}
------------------------------------------------------------------------------
-- * queryParamSpec {{{
------------------------------------------------------------------------------
type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
:<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
@ -319,131 +333,41 @@ queryParamSpec = do
name = "Alice"
}
type PostApi =
ReqBody '[JSON] Person :> Post '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
:<|> "empty" :> Post '[] ()
-- }}}
------------------------------------------------------------------------------
-- * reqBodySpec {{{
------------------------------------------------------------------------------
type ReqBodyApi = ReqBody '[JSON] Person :> Post '[JSON] Person
:<|> "blah" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
postApi :: Proxy PostApi
postApi = Proxy
reqBodyApi :: Proxy ReqBodyApi
reqBodyApi = 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")]
reqBodySpec :: Spec
reqBodySpec = describe "Servant.API.ReqBody" $ do
it "allows to POST a Person" $ do
post' "/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201
}
let server :: Server ReqBodyApi
server = return :<|> return . age
mkReq method x = Test.Hspec.Wai.request method x
[(hContentType, "application/json;charset=utf-8")]
it "allows alternative routes if all have request bodies" $ do
post' "/bla" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201
}
with (return $ serve reqBodyApi server) $ do
it "handles trailing '/' gracefully" $ do
post' "/bla/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201
}
it "passes the argument to the handler" $ do
response <- mkReq methodPost "" (encode alice)
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
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 "rejects invalid request bodies with status 400" $ do
mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400
it "responds with 415 if the request body media type is unsupported" $ do
let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
, "application/nonsense")]
post'' "/" "anything at all" `shouldRespondWith` 415
Test.Hspec.Wai.request methodPost "/"
[(hContentType, "application/nonsense")] "" `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 request body 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 request body media type is unsupported" $ do
let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
, "application/nonsense")]
patch'' "/" "anything at all" `shouldRespondWith` 415
-- }}}
------------------------------------------------------------------------------
-- * headerSpec {{{
------------------------------------------------------------------------------
type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] ()
headerApi :: Proxy (HeaderApi a)
@ -461,23 +385,30 @@ headerSpec = describe "Servant.API.Header" $ do
expectsString Nothing = error "Expected a string"
with (return (serve headerApi expectsInt)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")]
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")]
it "passes the header to the handler (Int)" $
delete' "/" "" `shouldRespondWith` 204
delete' "/" "" `shouldRespondWith` 200
with (return (serve headerApi expectsString)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")]
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")]
it "passes the header to the handler (String)" $
delete' "/" "" `shouldRespondWith` 204
delete' "/" "" `shouldRespondWith` 200
-- }}}
------------------------------------------------------------------------------
-- * rawSpec {{{
------------------------------------------------------------------------------
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_)
rawApplication f request_ respond = respond $ responseLBS ok200 []
(cs $ show $ f request_)
rawSpec :: Spec
rawSpec = do
@ -498,7 +429,10 @@ rawSpec = do
liftIO $ do
simpleBody response `shouldBe` cs (show ["bar" :: String])
-- }}}
------------------------------------------------------------------------------
-- * alternativeSpec {{{
------------------------------------------------------------------------------
type AlternativeApi =
"foo" :> Get '[JSON] Person
:<|> "bar" :> Get '[JSON] Animal
@ -506,11 +440,12 @@ type AlternativeApi =
:<|> "bar" :> Post '[JSON] Animal
:<|> "bar" :> Put '[JSON] Animal
:<|> "bar" :> Delete '[JSON] ()
unionApi :: Proxy AlternativeApi
unionApi = Proxy
unionServer :: Server AlternativeApi
unionServer =
alternativeApi :: Proxy AlternativeApi
alternativeApi = Proxy
alternativeServer :: Server AlternativeApi
alternativeServer =
return alice
:<|> return jerry
:<|> return "a string"
@ -518,10 +453,10 @@ unionServer =
:<|> return jerry
:<|> return ()
unionSpec :: Spec
unionSpec = do
alternativeSpec :: Spec
alternativeSpec = do
describe "Servant.API.Alternative" $ do
with (return $ serve unionApi unionServer) $ do
with (return $ serve alternativeApi alternativeServer) $ do
it "unions endpoints" $ do
response <- get "/foo"
@ -538,7 +473,10 @@ unionSpec = do
it "returns 404 if the path does not exist" $ do
get "/nonexistent" `shouldRespondWith` 404
-- }}}
------------------------------------------------------------------------------
-- * responseHeaderSpec {{{
------------------------------------------------------------------------------
type ResponseHeadersApi =
Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
:<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
@ -555,26 +493,29 @@ responseHeadersSpec :: Spec
responseHeadersSpec = describe "ResponseHeaders" $ do
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do
let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)]
let methods = [methodGet, methodPost, methodPut, methodPatch]
it "includes the headers in the response" $
forM_ methods $ \(method, expected) ->
forM_ methods $ \method ->
Test.Hspec.Wai.request method "/" [] ""
`shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]
, matchStatus = expected
, matchStatus = 200
}
it "responds with not found for non-existent endpoints" $
forM_ methods $ \(method,_) ->
forM_ methods $ \method ->
Test.Hspec.Wai.request method "blahblah" [] ""
`shouldRespondWith` 404
it "returns 406 if the Accept header is not supported" $
forM_ methods $ \(method,_) ->
forM_ methods $ \method ->
Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 406
-- }}}
------------------------------------------------------------------------------
-- * routerSpec {{{
------------------------------------------------------------------------------
routerSpec :: Spec
routerSpec = do
describe "Servant.Server.Internal.Router" $ do
@ -593,6 +534,10 @@ routerSpec = do
it "calls f on route result" $ do
get "" `shouldRespondWith` 202
-- }}}
------------------------------------------------------------------------------
-- * miscCombinatorSpec {{{
------------------------------------------------------------------------------
type MiscCombinatorsAPI
= "version" :> HttpVersion :> Get '[JSON] String
:<|> "secure" :> IsSecure :> Get '[JSON] String
@ -611,8 +556,8 @@ miscServ = versionHandler
secureHandler NotSecure = return "not secure"
hostHandler = return . show
miscReqCombinatorsSpec :: Spec
miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $
miscCombinatorSpec :: Spec
miscCombinatorSpec = with (return $ serve miscApi miscServ) $
describe "Misc. combinators for request inspection" $ do
it "Successfully gets the HTTP version specified in the request" $
go "/version" "\"HTTP/1.0\""
@ -624,3 +569,35 @@ miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $
go "/host" "\"0.0.0.0:0\""
where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res
-- }}}
------------------------------------------------------------------------------
-- * 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
-- }}}

7
servant-server/test/Servant/Utils/StaticFilesSpec.hs
View file

@ -15,12 +15,7 @@ import System.IO.Temp (withSystemTempDirectory)
import Test.Hspec (Spec, around_, describe, it)
import Test.Hspec.Wai (get, shouldRespondWith, with)
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.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)
import Servant.Server (Server, serve)
import Servant.ServerSpec (Person (Person))
import Servant.Utils.StaticFiles (serveDirectory)

2
servant/CHANGELOG.md
View file

@ -7,6 +7,8 @@ HEAD
* Use `http-api-data` instead of `Servant.Common.Text`
* Remove matrix params.
* Add PlainText String MimeRender and MimeUnrender instances.
* Add new `Verbs` combinator, and make all existing and new verb combinators
type synonyms of it.
0.4.2
-----

8
servant/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

10
servant/servant.cabal
View file

@ -16,6 +16,7 @@ maintainer: alpmestan@gmail.com
copyright: 2014 Zalora South East Asia Pte Ltd
category: Web
build-type: Simple
extra-source-files: include/*.h
cabal-version: >=1.10
tested-with: GHC >= 7.8
source-repository head
@ -28,14 +29,9 @@ library
Servant.API.Alternative
Servant.API.Capture
Servant.API.ContentTypes
Servant.API.Delete
Servant.API.Get
Servant.API.Header
Servant.API.HttpVersion
Servant.API.IsSecure
Servant.API.Patch
Servant.API.Post
Servant.API.Put
Servant.API.QueryParam
Servant.API.Raw
Servant.API.RemoteHost
@ -44,6 +40,7 @@ library
Servant.API.Sub
Servant.API.Times
Servant.API.Vault
Servant.API.Verbs
Servant.Utils.Links
build-depends:
base >=4.7 && <5
@ -87,6 +84,7 @@ library
, TypeSynonymInstances
, UndecidableInstances
ghc-options: -Wall
include-dirs: include
test-suite spec
type: exitcode-stdio-1.0
@ -107,7 +105,6 @@ test-suite spec
, hspec == 2.*
, QuickCheck
, quickcheck-instances
, parsec
, servant
, string-conversions
, text
@ -125,3 +122,4 @@ test-suite doctests
buildable: True
default-language: Haskell2010
ghc-options: -threaded
include-dirs: include

40
servant/src/Servant/API.hs
View file

@ -29,16 +29,7 @@ module Servant.API (
-- * Actual endpoints, distinguished by HTTP method
module Servant.API.Get,
-- | @GET@ requests
module Servant.API.Post,
-- | @POST@ requests
module Servant.API.Delete,
-- | @DELETE@ requests
module Servant.API.Put,
-- | @PUT@ requests
module Servant.API.Patch,
-- | @PATCH@ requests
module Servant.API.Verbs,
-- * Content Types
module Servant.API.ContentTypes,
@ -65,17 +56,12 @@ import Servant.API.Alternative ((:<|>) (..))
import Servant.API.Capture (Capture)
import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
FromFormUrlEncoded (..), JSON,
MimeRender (..),
MimeRender (..), NoContent (NoContent),
MimeUnrender (..), OctetStream,
PlainText, ToFormUrlEncoded (..))
import Servant.API.Delete (Delete)
import Servant.API.Get (Get)
import Servant.API.Header (Header (..))
import Servant.API.HttpVersion (HttpVersion (..))
import Servant.API.IsSecure (IsSecure (..))
import Servant.API.Patch (Patch)
import Servant.API.Post (Post)
import Servant.API.Put (Put)
import Servant.API.QueryParam (QueryFlag, QueryParam,
QueryParams)
import Servant.API.Raw (Raw)
@ -89,7 +75,25 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader),
import Servant.API.Sub ((:>))
import Servant.API.Times (FTime(..), toProxy, getFormat, renderTime, parseTime)
import Servant.API.Vault (Vault)
import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))
import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted,
DeleteNoContent,
DeleteNonAuthoritative, Get,
GetAccepted, GetNoContent,
GetNonAuthoritative,
GetPartialContent,
GetResetContent,
Patch,
PatchAccepted, PatchNoContent,
PatchNoContent,
PatchNonAuthoritative, Post,
PostAccepted, PostNoContent,
PostNonAuthoritative,
PostResetContent, Put,
PutAccepted, PutNoContent,
PutNoContent, PutNonAuthoritative,
ReflectMethod (reflectMethod),
Verb, StdMethod(..))
import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
URI (..), safeLink)
import Web.HttpApiData (FromHttpApiData (..),
ToHttpApiData (..))

61
servant/src/Servant/API/ContentTypes.hs
View file

@ -2,6 +2,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
@ -12,6 +13,8 @@
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
#include "overlapping-compat.h"
-- | A collection of basic Content-Types (also known as Internet Media
-- Types, or MIME types). Additionally, this module provides classes that
-- encapsulate how to serialize or deserialize values to or from
@ -19,7 +22,7 @@
--
-- Content-Types are used in `ReqBody` and the method combinators:
--
-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] :> Book
-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] Book
--
-- Meaning the endpoint accepts requests of Content-Type @application/json@
-- or @text/plain;charset-utf8@, and returns data in either one of those
@ -53,6 +56,9 @@ module Servant.API.ContentTypes
, MimeRender(..)
, MimeUnrender(..)
-- * NoContent
, NoContent(..)
-- * Internal
, AcceptHeader(..)
, AllCTRender(..)
@ -62,7 +68,6 @@ module Servant.API.ContentTypes
, AllMimeUnrender(..)
, FromFormUrlEncoded(..)
, ToFormUrlEncoded(..)
, IsNonEmpty
, eitherDecodeLenient
, canHandleAcceptH
) where
@ -72,8 +77,7 @@ import Control.Applicative ((*>), (<*))
#endif
import Control.Arrow (left)
import Control.Monad
import Data.Aeson (FromJSON, ToJSON, encode,
parseJSON)
import Data.Aeson (FromJSON(..), ToJSON(..), encode)
import Data.Aeson.Parser (value)
import Data.Aeson.Types (parseEither)
import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly,
@ -91,7 +95,7 @@ import qualified Data.Text.Encoding as TextS
import qualified Data.Text.Lazy as TextL
import qualified Data.Text.Lazy.Encoding as TextL
import Data.Typeable
import GHC.Exts (Constraint)
import GHC.Generics (Generic)
import qualified Network.HTTP.Media as M
import Network.URI (escapeURIString,
isUnreserved, unEscapeString)
@ -137,7 +141,7 @@ instance Accept OctetStream where
contentType _ = "application" M.// "octet-stream"
newtype AcceptHeader = AcceptHeader BS.ByteString
deriving (Eq, Show)
deriving (Eq, Show, Read, Typeable, Generic)
-- * Render (serializing)
@ -159,19 +163,19 @@ newtype AcceptHeader = AcceptHeader BS.ByteString
class Accept ctype => MimeRender ctype a where
mimeRender :: Proxy ctype -> a -> ByteString
class (AllMimeRender list a) => AllCTRender (list :: [*]) a where
class (AllMime list) => AllCTRender (list :: [*]) a where
-- If the Accept header can be matched, returns (Just) a tuple of the
-- Content-Type and response (serialization of @a@ into the appropriate
-- mimetype).
handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where
instance OVERLAPPABLE_
(AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where
handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
where pctyps = Proxy :: Proxy ctyps
where pctyps = Proxy :: Proxy (ct ': cts)
amrs = allMimeRender pctyps val
lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs
--------------------------------------------------------------------------
-- * Unrender
@ -199,14 +203,13 @@ instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where
class Accept ctype => MimeUnrender ctype a where
mimeUnrender :: Proxy ctype -> ByteString -> Either String a
class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where
class AllCTUnrender (list :: [*]) a where
handleCTypeH :: Proxy list
-> ByteString -- Content-Type header
-> ByteString -- Request body
-> Maybe (Either String a)
instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
) => AllCTUnrender ctyps a where
instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
@ -235,11 +238,12 @@ class (AllMime list) => AllMimeRender (list :: [*]) a where
-> a -- value to serialize
-> [(M.MediaType, ByteString)] -- content-types/response pairs
instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)]
where pctyp = Proxy :: Proxy ctyp
instance ( MimeRender ctyp a
instance OVERLAPPABLE_
( MimeRender ctyp a
, AllMimeRender (ctyp' ': ctyps) a
) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
allMimeRender _ a = (contentType pctyp, mimeRender pctyp a)
@ -248,8 +252,17 @@ instance ( MimeRender ctyp a
pctyps = Proxy :: Proxy (ctyp' ': ctyps)
instance AllMimeRender '[] a where
allMimeRender _ _ = []
-- Ideally we would like to declare a 'MimeRender a NoContent' instance, and
-- then this would be taken care of. However there is no more specific instance
-- between that and 'MimeRender JSON a', so we do this instead
instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
allMimeRender _ _ = [(contentType pctyp, "")]
where pctyp = Proxy :: Proxy ctyp
instance OVERLAPPING_
( AllMime (ctyp ': ctyp' ': ctyps)
) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where
allMimeRender p _ = zip (allMime p) (repeat "")
--------------------------------------------------------------------------
-- Check that all elements of list are instances of MimeUnrender
@ -270,21 +283,19 @@ instance ( MimeUnrender ctyp a
where pctyp = Proxy :: Proxy ctyp
pctyps = Proxy :: Proxy ctyps
type family IsNonEmpty (list :: [*]) :: Constraint where
IsNonEmpty (x ': xs) = ()
--------------------------------------------------------------------------
-- * MimeRender Instances
-- | `encode`
instance ToJSON a => MimeRender JSON a where
instance OVERLAPPABLE_
ToJSON a => MimeRender JSON a where
mimeRender _ = encode
-- | @encodeFormUrlEncoded . toFormUrlEncoded@
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@)
instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
instance OVERLAPPABLE_
ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded
-- | `TextL.encodeUtf8`
@ -307,6 +318,10 @@ instance MimeRender OctetStream ByteString where
instance MimeRender OctetStream BS.ByteString where
mimeRender _ = fromStrict
-- | A type for responses without content-body.
data NoContent = NoContent
deriving (Show, Eq, Read)
--------------------------------------------------------------------------
-- * MimeUnrender Instances

24
servant/src/Servant/API/Delete.hs
View file

@ -1,24 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Delete (Delete) where
import Data.Typeable (Typeable)
-- | Combinator for DELETE requests.
--
-- Example:
--
-- >>> -- DELETE /books/:isbn
-- >>> type MyApi = "books" :> Capture "isbn" Text :> Delete '[] ()
data Delete (contentTypes :: [*]) a
deriving Typeable
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }

22
servant/src/Servant/API/Get.hs
View file

@ -1,22 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Get (Get) where
import Data.Typeable (Typeable)
-- | Endpoint for simple GET requests. Serves the result as JSON.
--
-- Example:
--
-- >>> type MyApi = "books" :> Get '[JSON] [Book]
data Get (contentTypes :: [*]) a
deriving Typeable
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }

29
servant/src/Servant/API/Patch.hs
View file

@ -1,29 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Patch (Patch) where
import Data.Typeable (Typeable)
-- | Endpoint for PATCH requests. The type variable represents the type of the
-- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for
-- that).
--
-- If the HTTP response is empty, only () is supported.
--
-- Example:
--
-- >>> -- PATCH /books
-- >>> -- with a JSON encoded Book as the request body
-- >>> -- returning the just-created Book
-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Patch '[JSON] Book
data Patch (contentTypes :: [*]) a
deriving Typeable
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }

27
servant/src/Servant/API/Post.hs
View file

@ -1,27 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Post (Post) where
import Data.Typeable (Typeable)
-- | Endpoint for POST requests. The type variable represents the type of the
-- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for
-- that).
--
-- Example:
--
-- >>> -- POST /books
-- >>> -- with a JSON encoded Book as the request body
-- >>> -- returning the just-created Book
-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
data Post (contentTypes :: [*]) a
deriving Typeable
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }

25
servant/src/Servant/API/Put.hs
View file

@ -1,25 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Put (Put) where
import Data.Typeable (Typeable)
-- | 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 '[JSON] Book :> Put '[JSON] Book
data Put (contentTypes :: [*]) a
deriving Typeable
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }

65
servant/src/Servant/API/ResponseHeaders.hs
View file

@ -12,11 +12,9 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
{-# OPTIONS_HADDOCK not-home #-}
#include "overlapping-compat.h"
-- | This module provides facilities for adding headers to a response.
--
-- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int
@ -68,19 +66,12 @@ class BuildHeadersTo hs where
-- the values are interspersed with commas before deserialization (see
-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>)
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
BuildHeadersTo '[] where
instance OVERLAPPING_ BuildHeadersTo '[] where
buildHeadersTo _ = HNil
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( FromByteString v, BuildHeadersTo xs, KnownSymbol h, Contains h xs ~ 'False
) => BuildHeadersTo ((Header h v) ': xs) where
instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h
, Contains h xs ~ 'False)
=> BuildHeadersTo ((Header h v) ': xs) where
buildHeadersTo headers =
let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers
@ -96,38 +87,22 @@ instance
class GetHeaders ls where
getHeaders :: ls -> [HTTP.Header]
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
GetHeaders (HList '[]) where
instance OVERLAPPING_ GetHeaders (HList '[]) where
getHeaders _ = []
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( KnownSymbol h, ToByteString x, GetHeaders (HList xs)
) => GetHeaders (HList (Header h x ': xs)) where
instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs))
=> GetHeaders (HList (Header h x ': xs)) where
getHeaders hdrs = case hdrs of
Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest
UndecodableHeader h `HCons` rest -> (headerName, h) : getHeaders rest
MissingHeader `HCons` rest -> getHeaders rest
where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
GetHeaders (Headers '[] a) where
instance OVERLAPPING_ GetHeaders (Headers '[] a) where
getHeaders _ = []
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( KnownSymbol h, GetHeaders (HList rest), ToByteString v
) => GetHeaders (Headers (Header h v ': rest) a) where
instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v)
=> GetHeaders (Headers (Header h v ': rest) a) where
getHeaders hs = getHeaders $ getHeadersHList hs
-- * Adding
@ -138,21 +113,13 @@ class AddHeader h v orig new
addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False
) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
instance OVERLAPPING_ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False)
=> AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads)
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( KnownSymbol h, ToByteString v
, new ~ (Headers '[Header h v] a)
) => AddHeader h v a new where
instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString v
, new ~ (Headers '[Header h v] a))
=> AddHeader h v a new where
addHeader a resp = Headers resp (HCons (Header a) HNil)
type family Contains x xs where

169
servant/src/Servant/API/Verbs.hs Normal file
View file

@ -0,0 +1,169 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
module Servant.API.Verbs
( module Servant.API.Verbs
, StdMethod(GET, POST, HEAD, PUT, DELETE, TRACE, CONNECT, OPTIONS, PATCH)
) where
import Data.Typeable (Typeable)
import Data.Proxy (Proxy)
import GHC.Generics (Generic)
import GHC.TypeLits (Nat)
import Network.HTTP.Types.Method (Method, StdMethod (..),
methodDelete, methodGet, methodHead,
methodPatch, methodPost, methodPut)
-- | @Verb@ is a general type for representing HTTP verbs (a.k.a. methods). For
-- convenience, type synonyms for each verb with a 200 response code are
-- provided, but you are free to define your own:
--
-- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a
data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) a
deriving (Typeable, Generic)
-- * 200 responses
--
-- The 200 response is the workhorse of web servers, but also fairly generic.
-- When appropriate, you should prefer the more specific success combinators.
-- More information about the definitions of status codes can be found in
-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC2615> and
-- <https://tools.ietf.org/html/rfc7231#section-6 RFC7231 Section 6>;
-- the relevant information is summarily presented here.
-- | 'GET' with 200 status code.
type Get contentTypes a = Verb 'GET 200 contentTypes a
-- | 'POST' with 200 status code.
type Post contentTypes a = Verb 'POST 200 contentTypes a
-- | 'PUT' with 200 status code.
type Put contentTypes a = Verb 'PUT 200 contentTypes a
-- | 'DELETE' with 200 status code.
type Delete contentTypes a = Verb 'DELETE 200 contentTypes a
-- | 'PATCH' with 200 status code.
type Patch contentTypes a = Verb 'PATCH 200 contentTypes a
-- * Other responses
-- ** 201 Created
--
-- Indicates that a new resource has been created. The URI corresponding to the
-- resource should be given in the @Location@ header field.
--
-- If the resource cannot be created immediately, use 'PostAccepted'.
--
-- Consider using 'Servant.Utils.Links.safeLink' for the @Location@ header
-- field.
-- | 'POST' with 201 status code.
--
type PostCreated contentTypes a = Verb 'POST 201 contentTypes a
-- ** 202 Accepted
--
-- Indicates that the request has been accepted for processing, but the
-- processing has not yet completed. The status of the processing should be
-- included, as well as either a link to a status monitoring endpoint or an
-- estimate of when the processing will be finished.
-- | 'GET' with 202 status code.
type GetAccepted contentTypes a = Verb 'GET 202 contentTypes a
-- | 'POST' with 202 status code.
type PostAccepted contentTypes a = Verb 'POST 202 contentTypes a
-- | 'DELETE' with 202 status code.
type DeleteAccepted contentTypes a = Verb 'DELETE 202 contentTypes a
-- | 'PATCH' with 202 status code.
type PatchAccepted contentTypes a = Verb 'PATCH 202 contentTypes a
-- | 'PUT' with 202 status code.
type PutAccepted contentTypes a = Verb 'PUT 202 contentTypes a
-- ** 203 Non-Authoritative Information
--
-- Indicates that the request has been successfully processed, but the
-- information may come from a third-party.
-- | 'GET' with 203 status code.
type GetNonAuthoritative contentTypes a = Verb 'GET 203 contentTypes a
-- | 'POST' with 203 status code.
type PostNonAuthoritative contentTypes a = Verb 'POST 203 contentTypes a
-- | 'DELETE' with 203 status code.
type DeleteNonAuthoritative contentTypes a = Verb 'DELETE 203 contentTypes a
-- | 'PATCH' with 203 status code.
type PatchNonAuthoritative contentTypes a = Verb 'PATCH 203 contentTypes a
-- | 'PUT' with 203 status code.
type PutNonAuthoritative contentTypes a = Verb 'PUT 203 contentTypes a
-- ** 204 No Content
--
-- Indicates that no response body is being returned. Handlers for these should
-- return 'NoContent', possibly with headers.
--
-- If the document view should be reset, use @205 Reset Content@.
-- | 'GET' with 204 status code.
type GetNoContent contentTypes noContent = Verb 'GET 204 contentTypes noContent
-- | 'POST' with 204 status code.
type PostNoContent contentTypes noContent = Verb 'POST 204 contentTypes noContent
-- | 'DELETE' with 204 status code.
type DeleteNoContent contentTypes noContent = Verb 'DELETE 204 contentTypes noContent
-- | 'PATCH' with 204 status code.
type PatchNoContent contentTypes noContent = Verb 'PATCH 204 contentTypes noContent
-- | 'PUT' with 204 status code.
type PutNoContent contentTypes noContent = Verb 'PUT 204 contentTypes noContent
-- ** 205 Reset Content
--
-- Indicates that no response body is being returned. Handlers for these should
-- return 'NoContent', possibly with Headers.
--
-- If the document view should not be reset, use @204 No Content@.
-- | 'GET' with 205 status code.
type GetResetContent contentTypes noContent = Verb 'GET 205 contentTypes noContent
-- | 'POST' with 205 status code.
type PostResetContent contentTypes noContent = Verb 'POST 205 contentTypes noContent
-- | 'DELETE' with 205 status code.
type DeleteResetContent contentTypes noContent = Verb 'DELETE 205 contentTypes noContent
-- | 'PATCH' with 205 status code.
type PatchResetContent contentTypes noContent = Verb 'PATCH 205 contentTypes noContent
-- | 'PUT' with 205 status code.
type PutResetContent contentTypes noContent = Verb 'PUT 205 contentTypes noContent
-- ** 206 Partial Content
--
-- Indicates that the server is delivering part of the resource due to a range
-- header in the request.
--
-- For more information, see <https://tools.ietf.org/html/rfc7233#section-4.1
-- RFC7233 Section 4.1>
-- | 'GET' with 206 status code.
type GetPartialContent contentTypes noContent = Verb 'GET 206 contentTypes noContent
class ReflectMethod a where
reflectMethod :: Proxy a -> Method
instance ReflectMethod 'GET where
reflectMethod _ = methodGet
instance ReflectMethod 'POST where
reflectMethod _ = methodPost
instance ReflectMethod 'PUT where
reflectMethod _ = methodPut
instance ReflectMethod 'DELETE where
reflectMethod _ = methodDelete
instance ReflectMethod 'PATCH where
reflectMethod _ = methodPatch
instance ReflectMethod 'HEAD where
reflectMethod _ = methodHead

61
servant/src/Servant/Utils/Links.hs
View file

@ -74,7 +74,7 @@
-- >>> safeLink api bad_link
-- ...
-- Could not deduce (Or
-- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int))
-- (IsElem' (Verb 'DELETE 200 '[JSON] ()) (Verb 'GET 200 '[JSON] Int))
-- (IsElem'
-- ("hello" :> Delete '[JSON] ())
-- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ()))))
@ -103,7 +103,8 @@ module Servant.Utils.Links (
import Data.List
import Data.Proxy ( Proxy(..) )
import Data.Text (Text, unpack)
import qualified Data.Text as Text
import qualified Data.ByteString.Char8 as BSC
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid ( Monoid(..), (<>) )
#else
@ -118,11 +119,7 @@ import Servant.API.Capture ( Capture )
import Servant.API.ReqBody ( ReqBody )
import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
import Servant.API.Header ( Header )
import Servant.API.Get ( Get )
import Servant.API.Post ( Post )
import Servant.API.Put ( Put )
import Servant.API.Patch ( Patch )
import Servant.API.Delete ( Delete )
import Servant.API.Verbs ( Verb )
import Servant.API.Sub ( type (:>) )
import Servant.API.Raw ( Raw )
import Servant.API.Alternative ( type (:<|>) )
@ -135,6 +132,10 @@ data Link = Link
, _queryParams :: [Param Query]
} deriving Show
instance ToHttpApiData Link where
toUrlPiece = Text.pack . show
toHeader = BSC.pack . show
-- | If either a or b produce an empty constraint, produce an empty constraint.
type family Or (a :: Constraint) (b :: Constraint) :: Constraint where
-- This works because of:
@ -172,28 +173,26 @@ type family IsElem endpoint api :: Constraint where
IsElem sa (QueryParam x y :> sb) = IsElem sa sb
IsElem sa (QueryParams x y :> sb) = IsElem sa sb
IsElem sa (QueryFlag x :> sb) = IsElem sa sb
IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct'
IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct'
IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct'
IsElem (Patch ct typ) (Patch ct' typ) = IsSubList ct ct'
IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct'
IsElem (Verb m s ct typ) (Verb m s ct' typ)
= IsSubList ct ct'
IsElem e e = ()
IsElem e a = IsElem' e a
type family IsSubList a b :: Constraint where
IsSubList '[] b = ()
IsSubList '[x] (x ': xs) = ()
IsSubList '[x] (y ': ys) = IsSubList '[x] ys
IsSubList (x ': xs) y = IsSubList '[x] y `And` IsSubList xs y
IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y
type family Elem e es :: Constraint where
Elem x (x ': xs) = ()
Elem y (x ': xs) = Elem y xs
-- Phantom types for Param
data Query
-- | Query param
data Param a
= SingleParam String Text
| ArrayElemParam String Text
= SingleParam String Text.Text
| ArrayElemParam String Text.Text
| FlagParam String
deriving Show
@ -217,8 +216,8 @@ linkURI (Link segments q_params) =
"?" <> intercalate "&" (fmap makeQuery xs)
makeQuery :: Param Query -> String
makeQuery (ArrayElemParam k v) = escape k <> "[]=" <> escape (unpack v)
makeQuery (SingleParam k v) = escape k <> "=" <> escape (unpack v)
makeQuery (ArrayElemParam k v) = escape k <> "[]=" <> escape (Text.unpack v)
makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)
makeQuery (FlagParam k) = escape k
escape :: String -> String
@ -290,31 +289,15 @@ instance (ToHttpApiData v, HasLink sub)
type MkLink (Capture sym v :> sub) = v -> MkLink sub
toLink _ l v =
toLink (Proxy :: Proxy sub) $
addSegment (escape . unpack $ toUrlPiece v) l
addSegment (escape . Text.unpack $ toUrlPiece v) l
instance HasLink sub => HasLink (Header sym a :> sub) where
type MkLink (Header sym a :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)
-- Verb (terminal) instances
instance HasLink (Get y r) where
type MkLink (Get y r) = URI
toLink _ = linkURI
instance HasLink (Post y r) where
type MkLink (Post y r) = URI
toLink _ = linkURI
instance HasLink (Put y r) where
type MkLink (Put y r) = URI
toLink _ = linkURI
instance HasLink (Patch y r) where
type MkLink (Patch y r) = URI
toLink _ = linkURI
instance HasLink (Delete y r) where
type MkLink (Delete y r) = URI
instance HasLink (Verb m s ct a) where
type MkLink (Verb m s ct a) = URI
toLink _ = linkURI
instance HasLink Raw where

5
servant/test/Doctests.hs
View file

@ -9,13 +9,14 @@ import Test.DocTest
main :: IO ()
main = do
files <- find always (extension ==? ".hs") "src"
tfiles <- find always (extension ==? ".hs") "test/Servant"
mCabalMacrosFile <- getCabalMacrosFile
doctest $ "-isrc" :
doctest $ "-isrc" : "-Iinclude" :
(maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++
"-XOverloadedStrings" :
"-XFlexibleInstances" :
"-XMultiParamTypeClasses" :
files
(files ++ tfiles)
getCabalMacrosFile :: IO (Maybe FilePath)
getCabalMacrosFile = do

66
servant/test/Servant/Utils/LinksSpec.hs
View file

@ -1,12 +1,12 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
module Servant.Utils.LinksSpec where
import Test.Hspec ( Spec, it, describe, shouldBe, Expectation )
import Data.Proxy ( Proxy(..) )
import Data.Proxy (Proxy (..))
import Test.Hspec (Expectation, Spec, describe, it,
shouldBe)
import Servant.API
@ -24,18 +24,6 @@ type TestApi =
:<|> "delete" :> Header "ponies" String :> Delete '[JSON] ()
:<|> "raw" :> Raw
type TestLink = "hello" :> "hi" :> Get '[JSON] Bool
type TestLink2 = "greet" :> ReqBody '[JSON] [Int] :> Post '[PlainText] Bool
type TestLink3 = "parent" :> "child" :> Get '[JSON] String
type BadTestLink = "hallo" :> "hi" :> Get '[JSON] Bool
type BadTestLink2 = "greet" :> Get '[PlainText] Bool
type BadTestLink' = "hello" :> "hi" :> Get '[OctetStream] Bool
type BadTestLink'2 = "greet" :> Get '[OctetStream] Bool
type NotALink = "hello" :> Capture "x" Bool :> Get '[JSON] Bool
type NotALink2 = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool
apiLink :: (IsElem endpoint TestApi, HasLink endpoint)
=> Proxy endpoint -> MkLink endpoint
@ -49,7 +37,7 @@ shouldBeURI link expected =
spec :: Spec
spec = describe "Servant.Utils.Links" $ do
it "Generates correct links for capture query params" $ do
it "generates correct links for capture query params" $ do
let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] ())
apiLink l1 "hi" `shouldBeURI` "hello/hi"
@ -59,15 +47,55 @@ spec = describe "Servant.Utils.Links" $ do
apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true"
it "Generates correct links for query flags" $ do
it "generates correct links for query flags" $ do
let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"
:> QueryFlag "fast" :> Delete '[JSON] ())
apiLink l1 True True `shouldBeURI` "balls?bouncy&fast"
apiLink l1 False True `shouldBeURI` "balls?fast"
it "Generates correct links for all of the verbs" $ do
it "generates correct links for all of the verbs" $ do
apiLink (Proxy :: Proxy ("get" :> Get '[JSON] ())) `shouldBeURI` "get"
apiLink (Proxy :: Proxy ("put" :> Put '[JSON] ())) `shouldBeURI` "put"
apiLink (Proxy :: Proxy ("post" :> Post '[JSON] ())) `shouldBeURI` "post"
apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] ())) `shouldBeURI` "delete"
apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw"
-- |
-- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed,
-- we'll just use doctest
--
-- >>> apiLink (Proxy :: Proxy WrongPath)
-- ...
-- Could not deduce ...
-- ...
--
-- >>> apiLink (Proxy :: Proxy WrongReturnType)
-- ...
-- Could not deduce ...
-- ...
--
-- >>> apiLink (Proxy :: Proxy WrongContentType)
-- ...
-- Could not deduce ...
-- ...
--
-- >>> apiLink (Proxy :: Proxy WrongMethod)
-- ...
-- Could not deduce ...
-- ...
--
-- >>> apiLink (Proxy :: Proxy NotALink)
-- ...
-- Could not deduce ...
-- ...
--
-- sanity check
-- >>> apiLink (Proxy :: Proxy AllGood)
-- get
type WrongPath = "getTypo" :> Get '[JSON] ()
type WrongReturnType = "get" :> Get '[JSON] Bool
type WrongContentType = "get" :> Get '[OctetStream] ()
type WrongMethod = "get" :> Post '[JSON] ()
type NotALink = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool
type AllGood = "get" :> Get '[JSON] ()