Merge pull request #31 from haskell-servant/merge

Merge all repos

.gitignore

@@ -1,5 +1,11 @@
 dist
+bin
+lib
+share
+packages
+*-packages.conf.d
 cabal-dev
+add-source-timestamps
 *.o
 *.hi
 *.chi

.travis.yml

@@ -3,25 +3,12 @@ language: haskell
 ghc:
   - 7.8
 
-before_install:
-  - cabal update
-  - cabal sandbox init
-
 install:
-  - cabal install --only-dependencies --enable-tests
+  - ghc --version
+  - cabal --version
 
 script:
-  - cabal configure --enable-tests --enable-library-coverage && cabal build && cabal test
+  - ./scripts/test-all.sh
-  - cabal check
-  - cabal sdist
-
-after_script:
-  - |
-    if [ "$TRAVIS_PULL_REQUEST" -eq "$TRAVIS_PULL_REQUEST" ] 2>/dev/null || [ "$TRAVIS_BRANCH" == "master" ] ; then
-      cabal install hpc-coveralls
-      hpc-coveralls --exclude-dir=test spec doctests
-    fi
-
 
 notifications:
   irc:

scripts/test-all.sh

@@ -0,0 +1,42 @@
+#!/bin/bash -
+#===============================================================================
+#
+#          FILE: test-all.sh
+#
+#         USAGE: ./test-all.sh
+#
+#   DESCRIPTION: Run tests for all source directories listed in $SOURCES.
+#                Uses local versions of those sources.
+#
+#===============================================================================
+
+set -o nounset
+set -o errexit
+
+SOURCES=( servant servant-server servant-client servant-jquery servant-docs )
+GHC_FLAGS="-Werror"
+
+prepare_sandbox () {
+    cabal sandbox init
+    for s in ${SOURCES[@]} ; do
+        cd "$s"
+        cabal sandbox init --sandbox=../
+        cabal sandbox add-source .
+        cd ..
+    done
+}
+
+test_each () {
+    for s in ${SOURCES[@]} ; do
+        echo "Testing $s..."
+        cd "$s"
+        cabal install --only-dependencies --enable-tests
+        cabal configure --enable-tests --ghc-options="$GHC_FLAGS"
+        cabal build
+        cabal test
+        cd ..
+    done
+}
+
+prepare_sandbox
+test_each

servant-client/CHANGELOG.md

@@ -0,0 +1,15 @@
+0.3
+---
+* Support content-type aware combinators and `Accept`/`Content-type` headers
+* Added a lot of tests
+* Support multiple concurrent threads
+* Use `ServantError` to report Errors instead of `String`
+* Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example)
+* Support for PATCH
+* Make () instances expect No Content status code, and not try to decode body.
+* `Canonicalize` API types before generating client functions for them
+
+0.2.2
+-----
+* Add TLS support
+* Add matrix parameter support

servant-client/README.md

@@ -0,0 +1,23 @@
+# servant-client
+
+[![Build Status](https://secure.travis-ci.org/haskell-servant/servant-client.svg)](http://travis-ci.org/haskell-servant/servant-client)
+[![Coverage Status](https://coveralls.io/repos/haskell-servant/servant-client/badge.svg)](https://coveralls.io/r/haskell-servant/servant-client)
+
+![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
+
+This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice.
+
+## Example
+
+``` haskell
+type MyApi = "books" :> Get [Book] -- GET /books
+        :<|> "books" :> ReqBody Book :> Post Book -- POST /books
+
+myApi :: Proxy MyApi
+myApi = Proxy
+
+getAllBooks :: BaseUrl -> EitherT String IO [Book]
+postNewBook :: Book -> BaseUrl -> EitherT String IO Book
+-- 'client' allows you to produce operations to query an API from a client.
+(getAllBooks :<|> postNewBook) = client myApi
+```

servant-client/docs.sh

@@ -0,0 +1,52 @@
+SERVANT_DIR=/tmp/servant-client-gh-pages
+
+# Make a temporary clone
+
+rm -rf $SERVANT_DIR
+
+git clone . $SERVANT_DIR
+
+cd $SERVANT_DIR
+
+# Make sure to pull the latest
+
+git remote add haskell-servant git@github.com:haskell-servant/servant-client.git
+
+git fetch haskell-servant
+
+git reset --hard haskell-servant/gh-pages
+
+# Clear everything away
+
+git rm -rf $SERVANT_DIR/*
+
+# Switch back and build the haddocks
+
+cd -
+
+cabal configure --builddir=$SERVANT_DIR
+
+cabal haddock --hoogle --hyperlink-source --html-location='https://hackage.haskell.org/package/$pkg-$version/docs' --builddir=$SERVANT_DIR
+
+commit_hash=$(git rev-parse HEAD)
+
+# Move the HTML docs to the root
+
+cd $SERVANT_DIR
+
+rm *
+rm -rf build
+mv doc/html/servant-client/* .
+rm -r doc/
+
+# Add everything
+
+git add .
+
+git commit -m "Built from $commit_hash"
+
+# Push to update the pages
+
+git push haskell-servant HEAD:gh-pages
+
+rm -rf $SERVANT_DIR

servant-client/servant-client.cabal

@@ -0,0 +1,85 @@
+name:                servant-client
+version:             0.2.2
+synopsis: automatical derivation of querying functions for servant webservices
+description:
+  This library lets you derive automatically Haskell functions that
+  let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
+  .
+  Example below.
+  .
+  > type MyApi = "books" :> Get [Book] -- GET /books
+  >         :<|> "books" :> ReqBody Book :> Post Book -- POST /books
+  >
+  > myApi :: Proxy MyApi
+  > myApi = Proxy
+  >
+  > getAllBooks :: BaseUrl -> EitherT String IO [Book]
+  > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
+  > (getAllBooks :<|> postNewBook) = client myApi
+license:             BSD3
+license-file:        LICENSE
+author:              Alp Mestanogullari, Sönke Hahn, Julian K. Arni
+maintainer:          alpmestan@gmail.com
+copyright:           2014 Zalora South East Asia Pte Ltd
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+tested-with:         GHC >= 7.8
+homepage:            http://haskell-servant.github.io/
+Bug-reports:         http://github.com/haskell-servant/servant-client/issues
+source-repository head
+  type: git
+  location: http://github.com/haskell-servant/servant-client.git
+
+library
+  exposed-modules:
+    Servant.Client
+    Servant.Common.BaseUrl
+    Servant.Common.Req
+  build-depends:
+      base >=4.7 && <5
+    , aeson
+    , attoparsec
+    , bytestring
+    , either
+    , exceptions
+    , http-client
+    , http-client-tls
+    , http-media
+    , http-types
+    , network-uri >= 2.6
+    , safe
+    , servant >= 0.2.2
+    , string-conversions
+    , text
+    , transformers
+  hs-source-dirs: src
+  default-language: Haskell2010
+  ghc-options: -Wall
+
+test-suite spec
+  type: exitcode-stdio-1.0
+  ghc-options:
+    -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
+  default-language: Haskell2010
+  hs-source-dirs: test
+  main-is: Spec.hs
+  build-depends:
+      base == 4.*
+    , aeson
+    , bytestring
+    , deepseq
+    , either
+    , hspec == 2.*
+    , http-client
+    , http-media
+    , http-types
+    , HUnit
+    , network >= 2.6
+    , QuickCheck >= 2.7
+    , servant >= 0.2.1
+    , servant-client
+    , servant-server >= 0.2.1
+    , text
+    , wai
+    , warp

servant-client/src/Servant/Client.hs

@@ -0,0 +1,504 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-- | This module provides 'client' which can automatically generate
+-- querying functions for each endpoint just from the type representing your
+-- API.
+module Servant.Client
+  ( client
+  , HasClient(..)
+  , Client
+  , ServantError(..)
+  , module Servant.Common.BaseUrl
+  ) where
+
+import Control.Monad
+import Control.Monad.Trans.Either
+import Data.ByteString.Lazy (ByteString)
+import Data.List
+import Data.Proxy
+import Data.String.Conversions
+import Data.Text (unpack)
+import GHC.TypeLits
+import Network.HTTP.Client (Response)
+import Network.HTTP.Media
+import qualified Network.HTTP.Types as H
+import Servant.API
+import Servant.API.ContentTypes
+import Servant.Common.BaseUrl
+import Servant.Common.Req
+
+-- * Accessing APIs as a Client
+
+-- | 'client' allows you to produce operations to query an API from a client.
+--
+-- > type MyApi = "books" :> Get [Book] -- GET /books
+-- >         :<|> "books" :> ReqBody Book :> Post Book -- POST /books
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
+-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
+-- > (getAllBooks :<|> postNewBook) = client myApi
+client :: HasClient (Canonicalize layout) => Proxy layout -> Client layout
+client p = clientWithRoute (canonicalize p) defReq
+
+-- | This class lets us define how each API combinator
+-- influences the creation of an HTTP request. It's mostly
+-- an internal class, you can just use 'client'.
+class HasClient layout where
+  type Client' layout :: *
+  clientWithRoute :: Proxy layout -> Req -> Client' layout
+
+type Client layout = Client' (Canonicalize layout)
+
+-- | A client querying function for @a ':<|>' b@ will actually hand you
+--   one function for querying @a@ and another one for querying @b@,
+--   stitching them together with ':<|>', which really is just like a pair.
+--
+-- > type MyApi = "books" :> Get [Book] -- GET /books
+-- >         :<|> "books" :> ReqBody Book :> Post Book -- POST /books
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
+-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
+-- > (getAllBooks :<|> postNewBook) = client myApi
+instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
+  type Client' (a :<|> b) = Client' a :<|> Client' b
+  clientWithRoute Proxy req =
+    clientWithRoute (Proxy :: Proxy a) req :<|>
+    clientWithRoute (Proxy :: Proxy b) req
+
+-- | If you use a 'Capture' in one of your endpoints in your API,
+-- the corresponding querying function will automatically take
+-- an additional argument of the type specified by your 'Capture'.
+-- That function will take care of inserting a textual representation
+-- of this value at the right place in the request path.
+--
+-- You can control how values for this type are turned into
+-- text by specifying a 'ToText' instance for your type.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getBook :: Text -> BaseUrl -> EitherT String IO Book
+-- > getBook = client myApi
+-- > -- then you can just use "getBook" to query that endpoint
+instance (KnownSymbol capture, ToText a, HasClient sublayout)
+      => HasClient (Capture capture a :> sublayout) where
+
+  type Client' (Capture capture a :> sublayout) =
+    a -> Client' sublayout
+
+  clientWithRoute Proxy req val =
+    clientWithRoute (Proxy :: Proxy sublayout) $
+      appendToPath p req
+
+    where p = unpack (toText 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 HasClient Delete where
+  type Client' Delete = BaseUrl -> EitherT ServantError IO ()
+
+  clientWithRoute Proxy req host =
+    void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host
+
+-- | 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 (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
+  type Client' (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
+  clientWithRoute Proxy req host =
+    performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host
+
+-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content
+-- HTTP header.
+instance HasClient (Get (ct ': cts) ()) where
+  type Client' (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
+  clientWithRoute Proxy req host =
+    performRequestNoBody H.methodGet req [204] host
+
+-- | 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',
+-- wrapped in Maybe.
+--
+-- That function will take care of encoding this argument as Text
+-- in the request headers.
+--
+-- All you need is for your type to have a 'ToText' instance.
+--
+-- Example:
+--
+-- > newtype Referer = Referer Text
+-- >   deriving (Eq, Show, FromText, ToText)
+-- >
+-- >            -- GET /view-my-referer
+-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get Referer
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > viewReferer :: Maybe Referer -> BaseUrl -> EitherT String IO Book
+-- > viewReferer = client myApi
+-- > -- then you can just use "viewRefer" to query that endpoint
+-- > -- specifying Nothing or Just "http://haskell.org/" as arguments
+instance (KnownSymbol sym, ToText a, HasClient sublayout)
+      => HasClient (Header sym a :> sublayout) where
+
+  type Client' (Header sym a :> sublayout) =
+    Maybe a -> Client' sublayout
+
+  clientWithRoute Proxy req mval =
+    clientWithRoute (Proxy :: Proxy sublayout) $
+      maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval
+
+    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 (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
+  type Client' (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
+
+  clientWithRoute Proxy req uri =
+    performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri
+
+-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content
+-- HTTP header.
+instance HasClient (Post (ct ': cts) ()) where
+  type Client' (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
+  clientWithRoute Proxy req host =
+    void $ performRequestNoBody H.methodPost req [204] host
+
+-- | 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 (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
+  type Client' (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
+
+  clientWithRoute Proxy req host =
+    performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host
+
+-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content
+-- HTTP header.
+instance HasClient (Put (ct ': cts) ()) where
+  type Client' (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
+  clientWithRoute Proxy req host =
+    void $ performRequestNoBody H.methodPut req [204] host
+
+-- | 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 (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
+  type Client' (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
+
+  clientWithRoute Proxy req host =
+    performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host
+
+-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content
+-- HTTP header.
+instance HasClient (Patch (ct ': cts) ()) where
+  type Client' (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
+  clientWithRoute Proxy req host =
+    void $ performRequestNoBody H.methodPatch req [204] host
+
+-- | 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',
+-- enclosed in Maybe.
+--
+-- If you give Nothing, nothing will be added to the query string.
+--
+-- If you give a non-'Nothing' value, this function will take care
+-- of inserting a textual representation of this value in the query string.
+--
+-- You can control how values for your type are turned into
+-- text by specifying a 'ToText' instance for your type.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book]
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getBooksBy :: Maybe Text -> BaseUrl -> EitherT String IO [Book]
+-- > getBooksBy = client myApi
+-- > -- then you can just use "getBooksBy" to query that endpoint.
+-- > -- 'getBooksBy Nothing' for all books
+-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
+instance (KnownSymbol sym, ToText a, HasClient sublayout)
+      => HasClient (QueryParam sym a :> sublayout) where
+
+  type Client' (QueryParam sym a :> sublayout) =
+    Maybe a -> Client' sublayout
+
+  -- if mparam = Nothing, we don't add it to the query string
+  clientWithRoute Proxy req mparam =
+    clientWithRoute (Proxy :: Proxy sublayout) $
+      maybe req (flip (appendToQueryString pname) req . Just) mparamText
+
+    where pname  = cs pname'
+          pname' = symbolVal (Proxy :: Proxy sym)
+          mparamText = fmap toText mparam
+
+-- | If you use a 'QueryParams' in one of your endpoints in your API,
+-- the corresponding querying function will automatically take
+-- an additional argument, a list of values of the type specified
+-- by your 'QueryParams'.
+--
+-- If you give an empty list, nothing will be added to the query string.
+--
+-- Otherwise, this function will take care
+-- of inserting a textual representation of your values in the query string,
+-- under the same query string parameter name.
+--
+-- You can control how values for your type are turned into
+-- text by specifying a 'ToText' instance for your type.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book]
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getBooksBy :: [Text] -> BaseUrl -> EitherT String IO [Book]
+-- > getBooksBy = client myApi
+-- > -- then you can just use "getBooksBy" to query that endpoint.
+-- > -- 'getBooksBy []' for all books
+-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
+-- > --   to get all books by Asimov and Heinlein
+instance (KnownSymbol sym, ToText a, HasClient sublayout)
+      => HasClient (QueryParams sym a :> sublayout) where
+
+  type Client' (QueryParams sym a :> sublayout) =
+    [a] -> Client' sublayout
+
+  clientWithRoute Proxy req paramlist =
+    clientWithRoute (Proxy :: Proxy sublayout) $
+      foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist'
+
+    where pname  = cs pname'
+          pname' = symbolVal (Proxy :: Proxy sym)
+          paramlist' = map (Just . toText) paramlist
+
+-- | If you use a 'QueryFlag' in one of your endpoints in your API,
+-- the corresponding querying function will automatically take
+-- an additional 'Bool' argument.
+--
+-- If you give 'False', nothing will be added to the query string.
+--
+-- Otherwise, this function will insert a value-less query string
+-- parameter under the name associated to your 'QueryFlag'.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book]
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getBooks :: Bool -> BaseUrl -> EitherT String IO [Book]
+-- > getBooks = client myApi
+-- > -- then you can just use "getBooks" to query that endpoint.
+-- > -- 'getBooksBy False' for all books
+-- > -- 'getBooksBy True' to only get _already published_ books
+instance (KnownSymbol sym, HasClient sublayout)
+      => HasClient (QueryFlag sym :> sublayout) where
+
+  type Client' (QueryFlag sym :> sublayout) =
+    Bool -> Client' sublayout
+
+  clientWithRoute Proxy req flag =
+    clientWithRoute (Proxy :: Proxy sublayout) $
+      if flag
+        then appendToQueryString paramname Nothing req
+        else req
+
+    where paramname = cs $ symbolVal (Proxy :: Proxy sym)
+
+-- | If you use a 'MatrixParam' in one of your endpoints in your API,
+-- the corresponding querying function will automatically take
+-- an additional argument of the type specified by your 'MatrixParam',
+-- enclosed in Maybe.
+--
+-- If you give Nothing, nothing will be added to the query string.
+--
+-- If you give a non-'Nothing' value, this function will take care
+-- of inserting a textual representation of this value in the query string.
+--
+-- You can control how values for your type are turned into
+-- text by specifying a 'ToText' instance for your type.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> MatrixParam "author" Text :> Get [Book]
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getBooksBy :: Maybe Text -> BaseUrl -> EitherT String IO [Book]
+-- > getBooksBy = client myApi
+-- > -- then you can just use "getBooksBy" to query that endpoint.
+-- > -- 'getBooksBy Nothing' for all books
+-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
+instance (KnownSymbol sym, ToText a, HasClient sublayout)
+      => HasClient (MatrixParam sym a :> sublayout) where
+
+  type Client' (MatrixParam sym a :> sublayout) =
+    Maybe a -> Client' sublayout
+
+  -- if mparam = Nothing, we don't add it to the query string
+  clientWithRoute Proxy req mparam =
+    clientWithRoute (Proxy :: Proxy sublayout) $
+      maybe req (flip (appendToMatrixParams pname . Just) req) mparamText
+
+    where pname = symbolVal (Proxy :: Proxy sym)
+          mparamText = fmap (cs . toText) mparam
+
+-- | If you use a 'MatrixParams' in one of your endpoints in your API,
+-- the corresponding querying function will automatically take an
+-- additional argument, a list of values of the type specified by your
+-- 'MatrixParams'.
+--
+-- If you give an empty list, nothing will be added to the query string.
+--
+-- Otherwise, this function will take care of inserting a textual
+-- representation of your values in the path segment string, under the
+-- same matrix string parameter name.
+--
+-- You can control how values for your type are turned into text by
+-- specifying a 'ToText' instance for your type.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> MatrixParams "authors" Text :> Get [Book]
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getBooksBy :: [Text] -> BaseUrl -> EitherT String IO [Book]
+-- > getBooksBy = client myApi
+-- > -- then you can just use "getBooksBy" to query that endpoint.
+-- > -- 'getBooksBy []' for all books
+-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
+-- > --   to get all books by Asimov and Heinlein
+instance (KnownSymbol sym, ToText a, HasClient sublayout)
+      => HasClient (MatrixParams sym a :> sublayout) where
+
+  type Client' (MatrixParams sym a :> sublayout) =
+    [a] -> Client' sublayout
+
+  clientWithRoute Proxy req paramlist =
+    clientWithRoute (Proxy :: Proxy sublayout) $
+      foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value) req paramlist'
+
+    where pname  = cs pname'
+          pname' = symbolVal (Proxy :: Proxy sym)
+          paramlist' = map (Just . toText) paramlist
+
+-- | If you use a 'MatrixFlag' in one of your endpoints in your API,
+-- the corresponding querying function will automatically take an
+-- additional 'Bool' argument.
+--
+-- If you give 'False', nothing will be added to the path segment.
+--
+-- Otherwise, this function will insert a value-less matrix parameter
+-- under the name associated to your 'MatrixFlag'.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> MatrixFlag "published" :> Get [Book]
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getBooks :: Bool -> BaseUrl -> EitherT String IO [Book]
+-- > getBooks = client myApi
+-- > -- then you can just use "getBooks" to query that endpoint.
+-- > -- 'getBooksBy False' for all books
+-- > -- 'getBooksBy True' to only get _already published_ books
+instance (KnownSymbol sym, HasClient sublayout)
+      => HasClient (MatrixFlag sym :> sublayout) where
+
+  type Client' (MatrixFlag sym :> sublayout) =
+    Bool -> Client' sublayout
+
+  clientWithRoute Proxy req flag =
+    clientWithRoute (Proxy :: Proxy sublayout) $
+      if flag
+        then appendToMatrixParams paramname Nothing req
+        else req
+
+    where paramname = cs $ symbolVal (Proxy :: Proxy sym)
+
+-- | Pick a 'Method' and specify where the server you want to query is. You get
+-- back the full `Response`.
+instance HasClient Raw where
+  type Client' Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)
+
+  clientWithRoute :: Proxy Raw -> Req -> Client' Raw
+  clientWithRoute Proxy req httpMethod host = do
+    performRequest httpMethod req (const True) host
+
+-- | If you use a 'ReqBody' in one of your endpoints in your API,
+-- the corresponding querying function will automatically take
+-- an additional argument of the type specified by your 'ReqBody'.
+-- That function will take care of encoding this argument as JSON and
+-- of using it as the request body.
+--
+-- All you need is for your type to have a 'ToJSON' instance.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> ReqBody Book :> Post Book
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > addBook :: Book -> BaseUrl -> EitherT String IO Book
+-- > addBook = client myApi
+-- > -- then you can just use "addBook" to query that endpoint
+instance (MimeRender ct a, HasClient sublayout)
+      => HasClient (ReqBody (ct ': cts) a :> sublayout) where
+
+  type Client' (ReqBody (ct ': cts) a :> sublayout) =
+    a -> Client' sublayout
+
+  clientWithRoute Proxy req body =
+    clientWithRoute (Proxy :: Proxy sublayout) $ do
+      let ctProxy = Proxy :: Proxy ct
+      setRQBody (mimeRender ctProxy body) (contentType ctProxy) req
+
+-- | Make the querying function append @path@ to the request path.
+instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
+  type Client' (path :> sublayout) = Client' sublayout
+
+  clientWithRoute Proxy req =
+     clientWithRoute (Proxy :: Proxy sublayout) $
+       appendToPath p req
+
+    where p = symbolVal (Proxy :: Proxy path)
+

servant-client/src/Servant/Common/BaseUrl.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ViewPatterns #-}
+module Servant.Common.BaseUrl where
+
+import Data.List
+import GHC.Generics
+import Network.URI
+import Safe
+import Text.Read
+
+-- | URI scheme to use
+data Scheme =
+    Http  -- ^ http://
+  | Https -- ^ https://
+  deriving (Show, Eq, Ord, Generic)
+
+-- | Simple data type to represent the target of HTTP requests
+--   for servant's automatically-generated clients.
+data BaseUrl = BaseUrl
+  { baseUrlScheme :: Scheme -- ^ URI scheme to use
+  , baseUrlHost :: String   -- ^ host (eg "haskell.org")
+  , baseUrlPort :: Int      -- ^ port (eg 80)
+  } deriving (Show, Eq, Ord, Generic)
+
+showBaseUrl :: BaseUrl -> String
+showBaseUrl (BaseUrl urlscheme host port) =
+  schemeString ++ "//" ++ host ++ portString
+    where
+      schemeString = case urlscheme of
+        Http  -> "http:"
+        Https -> "https:"
+      portString = case (urlscheme, port) of
+        (Http, 80) -> ""
+        (Https, 443) -> ""
+        _ -> ":" ++ show port
+
+parseBaseUrl :: String -> Either String BaseUrl
+parseBaseUrl s = case parseURI (removeTrailingSlash s) of
+  -- This is a rather hacky implementation and should be replaced with something
+  -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
+  Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
+    Right (BaseUrl Http host port)
+  Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->
+    Right (BaseUrl Http host 80)
+  Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
+    Right (BaseUrl Https host port)
+  Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->
+    Right (BaseUrl Https host 443)
+  _ -> if "://" `isInfixOf` s
+    then Left ("invalid base url: " ++ s)
+    else parseBaseUrl ("http://" ++ s)
+ where
+  removeTrailingSlash str = case lastMay str of
+    Just '/' -> init str
+    _ -> str

servant-client/src/Servant/Common/Req.hs

@@ -0,0 +1,184 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Servant.Common.Req where
+
+import Control.Applicative
+import Control.Exception
+import Control.Monad
+import Control.Monad.Catch (MonadThrow)
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Either
+import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
+import Data.IORef
+import Data.String
+import Data.String.Conversions
+import Data.Proxy
+import Data.Text (Text)
+import Data.Text.Encoding
+import Network.HTTP.Client hiding (Proxy)
+import Network.HTTP.Client.TLS
+import Network.HTTP.Media
+import Network.HTTP.Types
+import Network.URI
+import Servant.API.ContentTypes
+import Servant.Common.BaseUrl
+import Servant.Common.Text
+import System.IO.Unsafe
+
+import qualified Network.HTTP.Client as Client
+
+data ServantError
+  = FailureResponse
+    { responseStatus            :: Status
+    , responseContentType       :: MediaType
+    , responseBody              :: ByteString
+    }
+  | DecodeFailure
+    { decodeError               :: String
+    , responseContentType       :: MediaType
+    , responseBody              :: ByteString
+    }
+  | UnsupportedContentType
+    { responseContentType       :: MediaType
+    , responseBody              :: ByteString
+    }
+  | ConnectionError
+    { connectionError           :: HttpException
+    }
+  | InvalidContentTypeHeader
+    { responseContentTypeHeader :: ByteString
+    , responseBody              :: ByteString
+    }
+  deriving (Show)
+
+data Req = Req
+  { reqPath   :: String
+  , qs        :: QueryText
+  , reqBody   :: Maybe (ByteString, MediaType)
+  , reqAccept :: [MediaType]
+  , headers   :: [(String, Text)]
+  }
+
+defReq :: Req
+defReq = Req "" [] Nothing [] []
+
+appendToPath :: String -> Req -> Req
+appendToPath p req =
+  req { reqPath = reqPath req ++ "/" ++ p }
+
+appendToMatrixParams :: String
+                     -> Maybe String
+                     -> Req
+                     -> Req
+appendToMatrixParams pname pvalue req =
+  req { reqPath = reqPath req ++ ";" ++ pname ++ maybe "" ("=" ++) pvalue }
+
+appendToQueryString :: Text       -- ^ param name
+                    -> Maybe Text -- ^ param value
+                    -> Req
+                    -> Req
+appendToQueryString pname pvalue req =
+  req { qs = qs req ++ [(pname, pvalue)]
+      }
+
+addHeader :: ToText a => String -> a -> Req -> Req
+addHeader name val req = req { headers = headers req
+                                      ++ [(name, toText val)]
+                             }
+
+setRQBody :: ByteString -> MediaType -> Req -> Req
+setRQBody b t req = req { reqBody = Just (b, t) }
+
+reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
+reqToRequest req (BaseUrl reqScheme reqHost reqPort) =
+    fmap (setheaders . setAccept . setrqb . setQS ) $ parseUrl url
+
+  where url = show $ nullURI { uriScheme = case reqScheme of
+                                  Http  -> "http:"
+                                  Https -> "https:"
+                             , uriAuthority = Just $
+                                 URIAuth { uriUserInfo = ""
+                                         , uriRegName = reqHost
+                                         , uriPort = ":" ++ show reqPort
+                                         }
+                             , uriPath = reqPath req
+                             }
+
+        setrqb r = case reqBody req of
+                     Nothing -> r
+                     Just (b,t) -> r { requestBody = RequestBodyLBS b
+                                     , requestHeaders = requestHeaders r
+                                                     ++ [(hContentType, cs . show $ t)] }
+        setQS = setQueryString $ queryTextToQuery (qs req)
+        setheaders r = r { requestHeaders = requestHeaders r
+                                         <> fmap toProperHeader (headers req) }
+        setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)
+                                        <> [("Accept", renderHeader $ reqAccept req)
+                                              | not . null . reqAccept $ req] }
+        toProperHeader (name, val) =
+          (fromString name, encodeUtf8 val)
+
+
+-- * performing requests
+
+{-# NOINLINE __manager #-}
+__manager :: IORef Manager
+__manager = unsafePerformIO (newManager tlsManagerSettings >>= newIORef)
+
+__withGlobalManager :: (Manager -> IO a) -> IO a
+__withGlobalManager action = readIORef __manager >>= action
+
+
+displayHttpRequest :: Method -> String
+displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
+
+
+performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)
+performRequest reqMethod req isWantedStatus reqHost = do
+  partialRequest <- liftIO $ reqToRequest req reqHost
+
+  let request = partialRequest { Client.method = reqMethod
+                               , checkStatus = \ _status _headers _cookies -> Nothing
+                               }
+
+  eResponse <- liftIO $ __withGlobalManager $ \ manager ->
+    catchHttpException $
+    Client.httpLbs request manager
+  case eResponse of
+    Left err ->
+      left $ ConnectionError err
+
+    Right response -> do
+      let status = Client.responseStatus response
+          body = Client.responseBody response
+          status_code = statusCode status
+      ct <- case lookup "Content-Type" $ Client.responseHeaders response of
+                 Nothing -> pure $ "application"//"octet-stream"
+                 Just t -> case parseAccept t of
+                   Nothing -> left $ InvalidContentTypeHeader (cs t) body
+                   Just t' -> pure t'
+      unless (isWantedStatus status_code) $
+        left $ FailureResponse status ct body
+      return (status_code, body, ct, response)
+
+performRequestCT :: MimeUnrender ct result =>
+  Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO result
+performRequestCT ct reqMethod req wantedStatus reqHost = do
+  let acceptCT = contentType ct
+  (_status, respBody, respCT, _response) <-
+    performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost
+  unless (matches respCT (acceptCT)) $
+    left $ UnsupportedContentType respCT respBody
+  either
+    (left . (\s -> DecodeFailure s respCT respBody))
+    return
+    (mimeUnrender ct respBody)
+
+performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ()
+performRequestNoBody reqMethod req wantedStatus reqHost = do
+  _ <- performRequest reqMethod req (`elem` wantedStatus) reqHost
+  return ()
+
+catchHttpException :: IO a -> IO (Either HttpException a)
+catchHttpException action =
+  catch (Right <$> action) (pure . Left)

servant-client/test/Servant/ClientSpec.hs

@@ -0,0 +1,345 @@
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE GADTs              #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeOperators      #-}
+{-# OPTIONS_GHC -fcontext-stack=25 #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Servant.ClientSpec where
+
+import           Control.Applicative
+import qualified Control.Arrow              as Arrow
+import           Control.Concurrent
+import           Control.Exception
+import           Control.Monad.Trans.Either
+import           Data.Aeson
+import           Data.ByteString.Lazy       (ByteString)
+import           Data.Char
+import           Data.Foldable              (forM_)
+import           Data.Monoid
+import           Data.Proxy
+import qualified Data.Text                  as T
+import           GHC.Generics
+import qualified Network.HTTP.Client        as C
+import           Network.HTTP.Media
+import           Network.HTTP.Types
+import           Network.Socket
+import           Network.Wai                hiding (Response)
+import           Network.Wai.Handler.Warp
+import           Test.Hspec
+import           Test.Hspec.QuickCheck
+import           Test.HUnit
+import           Test.QuickCheck
+
+import           Servant.API
+import           Servant.Client
+import           Servant.Server
+
+-- * test data types
+
+data Person = Person {
+  name :: String,
+  age :: Integer
+ }
+  deriving (Eq, Show, Generic)
+
+instance ToJSON Person
+instance FromJSON Person
+
+instance ToFormUrlEncoded Person where
+    toFormUrlEncoded Person{..} =
+        [("name", T.pack name), ("age", T.pack (show age))]
+
+lookupEither :: (Show a, Eq a) => a -> [(a,b)] -> Either String b
+lookupEither x xs = do
+    maybe (Left $ "could not find key " <> show x) return $ lookup x xs
+
+instance FromFormUrlEncoded Person where
+    fromFormUrlEncoded xs = do
+        n <- lookupEither "name" xs
+        a <- lookupEither "age" xs
+        return $ Person (T.unpack n) (read $ T.unpack a)
+
+deriving instance Eq ServantError
+
+instance Eq C.HttpException where
+  a == b = show a == show b
+
+alice :: Person
+alice = Person "Alice" 42
+
+type Api =
+       "get" :> Get '[JSON] Person
+  :<|> "delete" :> Delete
+  :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
+  :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
+  :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
+  :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
+  :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
+  :<|> "matrixparam" :> MatrixParam "name" String :> Get '[JSON] Person
+  :<|> "matrixparams" :> MatrixParams "name" String :> Get '[JSON] [Person]
+  :<|> "matrixflag" :> MatrixFlag "flag" :> Get '[JSON] Bool
+  :<|> "rawSuccess" :> Raw
+  :<|> "rawFailure" :> Raw
+  :<|> "multiple" :>
+            Capture "first" String :>
+            QueryParam "second" Int :>
+            QueryFlag "third" :>
+            ReqBody '[JSON] [(String, [Rational])] :>
+            Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
+api :: Proxy Api
+api = Proxy
+
+server :: Application
+server = serve api (
+       return alice
+  :<|> return ()
+  :<|> (\ name -> return $ Person name 0)
+  :<|> return
+  :<|> (\ name -> case name of
+                   Just "alice" -> return alice
+                   Just name -> left (400, name ++ " not found")
+                   Nothing -> left (400, "missing parameter"))
+  :<|> (\ names -> return (zipWith Person names [0..]))
+  :<|> return
+  :<|> (\ name -> case name of
+                   Just "alice" -> return alice
+                   Just name -> left (400, name ++ " not found")
+                   Nothing -> left (400, "missing parameter"))
+  :<|> (\ names -> return (zipWith Person names [0..]))
+  :<|> return
+  :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
+  :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
+  :<|> \ a b c d -> return (a, b, c, d)
+ )
+
+withServer :: (BaseUrl -> IO a) -> IO a
+withServer action = withWaiDaemon (return server) action
+
+getGet :: BaseUrl -> EitherT ServantError IO Person
+getDelete :: BaseUrl -> EitherT ServantError IO ()
+getCapture :: String -> BaseUrl -> EitherT ServantError IO Person
+getBody :: Person -> BaseUrl -> EitherT ServantError IO Person
+getQueryParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
+getQueryParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
+getQueryFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
+getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
+getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
+getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
+getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString)
+getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString)
+getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
+  -> BaseUrl
+  -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
+(     getGet
+ :<|> getDelete
+ :<|> getCapture
+ :<|> getBody
+ :<|> getQueryParam
+ :<|> getQueryParams
+ :<|> getQueryFlag
+ :<|> getMatrixParam
+ :<|> getMatrixParams
+ :<|> getMatrixFlag
+ :<|> getRawSuccess
+ :<|> getRawFailure
+ :<|> getMultiple)
+    = client api
+
+type FailApi =
+       "get" :> Raw
+  :<|> "capture" :> Capture "name" String :> Raw
+  :<|> "body" :> Raw
+failApi :: Proxy FailApi
+failApi = Proxy
+
+failServer :: Application
+failServer = serve failApi (
+       (\ _request respond -> respond $ responseLBS ok200 [] "")
+  :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")
+  :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
+ )
+
+withFailServer :: (BaseUrl -> IO a) -> IO a
+withFailServer action = withWaiDaemon (return failServer) action
+
+spec :: Spec
+spec = do
+  it "Servant.API.Get" $ withServer $ \ host -> do
+    (Arrow.left show <$> runEitherT (getGet host)) `shouldReturn` Right alice
+
+  it "Servant.API.Delete" $ withServer $ \ host -> do
+    (Arrow.left show <$> runEitherT (getDelete host)) `shouldReturn` Right ()
+
+  it "Servant.API.Capture" $ withServer $ \ host -> do
+    (Arrow.left show <$> runEitherT (getCapture "Paula" host)) `shouldReturn` Right (Person "Paula" 0)
+
+  it "Servant.API.ReqBody" $ withServer $ \ host -> do
+    let p = Person "Clara" 42
+    (Arrow.left show <$> runEitherT (getBody p host)) `shouldReturn` Right p
+
+  it "Servant.API.QueryParam" $ withServer $ \ host -> do
+    Arrow.left show <$> runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice
+    Left FailureResponse{..} <- runEitherT (getQueryParam (Just "bob") host)
+    responseStatus `shouldBe` Status 400 "bob not found"
+
+  it "Servant.API.QueryParam.QueryParams" $ withServer $ \ host -> do
+    (Arrow.left show <$> runEitherT (getQueryParams [] host)) `shouldReturn` Right []
+    (Arrow.left show <$> runEitherT (getQueryParams ["alice", "bob"] host))
+      `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
+
+  context "Servant.API.QueryParam.QueryFlag" $
+    forM_ [False, True] $ \ flag ->
+    it (show flag) $ withServer $ \ host -> do
+      (Arrow.left show <$> runEitherT (getQueryFlag flag host)) `shouldReturn` Right flag
+
+  it "Servant.API.MatrixParam" $ withServer $ \ host -> do
+    Arrow.left show <$> runEitherT (getMatrixParam (Just "alice") host) `shouldReturn` Right alice
+    Left FailureResponse{..} <- runEitherT (getMatrixParam (Just "bob") host)
+    responseStatus `shouldBe` Status 400 "bob not found"
+
+  it "Servant.API.MatrixParam.MatrixParams" $ withServer $ \ host -> do
+    Arrow.left show <$> runEitherT (getMatrixParams [] host) `shouldReturn` Right []
+    Arrow.left show <$> runEitherT (getMatrixParams ["alice", "bob"] host)
+      `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
+
+  context "Servant.API.MatrixParam.MatrixFlag" $
+    forM_ [False, True] $ \ flag ->
+    it (show flag) $ withServer $ \ host -> do
+      Arrow.left show <$> runEitherT (getMatrixFlag flag host) `shouldReturn` Right flag
+
+  it "Servant.API.Raw on success" $ withServer $ \ host -> do
+    res <- runEitherT (getRawSuccess methodGet host)
+    case res of
+      Left e -> assertFailure $ show e
+      Right (code, body, ct, response) -> do
+        (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")
+        C.responseBody response `shouldBe` body
+        C.responseStatus response `shouldBe` ok200
+
+  it "Servant.API.Raw on failure" $ withServer $ \ host -> do
+    res <- runEitherT (getRawFailure methodGet host)
+    case res of
+      Left e -> assertFailure $ show e
+      Right (code, body, ct, response) -> do
+        (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream")
+        C.responseBody response `shouldBe` body
+        C.responseStatus response `shouldBe` badRequest400
+
+  modifyMaxSuccess (const 20) $ do
+    it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
+      property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
+        ioProperty $ do
+          withServer $ \ host -> do
+            result <- Arrow.left show <$> runEitherT (getMultiple cap num flag body host)
+            return $
+              result === Right (cap, num, flag, body)
+
+
+  context "client correctly handles error status codes" $ do
+    let test :: (WrappedApi, String) -> Spec
+        test (WrappedApi api, desc) =
+          it desc $
+          withWaiDaemon (return (serve api (left (500, "error message")))) $
+          \ host -> do
+            let getResponse :: BaseUrl -> EitherT ServantError IO ()
+                getResponse = client api
+            Left FailureResponse{..} <- runEitherT (getResponse host)
+            responseStatus `shouldBe` (Status 500 "error message")
+    mapM_ test $
+      (WrappedApi (Proxy :: Proxy Delete), "Delete") :
+      (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
+      (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
+      (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
+      []
+
+  context "client returns errors appropriately" $ do
+    it "reports FailureResponse" $ withFailServer $ \ host -> do
+      Left res <- runEitherT (getDelete host)
+      case res of
+        FailureResponse (Status 404 "Not Found") _ _ -> return ()
+        _ -> fail $ "expected 404 response, but got " <> show res
+
+    it "reports DecodeFailure" $ withFailServer $ \ host -> do
+      Left res <- runEitherT (getCapture "foo" host)
+      case res of
+        DecodeFailure _ ("application/json") _ -> return ()
+        _ -> fail $ "expected DecodeFailure, but got " <> show res
+
+    it "reports ConnectionError" $ do
+      Right host <- return $ parseBaseUrl "127.0.0.1:987654"
+      Left res <- runEitherT (getGet host)
+      case res of
+        ConnectionError (C.FailedConnectionException2 "127.0.0.1" 987654 False _) -> return ()
+        _ -> fail $ "expected ConnectionError, but got " <> show res
+
+    it "reports UnsupportedContentType" $ withFailServer $ \ host -> do
+      Left res <- runEitherT (getGet host)
+      case res of
+        UnsupportedContentType ("application/octet-stream") _ -> return ()
+        _ -> fail $ "expected UnsupportedContentType, but got " <> show res
+
+    it "reports InvalidContentTypeHeader" $ withFailServer $ \ host -> do
+      Left res <- runEitherT (getBody alice host)
+      case res of
+        InvalidContentTypeHeader "fooooo" _ -> return ()
+        _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
+
+data WrappedApi where
+  WrappedApi :: (HasServer (Canonicalize api), Server api ~ EitherT (Int, String) IO a,
+                 HasClient (Canonicalize api), Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
+    Proxy api -> WrappedApi
+
+
+-- * utils
+
+withWaiDaemon :: IO Application -> (BaseUrl -> IO a) -> IO a
+withWaiDaemon mkApplication action = do
+  application <- mkApplication
+  bracket (acquire application) free (\ (_, _, baseUrl) -> action baseUrl)
+ where
+  acquire application = do
+    (notifyStart, waitForStart) <- lvar
+    (notifyKilled, waitForKilled) <- lvar
+    thread <- forkIO $ (do
+      (krakenPort, socket) <- openTestSocket
+      let settings =
+            setPort krakenPort $ -- set here just for consistency, shouldn't be
+                                 -- used (it's set in the socket)
+            setBeforeMainLoop (notifyStart krakenPort)
+            defaultSettings
+      runSettingsSocket settings socket application)
+            `finally` notifyKilled ()
+    krakenPort <- waitForStart
+    let baseUrl = (BaseUrl Http "localhost" 80){baseUrlPort = krakenPort}
+    return (thread, waitForKilled, baseUrl)
+  free (thread, waitForKilled, _) = do
+    killThread thread
+    waitForKilled
+
+  lvar :: IO (a -> IO (), IO a)
+  lvar = do
+    mvar <- newEmptyMVar
+    let put = putMVar mvar
+        wait = readMVar mvar
+    return (put, wait)
+
+openTestSocket :: IO (Port, Socket)
+openTestSocket = do
+  s <- socket AF_INET Stream defaultProtocol
+  localhost <- inet_addr "127.0.0.1"
+  bind s (SockAddrInet aNY_PORT localhost)
+  listen s 1
+  port <- socketPort s
+  return (fromIntegral port, s)
+
+pathGen :: Gen (NonEmptyList Char)
+pathGen = fmap NonEmpty path
+ where
+  path = listOf1 $ elements $
+    filter (not . (`elem` "?%[]/#;")) $
+    filter isPrint $
+    map chr [0..127]

servant-client/test/Servant/Common/BaseUrlSpec.hs

@@ -0,0 +1,69 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Servant.Common.BaseUrlSpec where
+
+import Control.Applicative
+import Control.DeepSeq
+import Test.Hspec
+import Test.QuickCheck
+
+import Servant.Common.BaseUrl
+
+spec :: Spec
+spec = do
+  describe "showBaseUrl" $ do
+    it "shows a BaseUrl" $ do
+      showBaseUrl (BaseUrl Http "foo.com" 80) `shouldBe` "http://foo.com"
+
+    it "shows a https BaseUrl" $ do
+      showBaseUrl (BaseUrl Https "foo.com" 443) `shouldBe` "https://foo.com"
+
+  describe "httpBaseUrl" $ do
+    it "allows to construct default http BaseUrls" $ do
+      BaseUrl Http "bar" 80 `shouldBe` BaseUrl Http "bar" 80
+
+  describe "parseBaseUrl" $ do
+    it "is total" $ do
+      property $ \ string ->
+        deepseq (fmap show (parseBaseUrl string)) True
+
+    it "is the inverse of showBaseUrl" $ do
+      property $ \ baseUrl ->
+        counterexample (showBaseUrl baseUrl) $
+        parseBaseUrl (showBaseUrl baseUrl) ===
+          Right baseUrl
+
+    it "allows trailing slashes" $ do
+      parseBaseUrl "foo.com/" `shouldBe` Right (BaseUrl Http "foo.com" 80)
+
+    context "urls without scheme" $ do
+      it "assumes http" $ do
+        parseBaseUrl "foo.com" `shouldBe` Right (BaseUrl Http "foo.com" 80)
+
+      it "allows port numbers" $ do
+        parseBaseUrl "foo.com:8080" `shouldBe` Right (BaseUrl Http "foo.com" 8080)
+
+    it "rejects ftp urls" $ do
+      parseBaseUrl "ftp://foo.com" `shouldSatisfy` isLeft
+
+instance Arbitrary BaseUrl where
+  arbitrary = BaseUrl <$>
+    elements [Http, Https] <*>
+    hostNameGen <*>
+    portGen
+   where
+    -- this does not perfectly mirror the url standard, but I hope it's good
+    -- enough.
+    hostNameGen = do
+      let letters = ['a' .. 'z'] ++ ['A' .. 'Z']
+      first <- elements letters
+      middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-'])
+      last <- elements letters
+      return (first : middle ++ [last])
+    portGen = frequency $
+      (1, return 80) :
+      (1, return 443) :
+      (1, choose (1, 20000)) :
+      []
+
+isLeft :: Either a b -> Bool
+isLeft = either (const True) (const False)

servant-docs/CHANGELOG.md

@@ -0,0 +1,15 @@
+0.4
+---
+* Allow for extra information to be added to the docs
+* Support content-type aware combinators of *servant-0.3*
+* Render endpoints in a canonical order (https://github.com/haskell-servant/servant-docs/pull/15)
+* Remove ToJSON superclass from ToSample
+* Split out Internal module
+* `Canonicalize` API types before generating the docs for them
+
+0.3
+---
+
+* Add the ability to display multiple responses, with some accompanying `Text` to describe the context in which we get the corresponding JSON.
+* Expose the `headers` lens
+* Represent an endpoint's path as `[String]` (previously `String`), fixing a corner case where the leading `/` would be missing.

servant-docs/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2014, Zalora South East Asia Pte Ltd
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Zalora South East Asia Pte Ltd nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

servant-docs/README.md

@@ -0,0 +1,72 @@
+# servant-docs
+
+[![Build Status](https://secure.travis-ci.org/haskell-servant/servant-docs.svg)](http://travis-ci.org/haskell-servant/servant-docs)
+
+![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
+
+Generate API docs for your *servant* webservice. Feel free to also take a look at [servant-pandoc](https://github.com/mpickering/servant-pandoc) which uses this package to target a broad range of output formats using the excellent **pandoc**.
+
+## Example
+
+See [here](https://github.com/haskell-servant/servant-docs/blob/master/example/greet.md) for the output of the following program.
+
+``` haskell
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+import Data.Proxy
+import Data.Text
+import Servant
+
+-- our type for a Greeting message
+data Greet = Greet { _msg :: Text }
+  deriving (Generic, Show)
+
+-- we get our JSON serialization for free. This will be used by the default
+-- 'MimeRender' instance for 'JSON'.
+instance FromJSON Greet
+instance ToJSON Greet
+
+-- We can also implement 'MimeRender' explicitly for additional formats.
+instance MimeRender PlainText Greet where
+    toByteString Proxy (Greet s) = "<h1>" <> cs s <> "</h1>"
+
+-- we provide a sample value for the 'Greet' type
+instance ToSample Greet where
+  toSample = Just g
+
+    where g = Greet "Hello, haskeller!"
+
+instance ToParam (QueryParam "capital" Bool) where
+  toParam _ =
+    DocQueryParam "capital"
+                  ["true", "false"]
+                  "Get the greeting message in uppercase (true) or not (false). Default is false."
+
+instance ToCapture (Capture "name" Text) where
+  toCapture _ = DocCapture "name" "name of the person to greet"
+
+instance ToCapture (Capture "greetid" Text) where
+  toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"
+
+-- API specification
+type TestApi =
+       "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON,PlainText] Greet
+  :<|> "greet" :> RQBody '[JSON] Greet :> Post '[JSON] Greet
+  :<|> "delete" :> Capture "greetid" Text :> Delete
+
+testApi :: Proxy TestApi
+testApi = Proxy
+
+-- Generate the Documentation's ADT
+greetDocs :: API
+greetDocs = docs testApi
+
+main :: IO ()
+main = putStrLn $ markdown greetDocs
+```

servant-docs/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

servant-docs/default.nix

@@ -0,0 +1,19 @@
+{ mkDerivation, aeson, base, bytestring, hashable, hspec
+, http-media, lens, servant, stdenv, string-conversions, text
+, unordered-containers
+}:
+mkDerivation {
+  pname = "servant-docs";
+  version = "0.3";
+  src = ./.;
+  isLibrary = true;
+  isExecutable = true;
+  buildDepends = [
+    aeson base bytestring hashable http-media lens servant
+    string-conversions text unordered-containers
+  ];
+  testDepends = [ aeson base hspec lens servant ];
+  homepage = "http://haskell-servant.github.io/";
+  description = "generate API docs for your servant webservice";
+  license = stdenv.lib.licenses.bsd3;
+}

servant-docs/docs.sh

@@ -0,0 +1,52 @@
+SERVANT_DIR=/tmp/servant-docs-gh-pages
+
+# Make a temporary clone
+
+rm -rf $SERVANT_DIR
+
+git clone . $SERVANT_DIR
+
+cd $SERVANT_DIR
+
+# Make sure to pull the latest
+
+git remote add haskell-servant git@github.com:haskell-servant/servant-docs.git
+
+git fetch haskell-servant
+
+git reset --hard haskell-servant/gh-pages
+
+# Clear everything away
+
+git rm -rf $SERVANT_DIR/*
+
+# Switch back and build the haddocks
+
+cd -
+
+cabal configure --builddir=$SERVANT_DIR
+
+cabal haddock --hoogle --hyperlink-source --html-location='https://hackage.haskell.org/package/$pkg-$version/docs' --builddir=$SERVANT_DIR
+
+commit_hash=$(git rev-parse HEAD)
+
+# Move the HTML docs to the root
+
+cd $SERVANT_DIR
+
+rm *
+rm -rf build
+mv doc/html/servant-docs/* .
+rm -r doc/
+
+# Add everything
+
+git add .
+
+git commit -m "Built from $commit_hash"
+
+# Push to update the pages
+
+git push haskell-servant HEAD:gh-pages
+
+rm -rf $SERVANT_DIR

servant-docs/example/greet.hs

@@ -0,0 +1,117 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+import Control.Lens
+import Data.Aeson
+import Data.Proxy
+import Data.String.Conversions
+import Data.Text (Text)
+import GHC.Generics
+import Servant.API
+import Servant.Docs
+
+-- * Example
+
+-- | A greet message data type
+newtype Greet = Greet Text
+  deriving (Generic, Show)
+
+-- | We can get JSON support automatically. This will be used to parse
+-- and encode a Greeting as 'JSON'.
+instance FromJSON Greet
+instance ToJSON Greet
+
+-- | We can also implement 'MimeRender' for additional formats like 'PlainText'.
+instance MimeRender PlainText Greet where
+    mimeRender Proxy (Greet s) = "\"" <> cs s <> "\""
+
+-- We add some useful annotations to our captures,
+-- query parameters and request body to make the docs
+-- really helpful.
+instance ToCapture (Capture "name" Text) where
+  toCapture _ = DocCapture "name" "name of the person to greet"
+
+instance ToCapture (Capture "greetid" Text) where
+  toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"
+
+instance ToParam (QueryParam "capital" Bool) where
+  toParam _ =
+    DocQueryParam "capital"
+                  ["true", "false"]
+                  "Get the greeting message in uppercase (true) or not (false).\
+                  \Default is false."
+                  Normal
+
+instance ToParam (MatrixParam "lang" String) where
+  toParam _ =
+    DocQueryParam "lang"
+                  ["en", "sv", "fr"]
+                  "Get the greeting message selected language. Default is en."
+                  Normal
+
+instance ToSample Greet where
+  toSample = Just $ Greet "Hello, haskeller!"
+
+  toSamples =
+    [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")
+    , ("If you use ?capital=false", Greet "Hello, haskeller")
+    ]
+
+-- We define some introductory sections, these will appear at the top of the
+-- documentation.
+--
+-- We pass them in with 'docsWith', below. If you only want to add
+-- introductions, you may use 'docsWithIntros'
+intro1 :: DocIntro
+intro1 = DocIntro "On proper introductions." -- The title
+    [ "Hello there."
+    , "As documentation is usually written for humans, it's often useful \
+      \to introduce concepts with a few words." ] -- Elements are paragraphs
+
+intro2 :: DocIntro
+intro2 = DocIntro "This title is below the last"
+    [ "You'll also note that multiple intros are possible." ]
+
+
+-- API specification
+type TestApi =
+       -- GET /hello/:name?capital={true, false}  returns a Greet as JSON or PlainText
+       "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet
+
+       -- POST /greet with a Greet as JSON in the request body,
+       --             returns a Greet as JSON
+  :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
+
+       -- DELETE /greet/:greetid
+  :<|> "greet" :> Capture "greetid" Text :> Delete
+
+testApi :: Proxy TestApi
+testApi = Proxy
+
+-- Build some extra information for the DELETE /greet/:greetid endpoint. We
+-- want to add documentation about a secret unicorn header and some extra
+-- notes.
+extra :: ExtraInfo TestApi
+extra =
+    extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
+             defAction & headers <>~ ["unicorns"]
+                       & notes   <>~ [ DocNote "Title" ["This is some text"]
+                                     , DocNote "Second secton" ["And some more"]
+                                     ]
+
+-- Generate the data that lets us have API docs. This
+-- is derived from the type as well as from
+-- the 'ToCapture', 'ToParam' and 'ToSample' instances from above.
+--
+-- If you didn't want intros and extra information, you could just call:
+--
+-- > docs testAPI :: API
+docsGreet :: API
+docsGreet = docsWith [intro1, intro2] extra testApi
+
+main :: IO ()
+main = putStrLn $ markdown docsGreet

servant-docs/example/greet.md

@@ -0,0 +1,124 @@
+#### On proper introductions.
+
+Hello there.
+
+As documentation is usually written for humans, it's often useful to introduce concepts with a few words.
+
+#### This title is below the last
+
+You'll also note that multiple intros are possible.
+
+## POST /greet
+
+#### Request:
+
+- Supported content types are:
+
+    - `application/json`
+
+- Example: `application/json`
+
+```javascript
+"Hello, haskeller!"
+```
+
+#### Response:
+
+- Status code 201
+
+- Supported content types are:
+
+    - `application/json`
+
+- If you use ?capital=true
+
+```javascript
+"HELLO, HASKELLER"
+```
+
+- If you use ?capital=false
+
+```javascript
+"Hello, haskeller"
+```
+
+## GET /hello;lang=<value>/:name
+
+#### Captures:
+
+- *name*: name of the person to greet
+
+#### Matrix Parameters:
+
+**hello**:
+
+- lang
+     - **Values**: *en, sv, fr*
+     - **Description**: Get the greeting message selected language. Default is en.
+
+
+
+#### GET Parameters:
+
+- capital
+     - **Values**: *true, false*
+     - **Description**: Get the greeting message in uppercase (true) or not (false).Default is false.
+
+
+#### Response:
+
+- Status code 200
+
+- Supported content types are:
+
+    - `application/json`
+    - `text/plain;charset=utf-8`
+
+- If you use ?capital=true
+
+```javascript
+"HELLO, HASKELLER"
+```
+
+- If you use ?capital=true
+
+```
+"HELLO, HASKELLER"
+```
+
+- If you use ?capital=false
+
+```javascript
+"Hello, haskeller"
+```
+
+- If you use ?capital=false
+
+```
+"Hello, haskeller"
+```
+
+## DELETE /greet/:greetid
+
+#### Title
+
+This is some text
+
+#### Second secton
+
+And some more
+
+#### Captures:
+
+- *greetid*: identifier of the greet msg to remove
+
+
+- This endpoint is sensitive to the value of the **unicorns** HTTP header.
+
+#### Response:
+
+- Status code 200
+
+- No response body
+
+

servant-docs/servant-docs.cabal

@@ -0,0 +1,71 @@
+name:                servant-docs
+version:             0.3
+synopsis:            generate API docs for your servant webservice
+description:
+  Library for generating API docs from a servant API definition.
+  .
+  Runnable example <https://github.com/haskell-servant/servant-docs/blob/master/example/greet.hs here>.
+license:             BSD3
+license-file:        LICENSE
+author:              Alp Mestanogullari, Sönke Hahn, Julian K. Arni
+maintainer:          alpmestan@gmail.com
+copyright:           2014-2015 Zalora South East Asia Pte Ltd
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+tested-with:         GHC >= 7.8
+homepage:            http://haskell-servant.github.io/
+Bug-reports:         http://github.com/haskell-servant/servant-docs/issues
+extra-source-files:
+  CHANGELOG.md
+  README.md
+source-repository head
+  type: git
+  location: http://github.com/haskell-servant/servant-docs.git
+
+library
+  exposed-modules:
+      Servant.Docs
+    , Servant.Docs.Internal
+  build-depends:
+      base >=4.7 && <5
+    , bytestring
+    , hashable
+    , http-media >= 0.6
+    , lens
+    , servant >= 0.2.1
+    , string-conversions
+    , text
+    , unordered-containers
+  hs-source-dirs: src
+  default-language: Haskell2010
+  ghc-options: -Wall
+
+executable greet-docs
+  main-is: greet.hs
+  hs-source-dirs: example
+  ghc-options: -Wall
+  build-depends:
+      base
+    , aeson
+    , lens
+    , servant
+    , servant-docs
+    , string-conversions
+    , text
+  default-language: Haskell2010
+
+test-suite spec
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  hs-source-dirs: test
+  ghc-options: -Wall
+  build-depends:
+      base
+    , aeson
+    , hspec
+    , servant
+    , servant-docs
+    , string-conversions
+  default-language: Haskell2010
+

servant-docs/shell.nix

@@ -0,0 +1,9 @@
+with (import <nixpkgs> {}).pkgs;
+let modifiedHaskellPackages = haskellngPackages.override {
+      overrides = self: super: {
+        servant = self.callPackage ../servant {};
+        servant-server = self.callPackage ./servant-server {};
+        servant-docs = self.callPackage ./. {};
+      };
+    };
+in modifiedHaskellPackages.servant-docs.env

servant-docs/src/Servant/Docs.hs

@@ -0,0 +1,168 @@
+-------------------------------------------------------------------------------
+-- | This module lets you get API docs for free. It lets you generate
+-- an 'API' from the type that represents your API using 'docs':
+--
+-- @docs :: 'HasDocs' api => 'Proxy' api -> 'API'@
+--
+-- Alternatively, if you wish to add one or more introductions to your
+-- documentation, use 'docsWithIntros':
+--
+-- @'docsWithIntros' :: 'HasDocs' api => [DocIntro] -> 'Proxy' api -> 'API'@
+--
+-- You can then call 'markdown' on the 'API' value:
+--
+-- @'markdown' :: 'API' -> String@
+--
+-- or define a custom pretty printer:
+--
+-- @yourPrettyDocs :: 'API' -> String -- or blaze-html's HTML, or ...@
+--
+-- The only thing you'll need to do will be to implement some classes
+-- for your captures, get parameters and request or response bodies.
+--
+-- Here is a complete example that you can run to see the markdown pretty
+-- printer in action:
+--
+-- > {-# LANGUAGE DataKinds             #-}
+-- > {-# LANGUAGE DeriveGeneric         #-}
+-- > {-# LANGUAGE FlexibleInstances     #-}
+-- > {-# LANGUAGE MultiParamTypeClasses #-}
+-- > {-# LANGUAGE OverloadedStrings     #-}
+-- > {-# LANGUAGE TypeOperators         #-}
+-- > {-# OPTIONS_GHC -fno-warn-orphans #-}
+-- > import Data.Aeson
+-- > import Data.Proxy
+-- > import Data.String.Conversions
+-- > import Data.Text (Text)
+-- > import GHC.Generics
+-- > import Servant.API
+-- > import Servant.Docs
+-- >
+-- > -- * Example
+-- >
+-- > -- | A greet message data type
+-- > newtype Greet = Greet Text
+-- >   deriving (Generic, Show)
+-- >
+-- > -- | We can get JSON support automatically. This will be used to parse
+-- > -- and encode a Greeting as 'JSON'.
+-- > instance FromJSON Greet
+-- > instance ToJSON Greet
+-- >
+-- > -- | We can also implement 'MimeRender' for additional formats like 'PlainText'.
+-- > instance MimeRender PlainText Greet where
+-- >     toByteString Proxy (Greet s) = "\"" <> cs s <> "\""
+-- >
+-- > -- We add some useful annotations to our captures,
+-- > -- query parameters and request body to make the docs
+-- > -- really helpful.
+-- > instance ToCapture (Capture "name" Text) where
+-- >   toCapture _ = DocCapture "name" "name of the person to greet"
+-- >
+-- > instance ToCapture (Capture "greetid" Text) where
+-- >   toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"
+-- >
+-- > instance ToParam (QueryParam "capital" Bool) where
+-- >   toParam _ =
+-- >     DocQueryParam "capital"
+-- >                   ["true", "false"]
+-- >                   "Get the greeting message in uppercase (true) or not (false).\
+-- >                   \Default is false."
+-- >                   Normal
+-- >
+-- > instance ToParam (MatrixParam "lang" String) where
+-- >   toParam _ =
+-- >     DocQueryParam "lang"
+-- >                   ["en", "sv", "fr"]
+-- >                   "Get the greeting message selected language. Default is en."
+-- >                   Normal
+-- >
+-- > instance ToSample Greet where
+-- >   toSample = Just $ Greet "Hello, haskeller!"
+-- >
+-- >   toSamples =
+-- >     [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")
+-- >     , ("If you use ?capital=false", Greet "Hello, haskeller")
+-- >     ]
+-- >
+-- > -- We define some introductory sections, these will appear at the top of the
+-- > -- documentation.
+-- > --
+-- > -- We pass them in with 'docsWith', below. If you only want to add
+-- > -- introductions, you may use 'docsWithIntros'
+-- > intro1 :: DocIntro
+-- > intro1 = DocIntro "On proper introductions." -- The title
+-- >     [ "Hello there."
+-- >     , "As documentation is usually written for humans, it's often useful \
+-- >       \to introduce concepts with a few words." ] -- Elements are paragraphs
+-- >
+-- > intro2 :: DocIntro
+-- > intro2 = DocIntro "This title is below the last"
+-- >     [ "You'll also note that multiple intros are possible." ]
+-- >
+-- >
+-- > -- API specification
+-- > type TestApi =
+-- >        -- GET /hello/:name?capital={true, false}  returns a Greet as JSON or PlainText
+-- >        "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet
+-- >
+-- >        -- POST /greet with a Greet as JSON in the request body,
+-- >        --             returns a Greet as JSON
+-- >   :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
+-- >
+-- >        -- DELETE /greet/:greetid
+-- >   :<|> "greet" :> Capture "greetid" Text :> Delete
+-- >
+-- > testApi :: Proxy TestApi
+-- > testApi = Proxy
+-- >
+-- > -- Build some extra information for the DELETE /greet/:greetid endpoint. We
+-- > -- want to add documentation about a secret unicorn header and some extra
+-- > -- notes.
+-- > extra :: ExtraInfo TestApi
+-- > extra =
+-- >     extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
+-- >              defAction & headers <>~ ["unicorns"]
+-- >                        & notes   <>~ [ DocNote "Title" ["This is some text"]
+-- >                                      , DocNote "Second secton" ["And some more"]
+-- >                                      ]
+-- >
+-- > -- Generate the data that lets us have API docs. This
+-- > -- is derived from the type as well as from
+-- > -- the 'ToCapture', 'ToParam' and 'ToSample' instances from above.
+-- > --
+-- > -- If you didn't want intros and extra information, you could just call:
+-- > --
+-- > -- > docs testAPI :: API
+-- > docsGreet :: API
+-- > docsGreet = docsWith [intro1, intro2] extra testApi
+-- >
+-- > main :: IO ()
+-- > main = putStrLn $ markdown docsGreet
+module Servant.Docs
+  ( -- * 'HasDocs' class and key functions
+    HasDocs(..), docs, markdown
+    -- * Generating docs with extra information
+  , ExtraInfo(..), docsWith, docsWithIntros, extraInfo
+
+  , -- * Classes you need to implement for your types
+    ToSample(..)
+  , sampleByteString
+  , sampleByteStrings
+  , ToParam(..)
+  , ToCapture(..)
+
+  , -- * ADTs to represent an 'API'
+    Method(..)
+  , Endpoint, path, method, defEndpoint
+  , API, emptyAPI
+  , DocCapture(..), capSymbol, capDesc
+  , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind
+  , DocNote(..), noteTitle, noteBody
+  , DocIntro(..)
+  , Response(..), respStatus, respTypes, respBody, defResponse
+  , Action, captures, headers, notes, params, rqtypes, rqbody, response, defAction
+  , single
+  ) where
+
+import Servant.Docs.Internal

servant-docs/src/Servant/Docs/Internal.hs

@@ -0,0 +1,803 @@
+{-# LANGUAGE ConstraintKinds      #-}
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE PolyKinds            #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE TupleSections        #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Servant.Docs.Internal where
+
+import           Control.Applicative
+import           Control.Lens
+import           Data.ByteString.Lazy.Char8 (ByteString)
+import           Data.Hashable
+import           Data.HashMap.Strict        (HashMap)
+import           Data.List
+import           Data.Maybe
+import           Data.Monoid
+import           Data.Ord                   (comparing)
+import           Data.Proxy
+import           Data.String.Conversions
+import           Data.Text                  (Text, pack, unpack)
+import           GHC.Exts                   (Constraint)
+import           GHC.Generics
+import           GHC.TypeLits
+import           Servant.API
+import           Servant.API.ContentTypes
+import           Servant.Utils.Links
+
+import qualified Data.HashMap.Strict        as HM
+import qualified Data.Text                  as T
+import qualified Network.HTTP.Media         as M
+
+-- | 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'
+-- or any 'Endpoint' value you want using the 'path' and 'method'
+-- lenses to tweak.
+--
+-- @
+-- λ> 'defEndpoint'
+-- GET /
+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
+-- GET /foo
+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'
+-- POST /foo
+-- @
+data Endpoint = Endpoint
+  { _path   :: [String] -- type collected
+  , _method :: Method   -- type collected
+  } deriving (Eq, Ord, Generic)
+
+instance Show Endpoint where
+  show (Endpoint p m) =
+    show m ++ " " ++ showPath p
+
+-- |
+-- Render a path as a '/'-delimited string
+--
+showPath :: [String] -> String
+showPath [] = "/"
+showPath ps = concatMap ('/' :) ps
+
+-- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET'
+--
+-- Here's how you can modify it:
+--
+-- @
+-- λ> 'defEndpoint'
+-- GET /
+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
+-- GET /foo
+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'
+-- POST /foo
+-- @
+defEndpoint :: Endpoint
+defEndpoint = Endpoint [] DocGET
+
+instance Hashable Endpoint
+
+-- | Our API documentation type, a product of top-level information and a good
+-- old hashmap from 'Endpoint' to 'Action'
+data API = API
+  { _apiIntros    :: [DocIntro]
+  , _apiEndpoints :: HashMap Endpoint Action
+  } deriving (Eq, Show)
+
+instance Monoid API where
+    API a1 b1 `mappend` API a2 b2 = API (a1 <> a2) (b1 <> b2)
+    mempty = API mempty mempty
+
+-- | An empty 'API'
+emptyAPI :: API
+emptyAPI = mempty
+
+-- | A type to represent captures. Holds the name of the capture
+--   and a description.
+--
+-- Write a 'ToCapture' instance for your captured types.
+data DocCapture = DocCapture
+  { _capSymbol :: String -- type supplied
+  , _capDesc   :: String -- user supplied
+  } deriving (Eq, Ord, Show)
+
+-- | A type to represent a /GET/ parameter from the Query String. Holds its name,
+--   the possible values (leave empty if there isn't a finite number of them),
+--   and a description of how it influences the output or behavior.
+--
+-- Write a 'ToParam' instance for your GET parameter types
+data DocQueryParam = DocQueryParam
+  { _paramName   :: String   -- type supplied
+  , _paramValues :: [String] -- user supplied
+  , _paramDesc   :: String   -- user supplied
+  , _paramKind   :: ParamKind
+  } deriving (Eq, Ord, Show)
+
+-- | An introductory paragraph for your documentation. You can pass these to
+-- 'docsWithIntros'.
+data DocIntro = DocIntro
+  { _introTitle :: String   -- ^ Appears above the intro blob
+  , _introBody  :: [String] -- ^ Each String is a paragraph.
+  } deriving (Eq, Show)
+
+instance Ord DocIntro where
+    compare = comparing _introTitle
+
+-- | A type to represent extra notes that may be attached to an 'Action'.
+--
+-- This is intended to be used when writing your own HasDocs instances to
+-- add extra sections to your endpoint's documentation.
+data DocNote = DocNote
+  { _noteTitle :: String
+  , _noteBody  :: [String]
+  } deriving (Eq, Ord, Show)
+
+-- | Type of extra information that a user may wish to "union" with their
+-- documentation.
+--
+-- These are intended to be built using extraInfo.
+-- Multiple ExtraInfo may be combined with the monoid instance.
+newtype ExtraInfo layout = ExtraInfo (HashMap Endpoint Action)
+instance Monoid (ExtraInfo a) where
+    mempty = ExtraInfo mempty
+    ExtraInfo a `mappend` ExtraInfo b =
+        ExtraInfo $ HM.unionWith combineAction a b
+
+-- | Type of GET parameter:
+--
+-- - Normal corresponds to @QueryParam@, i.e your usual GET parameter
+-- - List corresponds to @QueryParams@, i.e GET parameters with multiple values
+-- - Flag corresponds to @QueryFlag@, i.e a value-less GET parameter
+data ParamKind = Normal | List | Flag
+  deriving (Eq, Ord, Show)
+
+-- | A type to represent an HTTP response. Has an 'Int' status, a list of
+-- possible 'MediaType's, and a list of example 'ByteString' response bodies.
+-- Tweak 'defResponse' using the 'respStatus', 'respTypes' and 'respBody'
+-- lenses if you want.
+--
+-- If you want to respond with a non-empty response body, you'll most likely
+-- want to write a 'ToSample' instance for the type that'll be represented
+-- as encoded data in the response.
+--
+-- Can be tweaked with three lenses.
+--
+-- > λ> defResponse
+-- > Response {_respStatus = 200, _respTypes = [], _respBody = []}
+-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
+-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
+data Response = Response
+  { _respStatus :: Int
+  , _respTypes  :: [M.MediaType]
+  , _respBody   :: [(Text, M.MediaType, ByteString)]
+  } deriving (Eq, Ord, Show)
+
+-- | Default response: status code 200, no response body.
+--
+-- Can be tweaked with two lenses.
+--
+-- > λ> defResponse
+-- > Response {_respStatus = 200, _respBody = Nothing}
+-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
+-- > Response {_respStatus = 204, _respBody = Just "[]"}
+defResponse :: Response
+defResponse = Response 200 [] []
+
+-- | A datatype that represents everything that can happen
+-- at an endpoint, with its lenses:
+--
+-- - List of captures ('captures')
+-- - List of GET parameters ('params')
+-- - What the request body should look like, if any is requested ('rqbody')
+-- - What the response should be if everything goes well ('response')
+--
+-- You can tweak an 'Action' (like the default 'defAction') with these lenses
+-- to transform an action and add some information to it.
+data Action = Action
+  { _captures :: [DocCapture]                -- type collected + user supplied info
+  , _headers  :: [Text]                      -- type collected
+  , _params   :: [DocQueryParam]             -- type collected + user supplied info
+  , _notes    :: [DocNote]                   -- user supplied
+  , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
+  , _rqtypes  :: [M.MediaType]               -- type collected
+  , _rqbody   :: [(M.MediaType, ByteString)] -- user supplied
+  , _response :: Response                    -- user supplied
+  } deriving (Eq, Ord, Show)
+
+-- | Combine two Actions, we can't make a monoid as merging Response breaks the
+-- laws.
+--
+-- As such, we invent a non-commutative, left associative operation
+-- 'combineAction' to mush two together taking the response, body and content
+-- types from the very left.
+combineAction :: Action -> Action -> Action
+Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ =
+        Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
+
+-- Default 'Action'. Has no 'captures', no GET 'params', expects
+-- no request body ('rqbody') and the typical response is 'defResponse'.
+--
+-- Tweakable with lenses.
+--
+-- > λ> defAction
+-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}}
+-- > λ> defAction & response.respStatus .~ 201
+-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}}
+defAction :: Action
+defAction =
+  Action []
+         []
+         []
+         []
+         []
+         []
+         []
+         defResponse
+
+-- | Create an API that's comprised of a single endpoint.
+--   'API' is a 'Monoid', so combine multiple endpoints with
+--   'mappend' or '<>'.
+single :: Endpoint -> Action -> API
+single e a = API mempty (HM.singleton e a)
+
+-- gimme some lenses
+makeLenses ''API
+makeLenses ''Endpoint
+makeLenses ''DocCapture
+makeLenses ''DocQueryParam
+makeLenses ''DocIntro
+makeLenses ''DocNote
+makeLenses ''Response
+makeLenses ''Action
+
+-- | Generate the docs for a given API that implements 'HasDocs'. This is the
+-- default way to create documentation.
+docs :: HasDocs (Canonicalize layout) => Proxy layout -> API
+docs p = docsFor (canonicalize p) (defEndpoint, defAction)
+
+-- | Closed type family, check if endpoint is exactly within API.
+
+-- We aren't sure what affects how an Endpoint is built up, so we require an
+-- exact match.
+type family IsIn (endpoint :: *) (api :: *) :: Constraint where
+    IsIn e (sa :<|> sb)                = Or (IsIn e sa) (IsIn e sb)
+    IsIn (e :> sa) (e :> sb)           = IsIn sa sb
+    IsIn e e                           = ()
+
+-- | Create an 'ExtraInfo' that is garunteed to be within the given API layout.
+--
+-- The safety here is to ensure that you only add custom documentation to an
+-- endpoint that actually exists within your API.
+--
+-- > extra :: ExtraInfo TestApi
+-- > extra =
+-- >     extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
+-- >              defAction & headers <>~ ["unicorns"]
+-- >                        & notes   <>~ [ DocNote "Title" ["This is some text"]
+-- >                                      , DocNote "Second secton" ["And some more"]
+-- >                                      ]
+
+extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)
+          => Proxy endpoint -> Action -> ExtraInfo layout
+extraInfo p action =
+    let api = docsFor p (defEndpoint, defAction)
+    -- Assume one endpoint, HasLink constraint means that we should only ever
+    -- point at one endpoint.
+    in ExtraInfo $ api ^. apiEndpoints & traversed .~ action
+
+-- | Generate documentation given some extra introductions (in the form of
+-- 'DocInfo') and some extra endpoint documentation (in the form of
+-- 'ExtraInfo'.
+--
+-- The extra introductions will be prepended to the top of the documentation,
+-- before the specific endpoint documentation. The extra endpoint documentation
+-- will be "unioned" with the automatically generated endpoint documentation.
+--
+-- You are expected to build up the ExtraInfo with the Monoid instance and
+-- 'extraInfo'.
+--
+-- If you only want to add an introduction, use 'docsWithIntros'.
+docsWith :: HasDocs (Canonicalize layout)
+         => [DocIntro]
+         -> ExtraInfo layout
+         -> Proxy layout
+         -> API
+docsWith intros (ExtraInfo endpoints) p =
+    docs p & apiIntros <>~ intros
+           & apiEndpoints %~ HM.unionWith combineAction endpoints
+
+
+-- | Generate the docs for a given API that implements 'HasDocs' with with any
+-- number of introduction(s)
+docsWithIntros :: HasDocs (Canonicalize layout) => [DocIntro] -> Proxy layout -> API
+docsWithIntros intros = docsWith intros mempty
+
+-- | The class that abstracts away the impact of API combinators
+--   on documentation generation.
+class HasDocs layout where
+  docsFor :: Proxy layout -> (Endpoint, Action) -> API
+
+-- | The class that lets us display a sample input or output in the supported
+-- content-types when generating documentation for endpoints that either:
+--
+-- - expect a request body, or
+-- - return a non empty response body
+--
+-- Example of an instance:
+--
+-- > {-# LANGUAGE DeriveGeneric #-}
+-- > {-# LANGUAGE OverloadedStrings #-}
+-- >
+-- > import Data.Aeson
+-- > import Data.Text
+-- > import GHC.Generics
+-- >
+-- > data Greet = Greet { _msg :: Text }
+-- >   deriving (Generic, Show)
+-- >
+-- > instance FromJSON Greet
+-- > instance ToJSON Greet
+-- >
+-- > instance ToSample Greet where
+-- >   toSample = Just g
+-- >
+-- >     where g = Greet "Hello, haskeller!"
+--
+-- You can also instantiate this class using 'toSamples' instead of
+-- 'toSample': it lets you specify different responses along with
+-- some context (as 'Text') that explains when you're supposed to
+-- get the corresponding response.
+class ToSample a where
+  {-# MINIMAL (toSample | toSamples) #-}
+  toSample :: Maybe a
+  toSample = snd <$> listToMaybe samples
+    where samples = toSamples :: [(Text, a)]
+
+  toSamples :: [(Text, a)]
+  toSamples = maybe [] (return . ("",)) s
+    where s = toSample :: Maybe a
+
+-- | 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
+    -> Proxy a
+    -> [(M.MediaType, ByteString)]
+sampleByteString ctypes@Proxy Proxy =
+    maybe [] (allMimeRender ctypes) (toSample :: Maybe a)
+
+-- | 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
+    -> Proxy a
+    -> [(Text, M.MediaType, ByteString)]
+sampleByteStrings ctypes@Proxy Proxy =
+    let samples = toSamples :: [(Text, a)]
+        enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
+    in concatMap enc samples
+
+-- | Generate a list of 'MediaType' values describing the content types
+-- accepted by an API component.
+class SupportedTypes (list :: [*]) where
+    supportedTypes :: Proxy list -> [M.MediaType]
+
+instance SupportedTypes '[] where
+    supportedTypes Proxy = []
+
+instance (Accept ctype, SupportedTypes rest) => SupportedTypes (ctype ': rest)
+  where
+    supportedTypes Proxy =
+        contentType (Proxy :: Proxy ctype) : supportedTypes (Proxy :: Proxy rest)
+
+-- | The class that helps us automatically get documentation
+--   for GET parameters.
+--
+-- Example of an instance:
+--
+-- > instance ToParam (QueryParam "capital" Bool) where
+-- >   toParam _ =
+-- >     DocQueryParam "capital"
+-- >                   ["true", "false"]
+-- >                   "Get the greeting message in uppercase (true) or not (false). Default is false."
+class ToParam t where
+  toParam :: Proxy t -> DocQueryParam
+
+-- | The class that helps us automatically get documentation
+--   for URL captures.
+--
+-- Example of an instance:
+--
+-- > instance ToCapture (Capture "name" Text) where
+-- >   toCapture _ = DocCapture "name" "name of the person to greet"
+class ToCapture c where
+  toCapture :: Proxy c -> DocCapture
+
+-- | Generate documentation in Markdown format for
+--   the given 'API'.
+markdown :: API -> String
+markdown api = unlines $
+       introsStr (api ^. apiIntros)
+    ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
+
+  where printEndpoint :: Endpoint -> Action -> [String]
+        printEndpoint endpoint action =
+          str :
+          "" :
+          notesStr (action ^. notes) ++
+          capturesStr (action ^. captures) ++
+          mxParamsStr (action ^. mxParams) ++
+          headersStr (action ^. headers) ++
+          paramsStr (action ^. params) ++
+          rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
+          responseStr (action ^. response) ++
+          []
+
+          where str = "## " ++ show (endpoint^.method)
+                    ++ " " ++ showPath (endpoint^.path)
+
+        introsStr :: [DocIntro] -> [String]
+        introsStr = concatMap introStr
+
+        introStr :: DocIntro -> [String]
+        introStr i =
+            ("#### " ++ i ^. introTitle) :
+            "" :
+            intersperse "" (i ^. introBody) ++
+            "" :
+            []
+
+        notesStr :: [DocNote] -> [String]
+        notesStr = concatMap noteStr
+
+        noteStr :: DocNote -> [String]
+        noteStr nt =
+            ("#### " ++ nt ^. noteTitle) :
+            "" :
+            intersperse "" (nt ^. noteBody) ++
+            "" :
+            []
+
+        capturesStr :: [DocCapture] -> [String]
+        capturesStr [] = []
+        capturesStr l =
+          "#### Captures:" :
+          "" :
+          map captureStr l ++
+          "" :
+          []
+
+        captureStr cap =
+          "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
+
+        mxParamsStr :: [(String, [DocQueryParam])] -> [String]
+        mxParamsStr [] = []
+        mxParamsStr l =
+          "#### Matrix Parameters:" :
+          "" :
+          map segmentStr l
+        segmentStr :: (String, [DocQueryParam]) -> String
+        segmentStr (segment, l) = unlines $
+          ("**" ++ segment ++ "**:") :
+          "" :
+          map paramStr l ++
+          "" :
+          []
+
+        headersStr :: [Text] -> [String]
+        headersStr [] = []
+        headersStr l = [""] ++ map headerStr l ++ [""]
+
+          where headerStr hname = "- This endpoint is sensitive to the value of the **"
+                               ++ unpack hname ++ "** HTTP header."
+
+        paramsStr :: [DocQueryParam] -> [String]
+        paramsStr [] = []
+        paramsStr l =
+          "#### GET Parameters:" :
+          "" :
+          map paramStr l ++
+          "" :
+          []
+
+        paramStr param = unlines $
+          ("- " ++ param ^. paramName) :
+          (if (not (null values) || param ^. paramKind /= Flag)
+            then ["     - **Values**: *" ++ intercalate ", " values ++ "*"]
+            else []) ++
+          ("     - **Description**: " ++ param ^. paramDesc) :
+          (if (param ^. paramKind == List)
+            then ["     - This parameter is a **list**. All GET parameters with the name "
+                  ++ param ^. paramName ++ "[] will forward their values in a list to the handler."]
+            else []) ++
+          (if (param ^. paramKind == Flag)
+            then ["     - This parameter is a **flag**. This means no value is expected to be associated to this parameter."]
+            else []) ++
+          []
+
+          where values = param ^. paramValues
+
+        rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String]
+        rqbodyStr [] [] = []
+        rqbodyStr types samples =
+            ["#### Request:", ""]
+            <> formatTypes types
+            <> concatMap formatBody samples
+
+        formatTypes [] = []
+        formatTypes ts = ["- Supported content types are:", ""]
+            <> map (\t -> "    - `" <> show t <> "`") ts
+            <> [""]
+
+        formatBody (m, b) =
+          "- Example: `" <> cs (show m) <> "`" :
+          contentStr m b
+
+        markdownForType mime_type =
+            case (M.mainType mime_type, M.subType mime_type) of
+                ("text", "html") -> "html"
+                ("application", "xml") -> "xml"
+                ("application", "json") -> "javascript"
+                ("application", "javascript") -> "javascript"
+                ("text", "css") -> "css"
+                (_, _) -> ""
+
+        contentStr mime_type body =
+          "" :
+          "```" <> markdownForType mime_type :
+          cs body :
+          "```" :
+          "" :
+          []
+
+        responseStr :: Response -> [String]
+        responseStr resp =
+          "#### Response:" :
+          "" :
+          ("- Status code " ++ show (resp ^. respStatus)) :
+          "" :
+          formatTypes (resp ^. respTypes) ++
+          bodies
+
+          where bodies = case resp ^. respBody of
+                  []        -> ["- No response body\n"]
+                  [("", t, r)] -> "- Response body as below." : contentStr t r
+                  xs        ->
+                    concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs
+
+-- * Instances
+
+-- | The generated docs for @a ':<|>' b@ just appends the docs
+--   for @a@ with the docs for @b@.
+instance (HasDocs layout1, HasDocs layout2)
+      => HasDocs (layout1 :<|> layout2) where
+
+  docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action)
+
+    where p1 :: Proxy layout1
+          p1 = Proxy
+
+          p2 :: Proxy layout2
+          p2 = Proxy
+
+-- | @"books" :> 'Capture' "isbn" Text@ will appear as
+-- @/books/:isbn@ in the docs.
+instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)
+      => HasDocs (Capture sym a :> sublayout) where
+
+  docsFor Proxy (endpoint, action) =
+    docsFor sublayoutP (endpoint', action')
+
+    where sublayoutP = Proxy :: Proxy sublayout
+          captureP = Proxy :: Proxy (Capture sym a)
+
+          action' = over captures (|> toCapture captureP) action
+          endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
+          symP = Proxy :: Proxy sym
+
+
+instance HasDocs Delete where
+  docsFor Proxy (endpoint, action) =
+    single endpoint' action'
+
+    where endpoint' = endpoint & method .~ DocDELETE
+
+          action' = action & response.respBody .~ []
+                           & response.respStatus .~ 204
+
+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
+    => HasDocs (Get cts a) where
+  docsFor Proxy (endpoint, action) =
+    single endpoint' action'
+
+    where endpoint' = endpoint & method .~ DocGET
+          action' = action & response.respBody .~ sampleByteStrings t p
+                           & response.respTypes .~ supportedTypes t
+          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 (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
+    => HasDocs (Post cts a) where
+  docsFor Proxy (endpoint, action) =
+    single endpoint' action'
+
+    where endpoint' = endpoint & method .~ DocPOST
+          action' = action & response.respBody .~ sampleByteStrings t p
+                           & response.respTypes .~ supportedTypes t
+                           & response.respStatus .~ 201
+          t = Proxy :: Proxy cts
+          p = Proxy :: Proxy a
+
+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
+    => HasDocs (Put cts a) where
+  docsFor Proxy (endpoint, action) =
+    single endpoint' action'
+
+    where endpoint' = endpoint & method .~ DocPUT
+          action' = action & response.respBody .~ sampleByteStrings t p
+                           & response.respTypes .~ supportedTypes t
+                           & response.respStatus .~ 200
+          t = Proxy :: Proxy cts
+          p = Proxy :: Proxy a
+
+instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
+      => HasDocs (QueryParam sym a :> sublayout) where
+
+  docsFor Proxy (endpoint, action) =
+    docsFor sublayoutP (endpoint, action')
+
+    where sublayoutP = Proxy :: Proxy sublayout
+          paramP = Proxy :: Proxy (QueryParam sym a)
+          action' = over params (|> toParam paramP) action
+
+instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout)
+      => HasDocs (QueryParams sym a :> sublayout) where
+
+  docsFor Proxy (endpoint, action) =
+    docsFor sublayoutP (endpoint, action')
+
+    where sublayoutP = Proxy :: Proxy sublayout
+          paramP = Proxy :: Proxy (QueryParams sym a)
+          action' = over params (|> toParam paramP) action
+
+
+instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout)
+      => HasDocs (QueryFlag sym :> sublayout) where
+
+  docsFor Proxy (endpoint, action) =
+    docsFor sublayoutP (endpoint, action')
+
+    where sublayoutP = Proxy :: Proxy sublayout
+          paramP = Proxy :: Proxy (QueryFlag sym)
+          action' = over params (|> toParam paramP) action
+
+
+instance (KnownSymbol sym, ToParam (MatrixParam sym a), HasDocs sublayout)
+      => HasDocs (MatrixParam sym a :> sublayout) where
+
+  docsFor Proxy (endpoint, action) =
+    docsFor sublayoutP (endpoint', action')
+
+    where sublayoutP = Proxy :: Proxy sublayout
+          paramP = Proxy :: Proxy (MatrixParam sym a)
+          segment = endpoint ^. (path._last)
+          segment' = action ^. (mxParams._last._1)
+          endpoint' = over (path._last) (\p -> p ++ ";" ++ symbolVal symP ++ "=<value>") endpoint
+
+          action' = if segment' /= segment
+                    -- This is the first matrix parameter for this segment, insert a new entry into the mxParams list
+                    then over mxParams (|> (segment, [toParam paramP])) action
+                    -- We've already inserted a matrix parameter for this segment, append to the existing list
+                    else action & mxParams._last._2 <>~ [toParam paramP]
+          symP = Proxy :: Proxy sym
+
+
+instance (KnownSymbol sym, {- ToParam (MatrixParams sym a), -} HasDocs sublayout)
+      => HasDocs (MatrixParams sym a :> sublayout) where
+
+  docsFor Proxy (endpoint, action) =
+    docsFor sublayoutP (endpoint', action)
+
+    where sublayoutP = Proxy :: Proxy sublayout
+          endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP ++ "=<value>"]) endpoint
+          symP = Proxy :: Proxy sym
+
+
+instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)
+      => HasDocs (MatrixFlag sym :> sublayout) where
+
+  docsFor Proxy (endpoint, action) =
+    docsFor sublayoutP (endpoint', action)
+
+    where sublayoutP = Proxy :: Proxy sublayout
+
+          endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint
+          symP = Proxy :: Proxy sym
+
+instance HasDocs Raw where
+  docsFor _proxy (endpoint, action) =
+    single endpoint action
+
+-- TODO: We use 'AllMimeRender' here because we need to be able to show the
+-- 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, SupportedTypes cts)
+      => HasDocs (ReqBody cts a :> sublayout) where
+
+  docsFor Proxy (endpoint, action) =
+    docsFor sublayoutP (endpoint, action')
+
+    where sublayoutP = Proxy :: Proxy sublayout
+          action' = action & rqbody .~ sampleByteString t p
+                           & rqtypes .~ supportedTypes t
+          t = Proxy :: Proxy cts
+          p = Proxy :: Proxy a
+
+instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where
+
+  docsFor Proxy (endpoint, action) =
+    docsFor sublayoutP (endpoint', action)
+
+    where sublayoutP = Proxy :: Proxy sublayout
+          endpoint' = endpoint & path <>~ [symbolVal pa]
+          pa = Proxy :: Proxy path
+
+{-
+
+-- | Serve your API's docs as markdown embedded in an html \<pre> tag.
+--
+-- > type MyApi = "users" :> Get [User]
+-- >         :<|> "docs   :> Raw
+-- >
+-- > apiProxy :: Proxy MyApi
+-- > apiProxy = Proxy
+-- >
+-- > server :: Server MyApi
+-- > server = listUsers
+-- >     :<|> serveDocumentation apiProxy
+serveDocumentation :: HasDocs api => Proxy api -> Server Raw
+serveDocumentation proxy _request respond =
+  respond $ responseLBS ok200 [] $ cs $ toHtml $ markdown $ docs proxy
+
+toHtml :: String -> String
+toHtml md =
+  "<html>" ++
+  "<body>" ++
+  "<pre>" ++
+  md ++
+  "</pre>" ++
+  "</body>" ++
+  "</html>"
+-}

servant-docs/test/Servant/DocsSpec.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE TypeSynonymInstances  #-}
+{-# OPTIONS_GHC -fno-warn-orphans  #-}
+module Servant.DocsSpec where
+
+import           Data.Aeson
+import           Data.Proxy
+import           Data.String.Conversions (cs)
+import           GHC.Generics
+import           Test.Hspec
+
+import           Servant.API
+import           Servant.Docs.Internal
+
+spec :: Spec
+spec = describe "Servant.Docs" $ do
+
+  describe "markdown" $ do
+    let md = markdown (docs (Proxy :: Proxy TestApi1))
+
+    it "mentions supported content-types" $ do
+      md `shouldContain` "application/json"
+      md `shouldContain` "text/plain;charset=utf-8"
+
+    it "mentions status codes" $ do
+      md `shouldContain` "Status code 200"
+      md `shouldContain` "Status code 201"
+
+    it "mentions methods" $ do
+      md `shouldContain` "POST"
+      md `shouldContain` "GET"
+
+    it "contains response samples" $ do
+      md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}"
+    it "contains request body samples" $ do
+      md `shouldContain` "17"
+-- * APIs
+
+data Datatype1 = Datatype1 { dt1field1 :: String
+                           , dt1field2 :: Int
+                           } deriving (Eq, Show, Generic)
+
+instance ToJSON Datatype1
+
+instance ToSample Datatype1 where
+  toSample = Just $ Datatype1 "field 1" 13
+
+instance ToSample String where
+  toSample = Just "a string"
+
+instance ToSample Int where
+  toSample = Just 17
+
+instance MimeRender PlainText Int where
+  mimeRender _ = cs . show
+
+
+type TestApi1 = Get '[JSON, PlainText] Int
+           :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1
+

servant-docs/test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-jquery/CHANGELOG.md

@@ -0,0 +1,12 @@
+0.3
+---
+* Extend `HeaderArg` to support more advanced HTTP header handling (https://github.com/haskell-servant/servant-jquery/pull/6)
+* Support content-type aware combinators (but require that endpoints support JSON)
+* Add support for Matrix params (https://github.com/haskell-servant/servant-jquery/pull/11)
+* Add functions that directly generate the Javascript code from the API type without having to manually pattern match on the result.
+
+0.2.2
+-----
+
+* Fix an issue where toplevel Raw endpoints would generate a JS function with no name (https://github.com/haskell-servant/servant-jquery/issues/2)
+* Replace dots by _ in paths (https://github.com/haskell-servant/servant-jquery/issues/1)

servant-jquery/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2014, Zalora South East Asia Pte Ltd
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Zalora South East Asia Pte Ltd nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

servant-jquery/README.md

@@ -0,0 +1,97 @@
+# servant-jquery
+
+[![Build Status](https://secure.travis-ci.org/haskell-servant/servant-jquery.svg)](http://travis-ci.org/haskell-servant/servant-jquery)
+[![Coverage Status](https://coveralls.io/repos/haskell-servant/servant-jquery/badge.svg)](https://coveralls.io/r/haskell-servant/servant-jquery)
+
+![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
+
+This library lets you derive automatically (JQuery based) Javascript functions that let you query each endpoint of a *servant* webservice.
+
+## Example
+
+Read more about the following example [here](https://github.com/haskell-servant/servant-jquery/tree/master/examples#examples).
+
+``` haskell
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+import Control.Concurrent.STM
+import Control.Monad.IO.Class
+import Data.Aeson
+import Data.Proxy
+import GHC.Generics
+import Network.Wai.Handler.Warp (run)
+import Servant
+import Servant.JQuery
+import System.FilePath
+
+-- * A simple Counter data type
+newtype Counter = Counter { value :: Int }
+  deriving (Generic, Show, Num)
+
+instance ToJSON Counter
+
+-- * Shared counter operations
+
+-- Creating a counter that starts from 0
+newCounter :: IO (TVar Counter)
+newCounter = newTVarIO 0
+
+-- Increasing the counter by 1
+counterPlusOne :: MonadIO m => TVar Counter -> m Counter
+counterPlusOne counter = liftIO . atomically $ do
+  oldValue <- readTVar counter
+  let newValue = oldValue + 1
+  writeTVar counter newValue
+  return newValue
+
+currentValue :: MonadIO m => TVar Counter -> m Counter
+currentValue counter = liftIO $ readTVarIO counter
+
+-- * Our API type
+type TestApi = "counter" :> Post Counter -- endpoint for increasing the counter
+          :<|> "counter" :> Get  Counter -- endpoint to get the current value
+          :<|> Raw                       -- used for serving static files 
+
+testApi :: Proxy TestApi
+testApi = Proxy
+
+-- * Server-side handler
+
+-- where our static files reside
+www :: FilePath
+www = "examples/www"
+
+-- defining handlers
+server :: TVar Counter -> Server TestApi
+server counter = counterPlusOne counter     -- (+1) on the TVar
+            :<|> currentValue counter       -- read the TVar
+            :<|> serveDirectory www         -- serve static files
+
+runServer :: TVar Counter -- ^ shared variable for the counter
+          -> Int          -- ^ port the server should listen on
+          -> IO ()
+runServer var port = run port (serve testApi $ server var)
+
+-- * Generating the JQuery code
+
+incCounterJS :<|> currentValueJS :<|> _ = jquery testApi
+
+writeJS :: FilePath -> [AjaxReq] -> IO ()
+writeJS fp functions = writeFile fp $
+  concatMap generateJS functions
+
+main :: IO ()
+main = do
+  -- write the JS code to www/api.js at startup
+  writeJS (www </> "api.js")
+          [ incCounterJS, currentValueJS ]
+
+  -- setup a shared counter
+  cnt <- newCounter
+
+  -- listen to requests on port 8080
+  runServer cnt 8080
+```

servant-jquery/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

servant-jquery/TODO.md

@@ -0,0 +1 @@
+- Investigate the best way to offer cross-origin requests

servant-jquery/docs.sh

@@ -0,0 +1,52 @@
+SERVANT_DIR=/tmp/servant-jquery-gh-pages
+
+# Make a temporary clone
+
+rm -rf $SERVANT_DIR
+
+git clone . $SERVANT_DIR
+
+cd $SERVANT_DIR
+
+# Make sure to pull the latest
+
+git remote add haskell-servant git@github.com:haskell-servant/servant-jquery.git
+
+git fetch haskell-servant
+
+git reset --hard haskell-servant/gh-pages
+
+# Clear everything away
+
+git rm -rf $SERVANT_DIR/*
+
+# Switch back and build the haddocks
+
+cd -
+
+cabal configure --builddir=$SERVANT_DIR
+
+cabal haddock --hoogle --hyperlink-source --html-location='https://hackage.haskell.org/package/$pkg-$version/docs' --builddir=$SERVANT_DIR
+
+commit_hash=$(git rev-parse HEAD)
+
+# Move the HTML docs to the root
+
+cd $SERVANT_DIR
+
+rm *
+rm -rf build
+mv doc/html/servant-jquery/* .
+rm -r doc/
+
+# Add everything
+
+git add .
+
+git commit -m "Built from $commit_hash"
+
+# Push to update the pages
+
+git push haskell-servant HEAD:gh-pages
+
+rm -rf $SERVANT_DIR

servant-jquery/examples/README.md

@@ -0,0 +1,17 @@
+# Examples
+
+## counter
+
+This example demonstrates a *servant* server that holds a shared variable (using a `TVar`) and exposes an endpoint for reading its current value and another one for increasing its current value by 1.
+
+In addition to that, it shows how you can generate the jquery-powered javascript functions corresponding to each endpoint, i.e one for reading the current value and one for increasing the value, and integrates all of that in a very simple HTML page. All these static files are served using the `serveDirectory` function from *servant*.
+
+To see this all in action, simply run:
+
+``` bash
+$ cabal run counter
+```
+
+And point your browser to [http://localhost:8080/index.html](http://localhost:8080/index.html).
+
+Copies of the generated javascript functions and of the generated docs are included in `www/api.js` and `counter.md` respectively.

servant-jquery/examples/counter.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+import Control.Concurrent.STM
+import Control.Monad.IO.Class
+import Data.Aeson
+import Data.Proxy
+import GHC.Generics
+import Network.Wai.Handler.Warp (run)
+import Servant
+import Servant.JQuery
+import System.FilePath
+
+-- * A simple Counter data type
+newtype Counter = Counter { value :: Int }
+  deriving (Generic, Show, Num)
+
+instance ToJSON Counter
+
+-- * Shared counter operations
+
+-- Creating a counter that starts from 0
+newCounter :: IO (TVar Counter)
+newCounter = newTVarIO 0
+
+-- Increasing the counter by 1
+counterPlusOne :: MonadIO m => TVar Counter -> m Counter
+counterPlusOne counter = liftIO . atomically $ do
+  oldValue <- readTVar counter
+  let newValue = oldValue + 1
+  writeTVar counter newValue
+  return newValue
+
+currentValue :: MonadIO m => TVar Counter -> m Counter
+currentValue counter = liftIO $ readTVarIO counter
+
+-- * Our API type
+type TestApi = "counter" :> Post Counter -- endpoint for increasing the counter
+          :<|> "counter" :> Get  Counter -- endpoint to get the current value
+          :<|> Raw                       -- used for serving static files 
+
+testApi :: Proxy TestApi
+testApi = Proxy
+
+-- * Server-side handler
+
+-- where our static files reside
+www :: FilePath
+www = "examples/www"
+
+-- defining handlers
+server :: TVar Counter -> Server TestApi
+server counter = counterPlusOne counter     -- (+1) on the TVar
+            :<|> currentValue counter       -- read the TVar
+            :<|> serveDirectory www         -- serve static files
+
+runServer :: TVar Counter -- ^ shared variable for the counter
+          -> Int          -- ^ port the server should listen on
+          -> IO ()
+runServer var port = run port (serve testApi $ server var)
+
+-- * Generating the JQuery code
+
+incCounterJS :<|> currentValueJS :<|> _ = jquery testApi
+
+writeJS :: FilePath -> [AjaxReq] -> IO ()
+writeJS fp functions = writeFile fp $
+  concatMap generateJS functions
+
+main :: IO ()
+main = do
+  -- write the JS code to www/api.js at startup
+  writeJS (www </> "api.js")
+          [ incCounterJS, currentValueJS ]
+
+  -- setup a shared counter
+  cnt <- newCounter
+
+  -- listen to requests on port 8080
+  runServer cnt 8080

servant-jquery/examples/counter.md

@@ -0,0 +1,39 @@
+POST /counter
+-------------
+
+**Response**: 
+
+ - Status code 201
+ - Response body as below.
+
+``` javascript
+{"value":0}
+```
+
+GET /doc
+--------
+
+**Response**: 
+
+ - Status code 200
+ - No response body
+
+GET /counter
+------------
+
+**Response**: 
+
+ - Status code 200
+ - Response body as below.
+
+``` javascript
+{"value":0}
+```
+
+GET /
+-----
+
+**Response**: 
+
+ - Status code 200
+ - No response body

servant-jquery/examples/www/api.js

@@ -0,0 +1,20 @@
+
+function postcounter(onSuccess, onError)
+{
+  $.ajax(
+    { url: '/counter'
+    , success: onSuccess
+    , error: onError
+    , type: 'POST'
+    });
+}
+
+function getcounter(onSuccess, onError)
+{
+  $.ajax(
+    { url: '/counter'
+    , success: onSuccess
+    , error: onError
+    , type: 'GET'
+    });
+}

servant-jquery/examples/www/index.html

@@ -0,0 +1,40 @@
+<html>
+<head>
+  <title>Servant: counter</title>
+  <style>
+  body { text-align: center; }
+  #counter { color: green; }
+  #inc { margin: 0px 20px; background-color: green; color: white; }
+  </style>
+</head>
+<body>
+<span id="counter">Counter: 0</span>
+<button id="inc">Increase</button>
+or <a href="/doc">view the docs</a>
+
+<script src="/jquery.min.js" type="text/javascript"></script>
+<script src="/api.js" type="text/javascript"></script>
+<script type="text/javascript">
+$(document).ready(function() {
+  // we get the current value stored by the server when the page is loaded
+  getcounter(updateCounter, alert);
+
+  // we update the value every 1sec, in the same way
+  window.setInterval(function() {
+    getcounter(updateCounter, alert);
+  }, 1000);
+});
+
+function updateCounter(response)
+{
+  $('#counter').html('Counter: ' + response.value);
+}
+
+// when the button is clicked, ask the server to increase
+// the value by one
+$('#inc').click(function() {
+  postcounter(updateCounter, alert);
+});
+</script>
+</body>
+</html>

servant-jquery/servant-jquery.cabal

@@ -0,0 +1,78 @@
+name:                servant-jquery
+version:             0.2.2
+synopsis:            Automatically derive (jquery) javascript functions to query servant webservices
+description:
+  Automatically derive jquery-based javascript functions to query servant webservices.
+  .
+  Example <https://github.com/haskell-servant/servant-jquery/blob/master/examples/counter.hs here> that serves the generated javascript to a webpage that lets you
+  trigger webservice calls.
+license:             BSD3
+license-file:        LICENSE
+author:              Alp Mestanogullari
+maintainer:          alpmestan@gmail.com
+copyright:           2014 Alp Mestanogullari
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+homepage:            http://haskell-servant.github.io/
+Bug-reports:         http://github.com/haskell-servant/servant-jquery/issues
+extra-source-files:
+  CHANGELOG.md
+  README.md
+source-repository head
+  type: git
+  location: http://github.com/haskell-servant/servant-jquery.git
+
+flag example
+  description: Build the example too
+  manual: True
+  default: False
+
+library
+  exposed-modules:     Servant.JQuery
+  other-modules:       Servant.JQuery.Internal
+  build-depends:       base >=4.5 && <5
+                     , charset
+                     , lens >= 4
+                     , servant >= 0.2.2
+                     , text
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  ghc-options:         -Wall
+
+executable counter
+  main-is: counter.hs
+  ghc-options: -O2 -Wall
+  hs-source-dirs: examples
+
+  if flag(example)
+    buildable: True
+  else
+    buildable: False
+
+  build-depends:
+      aeson
+    , base
+    , filepath
+    , servant >= 0.2.2
+    , servant-server >= 0.2.3
+    , servant-jquery >= 0.2.2
+    , stm
+    , transformers
+    , warp
+  default-language: Haskell2010
+
+test-suite spec
+  type:              exitcode-stdio-1.0
+  hs-source-dirs:    test
+  ghc-options:       -Wall
+  main-is:           Spec.hs
+  build-depends:
+      base == 4.*
+    , lens
+    , servant-jquery
+    , servant
+    , hspec >= 2.0
+    , hspec-expectations
+    , language-ecmascript >= 0.16
+  default-language: Haskell2010

servant-jquery/src/Servant/JQuery.hs

@@ -0,0 +1,117 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Servant.JQuery
+-- Copyright   :  (C) 2014 Alp Mestanogullari
+-- License     :  BSD3
+-- Maintainer  :  Alp Mestanogullari <alpmestan@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+module Servant.JQuery
+  ( jquery
+  , generateJS
+  , jsForAPI
+  , printJS
+  , module Servant.JQuery.Internal
+  , GenerateCode(..)
+  ) where
+
+import Control.Lens
+import Data.List
+import Data.Monoid
+import Data.Proxy
+import Servant.API
+import Servant.JQuery.Internal
+
+jquery :: HasJQ (Canonicalize layout) => Proxy layout -> JQ layout
+jquery p = jqueryFor (canonicalize p) defReq
+
+-- js codegen
+generateJS :: AjaxReq -> String
+generateJS req = "\n" <>
+    "function " <> fname <> "(" <> argsStr <> ")\n"
+ <> "{\n"
+ <> "  $.ajax(\n"
+ <> "    { url: " <> url <> "\n"
+ <> "    , success: onSuccess\n"
+ <> dataBody
+ <> reqheaders
+ <> "    , error: onError\n"
+ <> "    , type: '" <> method <> "'\n"
+ <> "    });\n"
+ <> "}\n"
+
+  where argsStr = intercalate ", " args
+        args = captures
+            ++ map (view argName) queryparams
+            ++ body
+            ++ map (toValidFunctionName . (<>) "header" . headerArgName) hs
+            ++ ["onSuccess", "onError"]
+
+        captures = map captureArg
+                 . filter isCapture
+                 $ req ^. reqUrl.path
+
+        hs = req ^. reqHeaders
+
+        queryparams = req ^.. reqUrl.queryStr.traverse
+
+        body = if req ^. reqBody
+                 then ["body"]
+                 else []
+
+        dataBody =
+          if req ^. reqBody
+            then "\n    , data: JSON.stringify(body)\n"
+            else ""
+
+        reqheaders =
+          if null hs
+            then ""
+            else "\n    , headers: { " ++ headersStr ++ " }\n"
+
+          where headersStr = intercalate ", " $ map headerStr hs
+                headerStr header = "\"" ++
+                  headerArgName header ++
+                  "\": " ++ show header
+
+        fname = req ^. funcName
+        method = req ^. reqMethod
+        url = if url' == "'" then "'/'" else url'
+        url' = "'"
+           ++ urlArgs
+           ++ queryArgs
+
+        urlArgs = jsSegments
+                $ req ^.. reqUrl.path.traverse
+
+        queryArgs = if null queryparams
+                      then ""
+                      else " + '?" ++ jsParams queryparams
+
+printJS :: AjaxReq -> IO ()
+printJS = putStrLn . generateJS
+
+-- | Utility class used by 'jsForAPI' which will
+--   directly hand you all the Javascript code
+--   instead of handing you a ':<|>'-separated list
+--   of 'AjaxReq' like 'jquery' and then having to
+--   use 'generateJS' on each 'AjaxReq'.
+class GenerateCode reqs where
+  jsFor :: reqs -> String
+
+instance GenerateCode AjaxReq where
+  jsFor = generateJS
+
+instance GenerateCode rest => GenerateCode (AjaxReq :<|> rest) where
+  jsFor (req :<|> rest) = jsFor req ++ jsFor rest
+
+-- | Directly generate all the javascript functions for your API
+--   from a 'Proxy' for your API type. You can then write it to
+--   a file or integrate it in a page, for example.
+jsForAPI :: (HasJQ (Canonicalize api), GenerateCode (JQ api))
+         => Proxy api -> String
+jsForAPI p = jsFor (jquery p)

servant-jquery/src/Servant/JQuery/Internal.hs

@@ -0,0 +1,339 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Servant.JQuery.Internal where
+
+import Control.Applicative
+import Control.Lens
+import Data.Char (toLower)
+import qualified Data.CharSet as Set
+import qualified Data.CharSet.Unicode.Category as Set
+import Data.List
+import Data.Monoid
+import Data.Proxy
+import qualified Data.Text as T
+import GHC.Exts (Constraint)
+import GHC.TypeLits
+import Servant.API
+
+type Arg = String
+
+data Segment = Segment { _segment :: SegmentType, _matrix :: [MatrixArg] }
+  deriving (Eq, Show)
+
+data SegmentType = Static String  -- ^ a static path segment. like "/foo"
+                 | Cap Arg        -- ^ a capture. like "/:userid"
+  deriving (Eq, Show)
+
+type Path = [Segment]
+
+data ArgType =
+    Normal
+  | Flag
+  | List
+  deriving (Eq, Show)
+
+data QueryArg = QueryArg
+  { _argName :: Arg
+  , _argType :: ArgType
+  } deriving (Eq, Show)
+
+data HeaderArg = HeaderArg
+    { headerArgName :: String
+    }
+  | ReplaceHeaderArg
+    { headerArgName :: String
+    , headerPattern :: String
+    } deriving (Eq)
+
+instance Show HeaderArg where
+    show (HeaderArg n)          = toValidFunctionName ("header" <> n)
+    show (ReplaceHeaderArg n p)
+        | pn `isPrefixOf` p = pv <> " + \"" <> rp <> "\""
+        | pn `isSuffixOf` p = "\"" <> rp <> "\" + " <> pv
+        | pn `isInfixOf` p  = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p)
+                                   <> "\""
+        | otherwise         = p
+      where
+        pv = toValidFunctionName ("header" <> n)
+        pn = "{" <> n <> "}"
+        rp = replace pn "" p
+        -- Use replace method from Data.Text
+        replace old new = T.unpack .
+            T.replace (T.pack old) (T.pack new) .
+            T.pack
+
+-- | Attempts to reduce the function name provided to that allowed by JS.
+-- https://mathiasbynens.be/notes/javascript-identifiers
+-- Couldn't work out how to handle zero-width characters.
+-- @TODO: specify better default function name, or throw error?
+toValidFunctionName :: String -> String
+toValidFunctionName (x:xs) = [setFirstChar x] <> filter remainder xs
+  where
+    setFirstChar c = if firstChar c
+        then c
+        else '_'
+    firstChar c = (prefixOK c) || (or . map (Set.member c) $ firstLetterOK)
+    remainder c = (prefixOK c) || (or . map (Set.member c) $ remainderOK)
+    -- Valid prefixes
+    prefixOK c = c `elem` ['$','_']
+    -- Unicode character sets
+    firstLetterOK = [ Set.lowercaseLetter
+                    , Set.uppercaseLetter
+                    , Set.titlecaseLetter
+                    , Set.modifierLetter
+                    , Set.otherLetter
+                    , Set.letterNumber ]
+    remainderOK   = firstLetterOK <> [ Set.nonSpacingMark
+                                     , Set.spacingCombiningMark
+                                     , Set.decimalNumber
+                                     , Set.connectorPunctuation ]
+toValidFunctionName [] = "_"
+
+type MatrixArg = QueryArg
+
+data Url = Url
+  { _path     :: Path
+  , _queryStr :: [QueryArg]
+  } deriving (Eq, Show)
+
+defUrl :: Url
+defUrl = Url [] []
+
+type FunctionName = String
+type Method = String
+
+data AjaxReq = AjaxReq
+  { _reqUrl     :: Url
+  , _reqMethod  :: Method
+  , _reqHeaders :: [HeaderArg]
+  , _reqBody    :: Bool
+  , _funcName   :: FunctionName
+  } deriving (Eq, Show)
+
+makeLenses ''QueryArg
+makeLenses ''Segment
+makeLenses ''Url
+makeLenses ''AjaxReq
+
+isCapture :: Segment -> Bool
+isCapture (Segment (Cap _) _) = True
+isCapture                  _  = False
+
+hasMatrixArgs :: Segment -> Bool
+hasMatrixArgs (Segment _ (_:_)) = True
+hasMatrixArgs                _  = False
+
+hasArgs :: Segment -> Bool
+hasArgs s = isCapture s || hasMatrixArgs s
+
+matrixArgs :: Segment -> [MatrixArg]
+matrixArgs (Segment _ ms) = ms
+
+captureArg :: Segment -> Arg
+captureArg (Segment (Cap s) _) = s
+captureArg                  _  = error "captureArg called on non capture"
+
+jsSegments :: [Segment] -> String
+jsSegments []  = ""
+jsSegments [x] = "/" ++ segmentToStr x False
+jsSegments (x:xs) = "/" ++ segmentToStr x True ++ jsSegments xs
+
+segmentToStr :: Segment -> Bool -> String
+segmentToStr (Segment st ms) notTheEnd =
+  segmentTypeToStr st ++ jsMParams ms ++ if notTheEnd then "" else "'"
+
+segmentTypeToStr :: SegmentType -> String
+segmentTypeToStr (Static s) = s
+segmentTypeToStr (Cap s)    = "' + encodeURIComponent(" ++ s ++ ") + '"
+
+jsGParams :: String -> [QueryArg] -> String
+jsGParams _ []  = ""
+jsGParams _ [x] = paramToStr x False
+jsGParams s (x:xs) = paramToStr x True ++ s ++ jsGParams s xs
+
+jsParams :: [QueryArg] -> String
+jsParams = jsGParams "&"
+
+jsMParams :: [MatrixArg] -> String
+jsMParams [] = ""
+jsMParams xs = ";" ++ jsGParams ";" xs
+
+paramToStr :: QueryArg -> Bool -> String
+paramToStr qarg notTheEnd =
+  case qarg ^. argType of
+    Normal -> name
+           ++ "=' + encodeURIComponent("
+           ++ name
+           ++ if notTheEnd then ") + '" else ")"
+
+    Flag   -> name ++ "="
+
+    List   -> name
+           ++ "[]=' + encodeURIComponent("
+           ++ name
+           ++ if notTheEnd then ") + '" else ")"
+
+  where name = qarg ^. argName
+
+defReq :: AjaxReq
+defReq = AjaxReq defUrl "GET" [] False ""
+
+type family Elem (a :: *) (ls::[*]) :: Constraint where
+  Elem a '[] = 'False ~ 'True
+  Elem a (a ': list) = ()
+  Elem a (b ': list) = Elem a list
+
+class HasJQ (layout :: *) where
+  type JQ' layout :: *
+  jqueryFor :: Proxy layout -> AjaxReq -> JQ' layout
+
+type JQ layout = JQ' (Canonicalize layout)
+
+instance (HasJQ a, HasJQ b)
+      => HasJQ (a :<|> b) where
+  type JQ' (a :<|> b) = JQ' a :<|> JQ' b
+
+  jqueryFor Proxy req =
+         jqueryFor (Proxy :: Proxy a) req
+    :<|> jqueryFor (Proxy :: Proxy b) req
+
+instance (KnownSymbol sym, HasJQ sublayout)
+      => HasJQ (Capture sym a :> sublayout) where
+  type JQ' (Capture sym a :> sublayout) = JQ' sublayout
+
+  jqueryFor Proxy req =
+    jqueryFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.path <>~ [Segment (Cap str) []]
+
+    where str = symbolVal (Proxy :: Proxy sym)
+
+instance HasJQ Delete where
+  type JQ' Delete = AjaxReq
+
+  jqueryFor Proxy req =
+    req & funcName  %~ ("delete" <>)
+        & reqMethod .~ "DELETE"
+
+instance Elem JSON list => HasJQ (Get list a) where
+  type JQ' (Get list a) = AjaxReq
+
+  jqueryFor Proxy req =
+    req & funcName  %~ ("get" <>)
+        & reqMethod .~ "GET"
+
+instance (KnownSymbol sym, HasJQ sublayout)
+      => HasJQ (Header sym a :> sublayout) where
+  type JQ' (Header sym a :> sublayout) = JQ' sublayout
+
+  jqueryFor Proxy req =
+    jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname])
+
+    where hname = symbolVal (Proxy :: Proxy sym)
+          subP = Proxy :: Proxy sublayout
+
+instance Elem JSON list => HasJQ (Post list a) where
+  type JQ' (Post list a) = AjaxReq
+
+  jqueryFor Proxy req =
+    req & funcName  %~ ("post" <>)
+        & reqMethod .~ "POST"
+
+instance Elem JSON list => HasJQ (Put list a) where
+  type JQ' (Put list a) = AjaxReq
+
+  jqueryFor Proxy req =
+    req & funcName  %~ ("put" <>)
+        & reqMethod .~ "PUT"
+
+instance (KnownSymbol sym, HasJQ sublayout)
+      => HasJQ (QueryParam sym a :> sublayout) where
+  type JQ' (QueryParam sym a :> sublayout) = JQ' sublayout
+
+  jqueryFor Proxy req =
+    jqueryFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.queryStr <>~ [QueryArg str Normal]
+
+    where str = symbolVal (Proxy :: Proxy sym)
+
+instance (KnownSymbol sym, HasJQ sublayout)
+      => HasJQ (QueryParams sym a :> sublayout) where
+  type JQ' (QueryParams sym a :> sublayout) = JQ' sublayout
+
+  jqueryFor Proxy req =
+    jqueryFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.queryStr <>~ [QueryArg str List]
+
+    where str = symbolVal (Proxy :: Proxy sym)
+
+instance (KnownSymbol sym, HasJQ sublayout)
+      => HasJQ (QueryFlag sym :> sublayout) where
+  type JQ' (QueryFlag sym :> sublayout) = JQ' sublayout
+
+  jqueryFor Proxy req =
+    jqueryFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.queryStr <>~ [QueryArg str Flag]
+
+    where str = symbolVal (Proxy :: Proxy sym)
+
+instance (KnownSymbol sym, HasJQ sublayout)
+      => HasJQ (MatrixParam sym a :> sublayout) where
+  type JQ' (MatrixParam sym a :> sublayout) = JQ' sublayout
+
+  jqueryFor Proxy req =
+    jqueryFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.path._last.matrix <>~ [QueryArg strArg Normal]
+
+    where str = symbolVal (Proxy :: Proxy sym)
+          strArg = str ++ "Value"
+
+instance (KnownSymbol sym, HasJQ sublayout)
+      => HasJQ (MatrixParams sym a :> sublayout) where
+  type JQ' (MatrixParams sym a :> sublayout) = JQ' sublayout
+
+  jqueryFor Proxy req =
+    jqueryFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.path._last.matrix  <>~ [QueryArg str List]
+
+    where str = symbolVal (Proxy :: Proxy sym)
+
+instance (KnownSymbol sym, HasJQ sublayout)
+      => HasJQ (MatrixFlag sym :> sublayout) where
+  type JQ' (MatrixFlag sym :> sublayout) = JQ' sublayout
+
+  jqueryFor Proxy req =
+    jqueryFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.path._last.matrix  <>~ [QueryArg str Flag]
+
+    where str = symbolVal (Proxy :: Proxy sym)
+
+instance HasJQ Raw where
+  type JQ' Raw = Method -> AjaxReq
+
+  jqueryFor Proxy req method =
+    req & funcName %~ ((toLower <$> method) <>)
+        & reqMethod .~ method
+
+instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout) where
+  type JQ' (ReqBody list a :> sublayout) = JQ' sublayout
+
+  jqueryFor Proxy req =
+    jqueryFor (Proxy :: Proxy sublayout) $
+      req & reqBody .~ True
+
+instance (KnownSymbol path, HasJQ sublayout)
+      => HasJQ (path :> sublayout) where
+  type JQ' (path :> sublayout) = JQ' sublayout
+
+  jqueryFor Proxy req =
+    jqueryFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.path <>~ [Segment (Static str) []]
+          & funcName %~ (str <>)
+
+    where str = map (\c -> if c == '.' then '_' else c) $ symbolVal (Proxy :: Proxy path)

servant-jquery/test/Servant/JQuerySpec.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE QuasiQuotes         #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Servant.JQuerySpec where
+
+import Data.Either (isRight)
+import Data.Proxy
+import Language.ECMAScript3.Parser (parseFromString)
+import Test.Hspec
+
+import Servant.API
+import Servant.JQuery
+import Servant.JQuerySpec.CustomHeaders
+
+type TestAPI = "simple" :> ReqBody '[JSON,FormUrlEncoded] String :> Post '[JSON] Bool
+          :<|> "has.extension" :> Get '[FormUrlEncoded,JSON] Bool
+
+type TopLevelRawAPI = "something" :> Get '[JSON] Int
+                  :<|> Raw
+
+type HeaderHandlingAPI = "something" :> Header "Foo" String
+                                     :> Get '[JSON] Int
+
+type CustomAuthAPI = "something" :> Authorization "Basic" String
+                                 :> Get '[JSON] Int
+
+type CustomHeaderAPI = "something" :> MyLovelyHorse String
+                                   :> Get '[JSON] Int
+
+type CustomHeaderAPI2 = "something" :> WhatsForDinner String
+                                    :> Get '[JSON] Int
+
+headerHandlingProxy :: Proxy HeaderHandlingAPI
+headerHandlingProxy = Proxy
+
+customAuthProxy :: Proxy CustomAuthAPI
+customAuthProxy = Proxy
+
+customHeaderProxy :: Proxy CustomHeaderAPI
+customHeaderProxy = Proxy
+
+customHeaderProxy2 :: Proxy CustomHeaderAPI2
+customHeaderProxy2 = Proxy
+
+spec :: Spec
+spec = describe "Servant.JQuery"
+    generateJSSpec
+
+generateJSSpec :: Spec
+generateJSSpec = describe "generateJS" $ do
+    it "should generate valid javascript" $ do
+        let (postSimple :<|> getHasExtension ) = jquery (Proxy :: Proxy TestAPI)
+        parseFromString (generateJS postSimple) `shouldSatisfy` isRight
+        parseFromString (generateJS getHasExtension) `shouldSatisfy` isRight
+        print $ generateJS getHasExtension
+
+    it "should use non-empty function names" $ do
+        let (_ :<|> topLevel) = jquery (Proxy :: Proxy TopLevelRawAPI)
+        print $ generateJS $ topLevel "GET"
+        parseFromString (generateJS $ topLevel "GET") `shouldSatisfy` isRight
+
+    it "should handle simple HTTP headers" $ do
+        let jsText = generateJS $ jquery headerHandlingProxy
+        print jsText
+        parseFromString jsText `shouldSatisfy` isRight
+        jsText `shouldContain` "headerFoo"
+        jsText `shouldContain` "headers: { \"Foo\": headerFoo }\n"
+
+    it "should handle complex HTTP headers" $ do
+        let jsText = generateJS $ jquery customAuthProxy
+        print jsText
+        parseFromString jsText `shouldSatisfy` isRight
+        jsText `shouldContain` "headerAuthorization"
+        jsText `shouldContain` "headers: { \"Authorization\": \"Basic \" + headerAuthorization }\n"
+
+    it "should handle complex, custom HTTP headers" $ do
+        let jsText = generateJS $ jquery customHeaderProxy
+        print jsText
+        parseFromString jsText `shouldSatisfy` isRight
+        jsText `shouldContain` "headerXMyLovelyHorse"
+        jsText `shouldContain` "headers: { \"X-MyLovelyHorse\": \"I am good friends with \" + headerXMyLovelyHorse }\n"
+
+    it "should handle complex, custom HTTP headers (template replacement)" $ do
+        let jsText = generateJS $ jquery customHeaderProxy2
+        print jsText
+        parseFromString jsText `shouldSatisfy` isRight
+        jsText `shouldContain` "headerXWhatsForDinner"
+        jsText `shouldContain` "headers: { \"X-WhatsForDinner\": \"I would like \" + headerXWhatsForDinner + \" with a cherry on top.\" }\n"
+
+    it "can generate the whole javascript code string at once with jsForAPI" $ do
+        let jsStr = jsForAPI (Proxy :: Proxy TestAPI)
+        parseFromString jsStr `shouldSatisfy` isRight

servant-jquery/test/Servant/JQuerySpec/CustomHeaders.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE KindSignatures      #-}
+{-# LANGUAGE PolyKinds           #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Servant.JQuerySpec.CustomHeaders where
+
+import Control.Lens
+import Data.Monoid
+import Data.Proxy
+import GHC.TypeLits
+import Servant.API
+import Servant.JQuery
+
+-- | This is a hypothetical combinator that fetches an Authorization header.
+-- The symbol in the header denotes what kind of authentication we are
+-- using -- Basic, Digest, whatever.
+data Authorization (sym :: Symbol) a
+
+instance (KnownSymbol sym, HasJQ sublayout)
+    => HasJQ (Authorization sym a :> sublayout) where
+    type JQ' (Authorization sym a :> sublayout) = JQ' sublayout
+
+    jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
+        req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $
+                               tokenType (symbolVal (Proxy :: Proxy sym)) ]
+      where
+        tokenType t = t <> " {Authorization}"
+
+-- | This is a combinator that fetches an X-MyLovelyHorse header.
+data MyLovelyHorse a
+
+instance (HasJQ sublayout)
+    => HasJQ (MyLovelyHorse a :> sublayout) where
+    type JQ' (MyLovelyHorse a :> sublayout) = JQ' sublayout
+
+    jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
+        req & reqHeaders <>~ [ ReplaceHeaderArg "X-MyLovelyHorse" tpl ]
+      where
+        tpl = "I am good friends with {X-MyLovelyHorse}"
+
+-- | This is a combinator that fetches an X-WhatsForDinner header.
+data WhatsForDinner a
+
+instance (HasJQ sublayout)
+    => HasJQ (WhatsForDinner a :> sublayout) where
+    type JQ' (WhatsForDinner a :> sublayout) = JQ' sublayout
+
+    jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
+        req & reqHeaders <>~ [ ReplaceHeaderArg "X-WhatsForDinner" tpl ]
+      where
+        tpl = "I would like {X-WhatsForDinner} with a cherry on top."

servant-jquery/test/Spec.hs

@@ -0,0 +1,2 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+

servant-server/CHANGELOG.md

@@ -0,0 +1,26 @@
+0.3
+---
+* Add a `RouteMismatch` constructor for arbitrary HTTP response codes (https://github.com/haskell-servant/servant-server/pull/22)
+* Add support for the `Patch` combinator
+* Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3*
+* Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29)
+* Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21)
+* Canonicalize API types before generating the handler types with `Server`
+* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)
+* Add server support for response headers
+
+0.2.4
+-----
+* Added support for matrix parameters, see e.g. http://www.w3.org/DesignIssues/MatrixURIs.html
+* Add support for serializing based on Accept header
+  (https://github.com/haskell-servant/servant-server/issues/9)
+* Ignore trailing slashes
+  (https://github.com/haskell-servant/servant-server/issues/5)
+
+
+0.2.3
+-----
+
+* Fix consuming request body issue
+  (https://github.com/haskell-servant/servant/issues/3)
+* Make code sample in Servant.Server complete

servant-server/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2014, Zalora South East Asia Pte Ltd
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Zalora South East Asia Pte Ltd nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

servant-server/README.md

@@ -0,0 +1,20 @@
+# servant-server
+
+[![Build Status](https://secure.travis-ci.org/haskell-servant/servant-server.svg)](http://travis-ci.org/haskell-servant/servant-server)
+[![Coverage Status](https://coveralls.io/repos/haskell-servant/servant-server/badge.svg)](https://coveralls.io/r/haskell-servant/servant-server)
+
+![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
+
+This library lets you *implement* an HTTP server with handlers for each endpoint of a servant API, handling most of the boilerplate for you.
+
+## Getting started
+
+We've written a [Getting Started](http://haskell-servant.github.io/getting-started/) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples.
+
+## Repositories and Haddocks
+
+- The core [servant](http://github.com/haskell-servant) package - [docs](http://hackage.haskell.org/package/servant)
+- Implementing an HTTP server for a webservice API with [servant-server](http://github.com/haskell-servant/servant-server) - [docs](http://hackage.haskell.org/package/servant-server)
+- (Haskell) client-side function generation with [servant-client](http://github.com/haskell-servant/servant-client) - [docs](http://hackage.haskell.org/package/servant-client)
+- (Javascript) client-side function generation with [servant-jquery](http://github.com/haskell-servant/servant-jquery) - [docs](http://hackage.haskell.org/package/servant-jquery)
+- API docs generation with [servant-docs](http://github.com/haskell-servant/servant-docs) - [docs](http://hackage.haskell.org/package/servant-docs)

servant-server/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

servant-server/default.nix

@@ -0,0 +1,15 @@
+{ pkgs ? import <nixpkgs> { config.allowUnfree = true; }
+, src ?  builtins.filterSource (path: type:
+    type != "unknown" &&
+    baseNameOf path != ".git" &&
+    baseNameOf path != "result" &&
+    baseNameOf path != "dist") ./.
+, servant ? import ../servant {}
+}:
+pkgs.haskellPackages.buildLocalCabalWithArgs {
+  name = "servant-server";
+  inherit src;
+  args = {
+      inherit servant;
+  };
+}

servant-server/example/README.md

@@ -0,0 +1,2 @@
+- `greet.hs` shows how to write a simple webservice, run it, query it with automatically-derived haskell functions and print the (generated) markdown documentation for the API.
+- `greet.md` contains the aforementionned generated documentation.

servant-server/example/greet.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+import Data.Aeson
+import Data.Monoid
+import Data.Proxy
+import Data.Text
+import GHC.Generics
+import Network.Wai
+import Network.Wai.Handler.Warp
+
+import Servant
+
+-- * Example
+
+-- | A greet message data type
+newtype Greet = Greet { _msg :: Text }
+  deriving (Generic, Show)
+
+instance FromJSON Greet
+instance ToJSON Greet
+
+-- API specification
+type TestApi =
+       -- GET /hello/:name?capital={true, false}  returns a Greet as JSON
+       "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet
+
+       -- POST /greet with a Greet as JSON in the request body,
+       --             returns a Greet as JSON
+  :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
+
+       -- DELETE /greet/:greetid
+  :<|> "greet" :> Capture "greetid" Text :> Delete
+
+testApi :: Proxy TestApi
+testApi = Proxy
+
+-- Server-side handlers.
+--
+-- There's one handler per endpoint, which, just like in the type
+-- that represents the API, are glued together using :<|>.
+--
+-- Each handler runs in the 'EitherT (Int, String) IO' monad.
+server :: Server TestApi
+server = helloH :<|> postGreetH :<|> deleteGreetH
+
+  where helloH name Nothing = helloH name (Just False)
+        helloH name (Just False) = return . Greet $ "Hello, " <> name
+        helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
+
+        postGreetH greet = return greet
+
+        deleteGreetH _ = return ()
+
+-- Turn the server into a WAI app. 'serve' is provided by servant,
+-- more precisely by the Servant.Server module.
+test :: Application
+test = serve testApi server
+
+-- Run the server.
+--
+-- 'run' comes from Network.Wai.Handler.Warp
+runTestServer :: Port -> IO ()
+runTestServer port = run port test
+
+-- Put this all to work!
+main :: IO ()
+main = runTestServer 8001

servant-server/example/greet.md

@@ -0,0 +1,52 @@
+POST /greet
+-----------
+
+**Request Body**: 
+
+``` javascript
+{"msg":"Hello, haskeller!"}
+```
+
+**Response**: 
+
+ - Status code 201
+ - Response body as below.
+
+``` javascript
+{"msg":"Hello, haskeller!"}
+```
+
+GET /hello/:name
+----------------
+
+**Captures**: 
+
+- *name*: name of the person to greet
+
+**GET Parameters**: 
+
+ - capital
+     - **Values**: *true, false*
+     - **Description**: Get the greeting message in uppercase (true) or not (false). Default is false.
+
+
+**Response**: 
+
+ - Status code 200
+ - Response body as below.
+
+``` javascript
+{"msg":"Hello, haskeller!"}
+```
+
+DELETE /greet/:greetid
+----------------------
+
+**Captures**: 
+
+- *greetid*: identifier of the greet msg to remove
+
+**Response**: 
+
+ - Status code 204
+ - No response body

servant-server/servant-server.cabal

@@ -0,0 +1,101 @@
+name:                servant-server
+version:             0.2.4
+synopsis:            A family of combinators for defining webservices APIs and serving them
+description:
+  A family of combinators for defining webservices APIs and serving them
+  .
+  You can learn about the basics in <http://haskell-servant.github.io/getting-started/ the getting started> guide.
+  .
+  <https://github.com/haskell-servant/servant-server/blob/master/example/greet.hs Here>'s a runnable example, with comments, that defines a dummy API and
+  implements a webserver that serves this API, using this package.
+homepage:            http://haskell-servant.github.io/
+Bug-reports:         http://github.com/haskell-servant/servant-server/issues
+license:             BSD3
+license-file:        LICENSE
+author:              Alp Mestanogullari, Sönke Hahn, Julian K. Arni
+maintainer:          alpmestan@gmail.com
+copyright:           2014 Zalora South East Asia Pte Ltd
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+tested-with:         GHC >= 7.8
+extra-source-files:
+  CHANGELOG.md
+  README.md
+source-repository head
+  type: git
+  location: http://github.com/haskell-servant/servant-server.git
+
+
+library
+  exposed-modules:
+    Servant
+    Servant.Server
+    Servant.Server.Internal
+    Servant.Utils.StaticFiles
+  build-depends:
+        base               >= 4.7  && < 5
+      , aeson              >= 0.7  && < 0.9
+      , attoparsec         >= 0.12 && < 0.13
+      , bytestring         >= 0.10 && < 0.11
+      , either             >= 4.3  && < 4.4
+      , http-types         >= 0.8  && < 0.9
+      , network-uri        >= 2.6  && < 2.7
+      , safe               >= 0.3  && < 0.4
+      , servant            >= 0.2  && < 0.4
+      , split              >= 0.2  && < 0.3
+      , string-conversions >= 0.3  && < 0.4
+      , system-filepath    >= 0.4  && < 0.5
+      , text               >= 1.2  && < 1.3
+      , transformers       >= 0.3  && < 0.5
+      , wai                >= 3.0  && < 3.1
+      , wai-app-static     >= 3.0  && < 3.1
+      , warp               >= 3.0  && < 3.1
+  hs-source-dirs: src
+  default-language: Haskell2010
+  ghc-options: -Wall
+
+executable greet
+  main-is: greet.hs
+  hs-source-dirs: example
+  ghc-options: -Wall
+  default-language: Haskell2010
+  build-depends:
+      base
+    , servant
+    , servant-server
+    , aeson
+    , warp
+    , wai
+    , text
+
+test-suite spec
+  type: exitcode-stdio-1.0
+  ghc-options:
+    -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
+  default-language: Haskell2010
+  hs-source-dirs: test
+  main-is: Spec.hs
+  build-depends:
+      base == 4.*
+    , aeson
+    , bytestring
+    , bytestring-conversion
+    , directory
+    , either
+    , exceptions
+    , hspec == 2.*
+    , hspec-wai
+    , http-types
+    , network >= 2.6
+    , QuickCheck
+    , parsec
+    , servant
+    , servant-server
+    , string-conversions
+    , temporary
+    , text
+    , transformers
+    , wai
+    , wai-extra
+    , warp

servant-server/src/Servant.hs

@@ -0,0 +1,22 @@
+module Servant (
+  -- | This module and its submodules can be used to define servant APIs. Note
+  -- that these API definitions don't directly implement a server (or anything
+  -- else).
+  module Servant.API,
+  -- | For implementing servers for servant APIs.
+  module Servant.Server,
+  -- | Using your types in request paths and query string parameters
+  module Servant.Common.Text,
+  -- | Utilities on top of the servant core
+  module Servant.Utils.Links,
+  module Servant.Utils.StaticFiles,
+  -- | Useful re-exports
+  Proxy(..),
+  ) where
+
+import Data.Proxy
+import Servant.API
+import Servant.Common.Text
+import Servant.Server
+import Servant.Utils.Links
+import Servant.Utils.StaticFiles

servant-server/src/Servant/Server.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module lets you implement 'Server's for defined APIs. You'll
+-- most likely just need 'serve'.
+module Servant.Server
+  ( -- * Run a wai application from an API
+    serve
+
+  , -- * Construct a wai Application from an API
+    toApplication
+
+  , -- * Handlers for all standard combinators
+    HasServer(..)
+  , Server
+  , ServerT
+  ) where
+
+import Data.Proxy (Proxy)
+import Network.Wai (Application)
+import Servant.API (Canonicalize, canonicalize)
+import Servant.Server.Internal
+
+
+-- * Implementing Servers
+
+-- | 'serve' allows you to implement an API and produce a wai 'Application'.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
+-- >         :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
+-- >
+-- > server :: Server MyApi
+-- > server = listAllBooks :<|> postBook
+-- >   where listAllBooks = ...
+-- >         postBook book = ...
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > app :: Application
+-- > app = serve myApi server
+-- >
+-- > main :: IO ()
+-- > main = Network.Wai.Handler.Warp.run 8080 app
+serve :: HasServer (Canonicalize layout) => Proxy layout -> Server layout -> Application
+serve p server = toApplication (route (canonicalize p) server)

servant-server/src/Servant/Server/Internal.hs

@@ -0,0 +1,866 @@
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE PolyKinds            #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeOperators        #-}
+module Servant.Server.Internal where
+
+import           Control.Applicative         ((<$>))
+import           Control.Monad.Trans.Either  (EitherT, runEitherT)
+import qualified Data.ByteString             as B
+import qualified Data.ByteString.Lazy        as BL
+import           Data.IORef                  (newIORef, readIORef, writeIORef)
+import           Data.List                   (unfoldr)
+import           Data.Maybe                  (catMaybes, fromMaybe)
+import           Data.Monoid                 (Monoid, mappend, mempty)
+import           Data.String                 (fromString)
+import           Data.String.Conversions     (cs, (<>))
+import           Data.Text                   (Text)
+import qualified Data.Text                   as T
+import           Data.Text.Encoding          (decodeUtf8, encodeUtf8)
+import           Data.Typeable
+import           GHC.TypeLits                (KnownSymbol, symbolVal)
+import           Network.HTTP.Types          hiding (Header, ResponseHeaders)
+import           Network.Wai                 (Application, Request, Response,
+                                              ResponseReceived, lazyRequestBody,
+                                              pathInfo, rawQueryString,
+                                              requestBody, requestHeaders,
+                                              requestMethod, responseLBS,
+                                              strictRequestBody)
+import           Servant.API                 ((:<|>) (..), (:>), Capture,
+                                              Canonicalize, Delete, Get, Header,
+                                              MatrixFlag, MatrixParam, MatrixParams,
+                                              Patch, Post, Put, QueryFlag,
+                                              QueryParam, QueryParams, Raw,
+                                              ReqBody)
+import           Servant.API.ContentTypes    (AcceptHeader (..),
+                                              AllCTRender (..),
+                                              AllCTUnrender (..))
+import           Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)
+import           Servant.Common.Text         (FromText, fromText)
+
+data ReqBodyState = Uncalled
+                  | Called !B.ByteString
+                  | Done !B.ByteString
+
+
+toApplication :: RoutingApplication -> Application
+toApplication ra request respond = do
+  reqBodyRef <- newIORef Uncalled
+  -- We may need to consume the requestBody more than once.  In order to
+  -- maintain the illusion that 'requestBody' works as expected,
+  -- 'ReqBodyState' is introduced, and the complete body is memoized and
+  -- returned as many times as requested with empty "Done" marker chunks in
+  -- between.
+  -- See https://github.com/haskell-servant/servant/issues/3
+  let memoReqBody = do
+          ior <- readIORef reqBodyRef
+          case ior of
+            Uncalled -> do
+                r <- BL.toStrict <$> strictRequestBody request
+                writeIORef reqBodyRef $ Done r
+                return r
+            Called bs -> do
+                writeIORef reqBodyRef $ Done bs
+                return bs
+            Done bs -> do
+                writeIORef reqBodyRef $ Called bs
+                return B.empty
+
+  ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
+ where
+  routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
+  routingRespond (Left NotFound) =
+    respond $ responseLBS notFound404 [] "not found"
+  routingRespond (Left WrongMethod) =
+    respond $ responseLBS methodNotAllowed405 [] "method not allowed"
+  routingRespond (Left (InvalidBody err)) =
+    respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
+  routingRespond (Left UnsupportedMediaType) =
+    respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
+  routingRespond (Left (HttpError status body)) =
+    respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
+  routingRespond (Right response) =
+    respond response
+
+-- Note that the ordering of the constructors has great significance! It
+-- determines the Ord instance and, consequently, the monoid instance.
+-- * Route mismatch
+data RouteMismatch =
+    NotFound           -- ^ the usual "not found" error
+  | WrongMethod        -- ^ a more informative "you just got the HTTP method wrong" error
+  | UnsupportedMediaType -- ^ request body has unsupported media type
+  | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
+  | HttpError Status (Maybe BL.ByteString)  -- ^ an even even more informative arbitrary HTTP response code error.
+  deriving (Eq, Ord, Show)
+
+instance Monoid RouteMismatch where
+  mempty = NotFound
+  -- The following isn't great, since it picks @InvalidBody@ based on
+  -- alphabetical ordering, but any choice would be arbitrary.
+  --
+  -- "As one judge said to the other, 'Be just and if you can't be just, be
+  -- arbitrary'" -- William Burroughs
+  mappend = max
+
+
+-- | A wrapper around @'Either' 'RouteMismatch' a@.
+newtype RouteResult a =
+  RR { routeResult :: Either RouteMismatch a }
+  deriving (Eq, Show)
+
+failWith :: RouteMismatch -> RouteResult a
+failWith = RR . Left
+
+succeedWith :: a -> RouteResult a
+succeedWith = RR . Right
+
+isMismatch :: RouteResult a -> Bool
+isMismatch (RR (Left _)) = True
+isMismatch _             = False
+
+-- | Like `null . pathInfo`, but works with redundant trailing slashes.
+pathIsEmpty :: Request -> Bool
+pathIsEmpty = f . processedPathInfo
+  where
+    f []   = True
+    f [""] = True
+    f _    = False
+
+-- | If we get a `Right`, it has precedence over everything else.
+--
+-- This in particular means that if we could get several 'Right's,
+-- only the first we encounter would be taken into account.
+instance Monoid (RouteResult a) where
+  mempty = RR $ Left mempty
+
+  RR (Left x)  `mappend` RR (Left y)  = RR $ Left (x <> y)
+  RR (Left _)  `mappend` RR (Right y) = RR $ Right y
+  r            `mappend` _            = r
+
+type RoutingApplication =
+     Request -- ^ the request, the field 'pathInfo' may be modified by url routing
+  -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
+
+splitMatrixParameters :: Text -> (Text, Text)
+splitMatrixParameters = T.break (== ';')
+
+parsePathInfo :: Request -> [Text]
+parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo
+  where mergePairs = concat . unfoldr pairToList
+        pairToList []          = Nothing
+        pairToList ((a, b):xs) = Just ([a, b], xs)
+
+-- | Returns a processed pathInfo from the request.
+--
+-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be
+-- processed, so routing works as intended. Therefor this function should be used to access
+-- the pathInfo for routing purposes.
+processedPathInfo :: Request -> [Text]
+processedPathInfo r =
+  case pinfo of
+    (x:xs) | T.head x == ';' -> xs
+    _                        -> pinfo
+  where pinfo = parsePathInfo r
+
+class HasServer layout where
+  type ServerT' layout (m :: * -> *) :: *
+
+  route :: Proxy layout -> Server' layout -> RoutingApplication
+
+type Server layout = Server' (Canonicalize layout)
+type Server' layout = ServerT' layout (EitherT (Int, String) IO)
+type ServerT layout m = ServerT' (Canonicalize layout) m
+
+-- * Instances
+
+-- | A server for @a ':<|>' b@ first tries to match the request against the route
+--   represented by @a@ and if it fails tries @b@. You must provide a request
+--   handler for each route.
+--
+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
+-- >         :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
+-- >
+-- > server :: Server MyApi
+-- > server = listAllBooks :<|> postBook
+-- >   where listAllBooks = ...
+-- >         postBook book = ...
+instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
+
+  type ServerT' (a :<|> b) m = ServerT' a m :<|> ServerT' b m
+
+  route Proxy (a :<|> b) request respond =
+    route pa a request $ \mResponse ->
+      if isMismatch mResponse
+        then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
+        else respond mResponse
+
+    where pa = Proxy :: Proxy a
+          pb = Proxy :: Proxy b
+
+captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
+captured _ = fromText
+
+-- | If you use 'Capture' in one of the endpoints for your API,
+-- this automatically requires your server-side handler to be a function
+-- that takes an argument of the type specified by the 'Capture'.
+-- This lets servant worry about getting it from the URL and turning
+-- it into a value of the type you specify.
+--
+-- You can control how it'll be converted from 'Text' to your type
+-- by simply providing an instance of 'FromText' for your type.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
+-- >
+-- > server :: Server MyApi
+-- > server = getBook
+-- >   where getBook :: Text -> EitherT (Int, String) IO Book
+-- >         getBook isbn = ...
+instance (KnownSymbol capture, FromText a, HasServer sublayout)
+      => HasServer (Capture capture a :> sublayout) where
+
+  type ServerT' (Capture capture a :> sublayout) m =
+     a -> ServerT' sublayout m
+
+  route Proxy subserver request respond = case processedPathInfo request of
+    (first : rest)
+      -> case captured captureProxy first of
+           Nothing  -> respond $ failWith NotFound
+           Just v   -> route (Proxy :: Proxy sublayout) (subserver v) request{
+                         pathInfo = rest
+                       } respond
+    _ -> respond $ failWith NotFound
+
+    where captureProxy = Proxy :: Proxy (Capture capture a)
+
+
+-- | If you have a 'Delete' endpoint in your API,
+-- the handler for this endpoint is meant to delete
+-- a resource.
+--
+-- The code of the handler will, just like
+-- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and
+-- 'Servant.API.Put.Put', run in @EitherT (Int, String) IO ()@.
+-- The 'Int' represents the status code and the 'String' a message
+-- to be returned. You can use 'Control.Monad.Trans.Either.left' to
+-- painlessly error out if the conditions for a successful deletion
+-- are not met.
+instance HasServer Delete where
+
+  type ServerT' Delete m = m ()
+
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodDelete = do
+        e <- runEitherT action
+        respond $ succeedWith $ case e of
+          Right () ->
+            responseLBS status204 [] ""
+          Left (status, message) ->
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodDelete =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+-- | When implementing the handler for a 'Get' endpoint,
+-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
+-- and 'Servant.API.Put.Put', the handler code runs in the
+-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
+-- the status code and the 'String' a message, returned in case of
+-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
+-- to quickly fail if some conditions are not met.
+--
+-- If successfully returning a value, we use the type-level list, combined
+-- with the request's @Accept@ header, to encode the value for you
+-- (returning a status code of 200). If there was no @Accept@ header or it
+-- was @*/*@, we return encode using the first @Content-Type@ type on the
+-- list.
+instance ( AllCTRender ctypes a
+         ) => HasServer (Get ctypes a) where
+
+  type ServerT' (Get ctypes a) m = m a
+
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodGet = do
+        e <- runEitherT action
+        respond $ case e of
+          Right output -> do
+            let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+            case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
+              Nothing -> failWith UnsupportedMediaType
+              Just (contentT, body) -> succeedWith $
+                responseLBS ok200 [ ("Content-Type" , cs contentT)] body
+          Left (status, message) -> succeedWith $
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodGet =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+-- '()' ==> 204 No Content
+instance HasServer (Get ctypes ()) where
+  type ServerT' (Get ctypes ()) m = m ()
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodGet = do
+        e <- runEitherT action
+        respond . succeedWith $ case e of
+          Right () -> responseLBS noContent204 [] ""
+          Left (status, message) ->
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodGet =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+-- Add response headers
+instance ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where
+  type ServerT' (Get ctypes (Headers h v)) m = m (Headers h v)
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodGet = do
+      e <- runEitherT action
+      respond $ case e of
+        Right output -> do
+          let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+              headers = getHeaders output
+          case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
+            Nothing -> failWith UnsupportedMediaType
+            Just (contentT, body) -> succeedWith $
+              responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
+        Left (status, message) -> succeedWith $
+          responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodGet =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+-- | If you use 'Header' in one of the endpoints for your API,
+-- this automatically requires your server-side handler to be a function
+-- that takes an argument of the type specified by 'Header'.
+-- This lets servant worry about extracting it from the request and turning
+-- it into a value of the type you specify.
+--
+-- All it asks is for a 'FromText' instance.
+--
+-- Example:
+--
+-- > newtype Referer = Referer Text
+-- >   deriving (Eq, Show, FromText, ToText)
+-- >
+-- >            -- GET /view-my-referer
+-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
+-- >
+-- > server :: Server MyApi
+-- > server = viewReferer
+-- >   where viewReferer :: Referer -> EitherT (Int, String) IO referer
+-- >         viewReferer referer = return referer
+instance (KnownSymbol sym, FromText a, HasServer sublayout)
+      => HasServer (Header sym a :> sublayout) where
+
+  type ServerT' (Header sym a :> sublayout) m =
+    Maybe a -> ServerT' sublayout m
+
+  route Proxy subserver request respond = do
+    let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
+    route (Proxy :: Proxy sublayout) (subserver mheader) request respond
+
+      where str = fromString $ symbolVal (Proxy :: Proxy sym)
+
+-- | When implementing the handler for a 'Post' endpoint,
+-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
+-- and 'Servant.API.Put.Put', the handler code runs in the
+-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
+-- the status code and the 'String' a message, returned in case of
+-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
+-- to quickly fail if some conditions are not met.
+--
+-- If successfully returning a value, we use the type-level list, combined
+-- with the request's @Accept@ header, to encode the value for you
+-- (returning a status code of 201). If there was no @Accept@ header or it
+-- was @*/*@, we return encode using the first @Content-Type@ type on the
+-- list.
+instance ( AllCTRender ctypes a
+         ) => HasServer (Post ctypes a) where
+
+  type ServerT' (Post ctypes a) m = m a
+
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodPost = do
+        e <- runEitherT action
+        respond $ case e of
+          Right output -> do
+            let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+            case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
+              Nothing -> failWith UnsupportedMediaType
+              Just (contentT, body) -> succeedWith $
+                responseLBS status201 [ ("Content-Type" , cs contentT)] body
+          Left (status, message) -> succeedWith $
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodPost =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+instance HasServer (Post ctypes ()) where
+  type ServerT' (Post ctypes ()) m = m ()
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodPost = do
+        e <- runEitherT action
+        respond . succeedWith $ case e of
+          Right () -> responseLBS noContent204 [] ""
+          Left (status, message) ->
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodPost =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+-- Add response headers
+instance ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where
+  type ServerT' (Post ctypes (Headers h v)) m = m (Headers h v)
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodPost = do
+      e <- runEitherT action
+      respond $ case e of
+        Right output -> do
+          let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+              headers = getHeaders output
+          case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
+            Nothing -> failWith UnsupportedMediaType
+            Just (contentT, body) -> succeedWith $
+              responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
+        Left (status, message) -> succeedWith $
+          responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodPost =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+-- | When implementing the handler for a 'Put' endpoint,
+-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
+-- and 'Servant.API.Post.Post', the handler code runs in the
+-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
+-- the status code and the 'String' a message, returned in case of
+-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
+-- to quickly fail if some conditions are not met.
+--
+-- If successfully returning a value, we use the type-level list, combined
+-- with the request's @Accept@ header, to encode the value for you
+-- (returning a status code of 200). If there was no @Accept@ header or it
+-- was @*/*@, we return encode using the first @Content-Type@ type on the
+-- list.
+instance ( AllCTRender ctypes a
+         ) => HasServer (Put ctypes a) where
+
+  type ServerT' (Put ctypes a) m = m a
+
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodPut = do
+        e <- runEitherT action
+        respond $ case e of
+          Right output -> do
+            let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+            case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
+              Nothing -> failWith UnsupportedMediaType
+              Just (contentT, body) -> succeedWith $
+                responseLBS status200 [ ("Content-Type" , cs contentT)] body
+          Left (status, message) -> succeedWith $
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodPut =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+instance HasServer (Put ctypes ()) where
+  type ServerT' (Put ctypes ()) m = m ()
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodPut = do
+        e <- runEitherT action
+        respond . succeedWith $ case e of
+          Right () -> responseLBS noContent204 [] ""
+          Left (status, message) ->
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodPut =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+-- Add response headers
+instance ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where
+  type ServerT' (Put ctypes (Headers h v)) m = m (Headers h v)
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodPut = do
+      e <- runEitherT action
+      respond $ case e of
+        Right output -> do
+          let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+              headers = getHeaders output
+          case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
+            Nothing -> failWith UnsupportedMediaType
+            Just (contentT, body) -> succeedWith $
+              responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
+        Left (status, message) -> succeedWith $
+          responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodPut =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+-- | When implementing the handler for a 'Patch' endpoint,
+-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
+-- and 'Servant.API.Put.Put', the handler code runs in the
+-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
+-- the status code and the 'String' a message, returned in case of
+-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
+-- to quickly fail if some conditions are not met.
+--
+-- If successfully returning a value, we just require that its type has
+-- a 'ToJSON' instance and servant takes care of encoding it for you,
+-- yielding status code 200 along the way.
+instance ( AllCTRender ctypes a
+         ) => HasServer (Patch ctypes a) where
+  type ServerT' (Patch ctypes a) m = m a
+
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodPatch = do
+        e <- runEitherT action
+        respond $ case e of
+          Right output -> do
+            let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+            case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
+              Nothing -> failWith UnsupportedMediaType
+              Just (contentT, body) -> succeedWith $
+                responseLBS status200 [ ("Content-Type" , cs contentT)] body
+          Left (status, message) -> succeedWith $
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodPatch =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+instance HasServer (Patch ctypes ()) where
+  type ServerT' (Patch ctypes ()) m = m ()
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodPatch = do
+        e <- runEitherT action
+        respond . succeedWith $ case e of
+          Right () -> responseLBS noContent204 [] ""
+          Left (status, message) ->
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodPatch =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+-- Add response headers
+instance ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where
+  type ServerT' (Patch ctypes (Headers h v)) m = m (Headers h v)
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodPatch = do
+      e <- runEitherT action
+      respond $ case e of
+        Right outpatch -> do
+          let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+              headers = getHeaders outpatch
+          case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of
+            Nothing -> failWith UnsupportedMediaType
+            Just (contentT, body) -> succeedWith $
+              responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
+        Left (status, message) -> succeedWith $
+          responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodPatch =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
+-- this automatically requires your server-side handler to be a function
+-- that takes an argument of type @'Maybe' 'Text'@.
+--
+-- This lets servant worry about looking it up in the query string
+-- and turning it into a value of the type you specify, enclosed
+-- in 'Maybe', because it may not be there and servant would then
+-- hand you 'Nothing'.
+--
+-- You can control how it'll be converted from 'Text' to your type
+-- by simply providing an instance of 'FromText' for your type.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
+-- >
+-- > server :: Server MyApi
+-- > server = getBooksBy
+-- >   where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]
+-- >         getBooksBy Nothing       = ...return all books...
+-- >         getBooksBy (Just author) = ...return books by the given author...
+instance (KnownSymbol sym, FromText a, HasServer sublayout)
+      => HasServer (QueryParam sym a :> sublayout) where
+
+  type ServerT' (QueryParam sym a :> sublayout) m =
+    Maybe a -> ServerT' sublayout m
+
+  route Proxy subserver request respond = do
+    let querytext = parseQueryText $ rawQueryString request
+        param =
+          case lookup paramname querytext of
+            Nothing       -> Nothing -- param absent from the query string
+            Just Nothing  -> Nothing -- param present with no value -> Nothing
+            Just (Just v) -> fromText v -- if present, we try to convert to
+                                        -- the right type
+
+    route (Proxy :: Proxy sublayout) (subserver param) request respond
+
+    where paramname = cs $ symbolVal (Proxy :: Proxy sym)
+
+-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
+-- this automatically requires your server-side handler to be a function
+-- that takes an argument of type @['Text']@.
+--
+-- This lets servant worry about looking up 0 or more values in the query string
+-- associated to @authors@ and turning each of them into a value of
+-- the type you specify.
+--
+-- You can control how the individual values are converted from 'Text' to your type
+-- by simply providing an instance of 'FromText' for your type.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
+-- >
+-- > server :: Server MyApi
+-- > server = getBooksBy
+-- >   where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]
+-- >         getBooksBy authors = ...return all books by these authors...
+instance (KnownSymbol sym, FromText a, HasServer sublayout)
+      => HasServer (QueryParams sym a :> sublayout) where
+
+  type ServerT' (QueryParams sym a :> sublayout) m =
+    [a] -> ServerT' sublayout m
+
+  route Proxy subserver request respond = do
+    let querytext = parseQueryText $ rawQueryString request
+        -- if sym is "foo", we look for query string parameters
+        -- named "foo" or "foo[]" and call fromText on the
+        -- corresponding values
+        parameters = filter looksLikeParam querytext
+        values = catMaybes $ map (convert . snd) parameters
+
+    route (Proxy :: Proxy sublayout) (subserver values) request respond
+
+    where paramname = cs $ symbolVal (Proxy :: Proxy sym)
+          looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
+          convert Nothing = Nothing
+          convert (Just v) = fromText v
+
+-- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API,
+-- this automatically requires your server-side handler to be a function
+-- that takes an argument of type 'Bool'.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
+-- >
+-- > server :: Server MyApi
+-- > server = getBooks
+-- >   where getBooks :: Bool -> EitherT (Int, String) IO [Book]
+-- >         getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
+instance (KnownSymbol sym, HasServer sublayout)
+      => HasServer (QueryFlag sym :> sublayout) where
+
+  type ServerT' (QueryFlag sym :> sublayout) m =
+    Bool -> ServerT' sublayout m
+
+  route Proxy subserver request respond = do
+    let querytext = parseQueryText $ rawQueryString request
+        param = case lookup paramname querytext of
+          Just Nothing  -> True  -- param is there, with no value
+          Just (Just v) -> examine v -- param with a value
+          Nothing       -> False -- param not in the query string
+
+    route (Proxy :: Proxy sublayout) (subserver param) request respond
+
+    where paramname = cs $ symbolVal (Proxy :: Proxy sym)
+          examine v | v == "true" || v == "1" || v == "" = True
+                    | otherwise = False
+
+parseMatrixText :: B.ByteString -> QueryText
+parseMatrixText = parseQueryText
+
+-- | If you use @'MatrixParam' "author" Text@ in one of the endpoints for your API,
+-- this automatically requires your server-side handler to be a function
+-- that takes an argument of type @'Maybe' 'Text'@.
+--
+-- This lets servant worry about looking it up in the query string
+-- and turning it into a value of the type you specify, enclosed
+-- in 'Maybe', because it may not be there and servant would then
+-- hand you 'Nothing'.
+--
+-- You can control how it'll be converted from 'Text' to your type
+-- by simply providing an instance of 'FromText' for your type.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> MatrixParam "author" Text :> Get [Book]
+-- >
+-- > server :: Server MyApi
+-- > server = getBooksBy
+-- >   where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]
+-- >         getBooksBy Nothing       = ...return all books...
+-- >         getBooksBy (Just author) = ...return books by the given author...
+instance (KnownSymbol sym, FromText a, HasServer sublayout)
+      => HasServer (MatrixParam sym a :> sublayout) where
+
+  type ServerT' (MatrixParam sym a :> sublayout) m =
+    Maybe a -> ServerT' sublayout m
+
+  route Proxy subserver request respond = case parsePathInfo request of
+    (first : _)
+      -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first
+                param = case lookup paramname querytext of
+                  Nothing       -> Nothing -- param absent from the query string
+                  Just Nothing  -> Nothing -- param present with no value -> Nothing
+                  Just (Just v) -> fromText v -- if present, we try to convert to
+                                        -- the right type
+            route (Proxy :: Proxy sublayout) (subserver param) request respond
+    _ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond
+
+    where paramname = cs $ symbolVal (Proxy :: Proxy sym)
+
+-- | If you use @'MatrixParams' "authors" Text@ in one of the endpoints for your API,
+-- this automatically requires your server-side handler to be a function
+-- that takes an argument of type @['Text']@.
+--
+-- This lets servant worry about looking up 0 or more values in the query string
+-- associated to @authors@ and turning each of them into a value of
+-- the type you specify.
+--
+-- You can control how the individual values are converted from 'Text' to your type
+-- by simply providing an instance of 'FromText' for your type.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> MatrixParams "authors" Text :> Get [Book]
+-- >
+-- > server :: Server MyApi
+-- > server = getBooksBy
+-- >   where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]
+-- >         getBooksBy authors = ...return all books by these authors...
+instance (KnownSymbol sym, FromText a, HasServer sublayout)
+      => HasServer (MatrixParams sym a :> sublayout) where
+
+  type ServerT' (MatrixParams sym a :> sublayout) m =
+    [a] -> ServerT' sublayout m
+
+  route Proxy subserver request respond = case parsePathInfo request of
+    (first : _)
+      -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
+                -- if sym is "foo", we look for matrix parameters
+                -- named "foo" or "foo[]" and call fromText on the
+                -- corresponding values
+                parameters = filter looksLikeParam matrixtext
+                values = catMaybes $ map (convert . snd) parameters
+            route (Proxy :: Proxy sublayout) (subserver values) request respond
+    _ -> route (Proxy :: Proxy sublayout) (subserver []) request respond
+
+    where paramname = cs $ symbolVal (Proxy :: Proxy sym)
+          looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
+          convert Nothing = Nothing
+          convert (Just v) = fromText v
+
+-- | If you use @'MatrixFlag' "published"@ in one of the endpoints for your API,
+-- this automatically requires your server-side handler to be a function
+-- that takes an argument of type 'Bool'.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> MatrixFlag "published" :> Get [Book]
+-- >
+-- > server :: Server MyApi
+-- > server = getBooks
+-- >   where getBooks :: Bool -> EitherT (Int, String) IO [Book]
+-- >         getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
+instance (KnownSymbol sym, HasServer sublayout)
+      => HasServer (MatrixFlag sym :> sublayout) where
+
+  type ServerT' (MatrixFlag sym :> sublayout) m =
+    Bool -> ServerT' sublayout m
+
+  route Proxy subserver request respond =  case parsePathInfo request of
+    (first : _)
+      -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
+                param = case lookup paramname matrixtext of
+                  Just Nothing  -> True  -- param is there, with no value
+                  Just (Just v) -> examine v -- param with a value
+                  Nothing       -> False -- param not in the query string
+
+            route (Proxy :: Proxy sublayout) (subserver param) request respond
+
+    _ -> route (Proxy :: Proxy sublayout) (subserver False) request respond
+
+    where paramname = cs $ symbolVal (Proxy :: Proxy sym)
+          examine v | v == "true" || v == "1" || v == "" = True
+                    | otherwise = False
+
+-- | Just pass the request to the underlying application and serve its response.
+--
+-- Example:
+--
+-- > type MyApi = "images" :> Raw
+-- >
+-- > server :: Server MyApi
+-- > server = serveDirectory "/var/www/images"
+instance HasServer Raw where
+
+  type ServerT' Raw m = Application
+
+  route Proxy rawApplication request respond =
+    rawApplication request (respond . succeedWith)
+
+-- | If you use 'ReqBody' in one of the endpoints for your API,
+-- this automatically requires your server-side handler to be a function
+-- that takes an argument of the type specified by 'ReqBody'.
+-- The @Content-Type@ header is inspected, and the list provided is used to
+-- attempt deserialization. If the request does not have a @Content-Type@
+-- header, it is treated as @application/octet-stream@.
+-- This lets servant worry about extracting it from the request and turning
+-- it into a value of the type you specify.
+--
+--
+-- All it asks is for a 'FromJSON' instance.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
+-- >
+-- > server :: Server MyApi
+-- > server = postBook
+-- >   where postBook :: Book -> EitherT (Int, String) IO Book
+-- >         postBook book = ...insert into your db...
+instance ( AllCTUnrender list a, HasServer sublayout
+         ) => HasServer (ReqBody list a :> sublayout) where
+
+  type ServerT' (ReqBody list a :> sublayout) m =
+    a -> ServerT' sublayout m
+
+  route Proxy subserver request respond = do
+    -- See HTTP RFC 2616, section 7.2.1
+    -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
+    -- See also "W3C Internet Media Type registration, consistency of use"
+    -- http://www.w3.org/2001/tag/2002/0129-mime
+    let contentTypeH = fromMaybe "application/octet-stream"
+                     $ lookup hContentType $ requestHeaders request
+    mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
+           <$> lazyRequestBody request
+    case mrqbody of
+      Nothing -> respond . failWith $ UnsupportedMediaType
+      Just (Left e) -> respond . failWith $ InvalidBody e
+      Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond
+
+-- | Make sure the incoming request starts with @"/path"@, strip it and
+-- pass the rest of the request path to @sublayout@.
+instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
+
+  type ServerT' (path :> sublayout) m = ServerT' sublayout m
+
+  route Proxy subserver request respond = case processedPathInfo request of
+    (first : rest)
+      | first == cs (symbolVal proxyPath)
+      -> route (Proxy :: Proxy sublayout) subserver request{
+           pathInfo = rest
+         } respond
+    _ -> respond $ failWith NotFound
+
+    where proxyPath = Proxy :: Proxy path

servant-server/src/Servant/Utils/StaticFiles.hs

@@ -0,0 +1,36 @@
+-- | This module defines a sever-side handler that lets you serve static files.
+--
+-- - 'serveDirectory' lets you serve anything that lives under a particular
+--   directory on your filesystem.
+module Servant.Utils.StaticFiles (
+  serveDirectory,
+ ) where
+
+import Filesystem.Path.CurrentOS (decodeString)
+import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)
+import Servant.API.Raw (Raw)
+import Servant.Server (Server)
+
+-- | Serve anything under the specified directory as a 'Raw' endpoint.
+--
+-- @
+-- type MyApi = "static" :> Raw
+--
+-- server :: Server MyApi
+-- server = serveDirectory "\/var\/www"
+-- @
+--
+-- would capture any request to @\/static\/\<something>@ and look for
+-- @\<something>@ under @\/var\/www@.
+--
+-- It will do its best to guess the MIME type for that file, based on the extension,
+-- and send an appropriate /Content-Type/ header if possible.
+--
+-- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API
+-- as a webapp backend, you will most likely not want the static files to be hidden
+-- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectory'
+-- handler in the last position, because /servant/ will try to match the handlers
+-- in order.
+serveDirectory :: FilePath -> Server Raw
+serveDirectory documentRoot =
+  staticApp (defaultFileServerSettings (decodeString (documentRoot ++ "/")))

servant-server/test/Servant/ServerSpec.hs

@@ -0,0 +1,619 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+{-# LANGUAGE FlexibleInstances       #-}
+
+module Servant.ServerSpec where
+
+
+import           Control.Monad              (forM_, when)
+import           Control.Monad.Trans.Either (EitherT, left)
+import           Data.Aeson                 (FromJSON, ToJSON, decode', encode)
+import           Data.ByteString.Conversion ()
+import           Data.Char                  (toUpper)
+import           Data.Monoid                ((<>))
+import           Data.Proxy                 (Proxy (Proxy))
+import           Data.String                (fromString)
+import           Data.String.Conversions    (cs)
+import qualified Data.Text                  as T
+import           GHC.Generics               (Generic)
+import           Network.HTTP.Types         (hAccept, hContentType,
+                                             methodDelete, methodGet,
+                                             methodPatch, methodPost, methodPut,
+                                             ok200, parseQuery, status409)
+import           Network.Wai                (Application, Request, pathInfo,
+                                             queryString, rawQueryString,
+                                             responseLBS)
+import           Network.Wai.Test           (defaultRequest, request,
+                                             runSession, simpleBody)
+import           Test.Hspec                 (Spec, describe, it, shouldBe)
+import           Test.Hspec.Wai             (get, liftIO, matchHeaders,
+                                             matchStatus, post, request,
+                                             shouldRespondWith, with, (<:>))
+
+import           Servant.API                ((:<|>) (..), (:>),
+                                             AddHeader (addHeader), Capture,
+                                             Delete, Get, Header (..), Headers,
+                                             JSON, MatrixFlag, MatrixParam,
+                                             MatrixParams, Patch, PlainText,
+                                             Post, Put, QueryFlag, QueryParam,
+                                             QueryParams, Raw, ReqBody)
+import           Servant.Server             (Server, serve)
+import           Servant.Server.Internal    (RouteMismatch (..))
+
+
+-- * test data types
+
+data Person = Person {
+  name :: String,
+  age  :: Integer
+ }
+  deriving (Eq, Show, Generic)
+
+instance ToJSON Person
+instance FromJSON Person
+
+alice :: Person
+alice = Person "Alice" 42
+
+data Animal = Animal {
+  species      :: String,
+  numberOfLegs :: Integer
+ }
+  deriving (Eq, Show, Generic)
+
+instance ToJSON Animal
+instance FromJSON Animal
+
+jerry :: Animal
+jerry = Animal "Mouse" 4
+
+tweety :: Animal
+tweety = Animal "Bird" 2
+
+
+-- * specs
+
+spec :: Spec
+spec = do
+  captureSpec
+  getSpec
+  postSpec
+  putSpec
+  patchSpec
+  queryParamSpec
+  matrixParamSpec
+  headerSpec
+  rawSpec
+  unionSpec
+  errorsSpec
+  responseHeadersSpec
+
+
+type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
+captureApi :: Proxy CaptureApi
+captureApi = Proxy
+captureServer :: Integer -> EitherT (Int, String) IO Animal
+captureServer legs = case legs of
+  4 -> return jerry
+  2 -> return tweety
+  _ -> left (404, "not found")
+
+captureSpec :: Spec
+captureSpec = do
+  describe "Servant.API.Capture" $ do
+    with (return (serve captureApi captureServer)) $ do
+
+      it "can capture parts of the 'pathInfo'" $ do
+        response <- get "/2"
+        liftIO $ decode' (simpleBody response) `shouldBe` Just tweety
+
+      it "returns 404 if the decoding fails" $ do
+        get "/notAnInt" `shouldRespondWith` 404
+
+    with (return (serve
+        (Proxy :: Proxy (Capture "captured" String :> Raw))
+        (\ "captured" request_ respond ->
+            respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
+      it "strips the captured path snippet from pathInfo" $ do
+        get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
+
+
+type GetApi = Get '[JSON] Person
+        :<|> "empty" :> Get '[] ()
+getApi :: Proxy GetApi
+getApi = Proxy
+
+getSpec :: Spec
+getSpec = do
+  describe "Servant.API.Get" $ do
+    let server = return alice :<|> return ()
+    with (return $ serve getApi server) $ do
+
+      it "allows to GET a Person" $ do
+        response <- get "/"
+        return response `shouldRespondWith` 200
+        liftIO $ decode' (simpleBody response) `shouldBe` Just alice
+
+      it "throws 405 (wrong method) on POSTs" $ do
+        post "/" "" `shouldRespondWith` 405
+        post "/empty" "" `shouldRespondWith` 405
+
+      it "returns 204 if the type is '()'" $ do
+        get "empty" `shouldRespondWith` ""{ matchStatus = 204 }
+
+      it "returns 415 if the Accept header is not supported" $ do
+        Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
+          `shouldRespondWith` 415
+
+
+
+type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
+                :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
+                :<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person
+
+queryParamApi :: Proxy QueryParamApi
+queryParamApi = Proxy
+
+qpServer :: Server QueryParamApi
+qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize
+
+  where qpNames (_:name2:_) = return alice { name = name2 }
+        qpNames _           = return alice
+
+        qpCapitalize False = return alice
+        qpCapitalize True  = return alice { name = map toUpper (name alice) }
+
+        queryParamServer (Just name_) = return alice{name = name_}
+        queryParamServer Nothing = return alice
+
+queryParamSpec :: Spec
+queryParamSpec = do
+  describe "Servant.API.QueryParam" $ do
+      it "allows to retrieve simple GET parameters" $
+        (flip runSession) (serve queryParamApi qpServer) $ do
+          let params1 = "?name=bob"
+          response1 <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params1,
+            queryString = parseQuery params1
+           }
+          liftIO $ do
+            decode' (simpleBody response1) `shouldBe` Just alice{
+              name = "bob"
+             }
+
+      it "allows to retrieve lists in GET parameters" $
+        (flip runSession) (serve queryParamApi qpServer) $ do
+          let params2 = "?names[]=bob&names[]=john"
+          response2 <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params2,
+            queryString = parseQuery params2,
+            pathInfo = ["a"]
+           }
+          liftIO $
+            decode' (simpleBody response2) `shouldBe` Just alice{
+              name = "john"
+             }
+
+
+      it "allows to retrieve value-less GET parameters" $
+        (flip runSession) (serve queryParamApi qpServer) $ do
+          let params3 = "?capitalize"
+          response3 <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params3,
+            queryString = parseQuery params3,
+            pathInfo = ["b"]
+           }
+          liftIO $
+            decode' (simpleBody response3) `shouldBe` Just alice{
+              name = "ALICE"
+             }
+
+          let params3' = "?capitalize="
+          response3' <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params3',
+            queryString = parseQuery params3',
+            pathInfo = ["b"]
+           }
+          liftIO $
+            decode' (simpleBody response3') `shouldBe` Just alice{
+              name = "ALICE"
+             }
+
+          let params3'' = "?unknown="
+          response3' <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params3'',
+            queryString = parseQuery params3'',
+            pathInfo = ["b"]
+           }
+          liftIO $
+            decode' (simpleBody response3') `shouldBe` Just alice{
+              name = "Alice"
+             }
+
+type MatrixParamApi = "a" :> MatrixParam "name" String :> Get '[JSON] Person
+                :<|> "b" :> MatrixParams "names" String :> "bsub" :> MatrixParams "names" String :> Get '[JSON] Person
+                :<|> "c" :> MatrixFlag "capitalize" :> Get '[JSON] Person
+                :<|> "d" :> Capture "foo" Integer :> MatrixParam "name" String :> MatrixFlag "capitalize" :> "dsub" :> Get '[JSON] Person
+
+matrixParamApi :: Proxy MatrixParamApi
+matrixParamApi = Proxy
+
+mpServer :: Server MatrixParamApi
+mpServer = matrixParamServer :<|> mpNames :<|> mpCapitalize alice :<|> mpComplex
+  where mpNames (_:name2:_) _ = return alice { name = name2 }
+        mpNames _           _ = return alice
+
+        mpCapitalize p False = return p
+        mpCapitalize p True  = return p { name = map toUpper (name p) }
+
+        matrixParamServer (Just name) = return alice{name = name}
+        matrixParamServer Nothing = return alice
+
+        mpAge age p = return p { age = age }
+        mpComplex capture name cap = matrixParamServer name >>= flip mpCapitalize cap >>= mpAge capture
+
+matrixParamSpec :: Spec
+matrixParamSpec = do
+  describe "Servant.API.MatrixParam" $ do
+      it "allows to retrieve simple matrix parameters" $
+        (flip runSession) (serve matrixParamApi mpServer) $ do
+          response1 <- Network.Wai.Test.request defaultRequest{
+            pathInfo = ["a;name=bob"]
+           }
+          liftIO $ do
+            decode' (simpleBody response1) `shouldBe` Just alice{
+              name = "bob"
+             }
+
+      it "allows to retrieve lists in matrix parameters" $
+        (flip runSession) (serve matrixParamApi mpServer) $ do
+          response2 <- Network.Wai.Test.request defaultRequest{
+            pathInfo = ["b;names=bob;names=john", "bsub;names=anna;names=sarah"]
+           }
+          liftIO $
+            decode' (simpleBody response2) `shouldBe` Just alice{
+              name = "john"
+             }
+
+      it "allows to retrieve value-less matrix parameters" $
+        (flip runSession) (serve matrixParamApi mpServer) $ do
+          response3 <- Network.Wai.Test.request defaultRequest{
+            pathInfo = ["c;capitalize"]
+           }
+          liftIO $
+            decode' (simpleBody response3) `shouldBe` Just alice{
+              name = "ALICE"
+             }
+
+          response3' <- Network.Wai.Test.request defaultRequest{
+            pathInfo = ["c;capitalize="]
+           }
+          liftIO $
+            decode' (simpleBody response3') `shouldBe` Just alice{
+              name = "ALICE"
+             }
+
+      it "allows to retrieve matrix parameters on captured segments" $
+        (flip runSession) (serve matrixParamApi mpServer) $ do
+          response4 <- Network.Wai.Test.request defaultRequest{
+            pathInfo = ["d", "12;name=stephen;capitalize", "dsub"]
+           }
+          liftIO $
+            decode' (simpleBody response4) `shouldBe` Just alice{
+              name = "STEPHEN",
+              age = 12
+             }
+
+          response4' <- Network.Wai.Test.request defaultRequest{
+            pathInfo = ["d;ignored=1", "5", "dsub"]
+           }
+          liftIO $
+            decode' (simpleBody response4') `shouldBe` Just alice{
+              name = "Alice",
+              age = 5
+             }
+
+type PostApi =
+       ReqBody '[JSON] Person :> Post '[JSON] Integer
+  :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
+  :<|> "empty" :> Post '[] ()
+
+postApi :: Proxy PostApi
+postApi = Proxy
+
+postSpec :: Spec
+postSpec = do
+  describe "Servant.API.Post and .ReqBody" $ do
+    let server = return . age :<|> return . age :<|> return ()
+    with (return $ serve postApi server) $ do
+      let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
+                                                        , "application/json;charset=utf-8")]
+
+      it "allows to POST a Person" $ do
+        post' "/" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 201
+         }
+
+      it "allows alternative routes if all have request bodies" $ do
+        post' "/bla" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 201
+         }
+
+      it "handles trailing '/' gracefully" $ do
+        post' "/bla/" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 201
+         }
+
+      it "correctly rejects invalid request bodies with status 400" $ do
+        post' "/" "some invalid body" `shouldRespondWith` 400
+
+      it "returns 204 if the type is '()'" $ do
+        post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
+
+      it "responds with 415 if the requested media type is unsupported" $ do
+        let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
+                                                            , "application/nonsense")]
+        post'' "/" "anything at all" `shouldRespondWith` 415
+
+type PutApi =
+       ReqBody '[JSON] Person :> Put '[JSON] Integer
+  :<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
+  :<|> "empty" :> Put '[] ()
+
+putApi :: Proxy PutApi
+putApi = Proxy
+
+putSpec :: Spec
+putSpec = do
+  describe "Servant.API.Put and .ReqBody" $ do
+    let server = return . age :<|> return . age :<|> return ()
+    with (return $ serve putApi server) $ do
+      let put' x = Test.Hspec.Wai.request methodPut x [(hContentType
+                                                        , "application/json;charset=utf-8")]
+
+      it "allows to put a Person" $ do
+        put' "/" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 200
+         }
+
+      it "allows alternative routes if all have request bodies" $ do
+        put' "/bla" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 200
+         }
+
+      it "handles trailing '/' gracefully" $ do
+        put' "/bla/" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 200
+         }
+
+      it "correctly rejects invalid request bodies with status 400" $ do
+        put' "/" "some invalid body" `shouldRespondWith` 400
+
+      it "returns 204 if the type is '()'" $ do
+        put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
+
+      it "responds with 415 if the requested media type is unsupported" $ do
+        let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType
+                                                            , "application/nonsense")]
+        put'' "/" "anything at all" `shouldRespondWith` 415
+
+type PatchApi =
+       ReqBody '[JSON] Person :> Patch '[JSON] Integer
+  :<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer
+  :<|> "empty" :> Patch '[] ()
+
+patchApi :: Proxy PatchApi
+patchApi = Proxy
+
+patchSpec :: Spec
+patchSpec = do
+  describe "Servant.API.Patch and .ReqBody" $ do
+    let server = return . age :<|> return . age :<|> return ()
+    with (return $ serve patchApi server) $ do
+      let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType
+                                                        , "application/json;charset=utf-8")]
+
+      it "allows to patch a Person" $ do
+        patch' "/" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 200
+         }
+
+      it "allows alternative routes if all have request bodies" $ do
+        patch' "/bla" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 200
+         }
+
+      it "handles trailing '/' gracefully" $ do
+        patch' "/bla/" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 200
+         }
+
+      it "correctly rejects invalid request bodies with status 400" $ do
+        patch' "/" "some invalid body" `shouldRespondWith` 400
+
+      it "returns 204 if the type is '()'" $ do
+        patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
+
+      it "responds with 415 if the requested media type is unsupported" $ do
+        let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
+                                                            , "application/nonsense")]
+        patch'' "/" "anything at all" `shouldRespondWith` 415
+
+type HeaderApi a = Header "MyHeader" a :> Delete
+headerApi :: Proxy (HeaderApi a)
+headerApi = Proxy
+
+headerSpec :: Spec
+headerSpec = describe "Servant.API.Header" $ do
+
+    let expectsInt :: Maybe Int -> EitherT (Int,String) IO ()
+        expectsInt (Just x) = when (x /= 5) $ error "Expected 5"
+        expectsInt Nothing  = error "Expected an int"
+
+    let expectsString :: Maybe String -> EitherT (Int,String) IO ()
+        expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
+        expectsString Nothing  = error "Expected a string"
+
+    with (return (serve headerApi expectsInt)) $ do
+        let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")]
+
+        it "passes the header to the handler (Int)" $
+            delete' "/" "" `shouldRespondWith` 204
+
+    with (return (serve headerApi expectsString)) $ do
+        let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")]
+
+        it "passes the header to the handler (String)" $
+            delete' "/" "" `shouldRespondWith` 204
+
+
+type RawApi = "foo" :> Raw
+rawApi :: Proxy RawApi
+rawApi = Proxy
+rawApplication :: Show a => (Request -> a) -> Application
+rawApplication f request_ respond = respond $ responseLBS ok200 [] (cs $ show $ f request_)
+
+rawSpec :: Spec
+rawSpec = do
+  describe "Servant.API.Raw" $ do
+    it "runs applications" $ do
+      (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
+        response <- Network.Wai.Test.request defaultRequest{
+          pathInfo = ["foo"]
+         }
+        liftIO $ do
+          simpleBody response `shouldBe` "42"
+
+    it "gets the pathInfo modified" $ do
+      (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do
+        response <- Network.Wai.Test.request defaultRequest{
+          pathInfo = ["foo", "bar"]
+         }
+        liftIO $ do
+          simpleBody response `shouldBe` cs (show ["bar" :: String])
+
+
+type AlternativeApi =
+       "foo" :> Get '[JSON] Person
+  :<|> "bar" :> Get '[JSON] Animal
+  :<|> "foo" :> Get '[PlainText] T.Text
+  :<|> "bar" :> Post '[JSON] Animal
+  :<|> "bar" :> Put '[JSON] Animal
+  :<|> "bar" :> Delete
+unionApi :: Proxy AlternativeApi
+unionApi = Proxy
+
+unionServer :: Server AlternativeApi
+unionServer =
+       return alice
+  :<|> return jerry
+  :<|> return "a string"
+  :<|> return jerry
+  :<|> return jerry
+  :<|> return ()
+
+unionSpec :: Spec
+unionSpec = do
+  describe "Servant.API.Alternative" $ do
+    with (return $ serve unionApi unionServer) $ do
+
+      it "unions endpoints" $ do
+        response <- get "/foo"
+        liftIO $ do
+          decode' (simpleBody response) `shouldBe`
+            Just alice
+        response_ <- get "/bar"
+        liftIO $ do
+          decode' (simpleBody response_) `shouldBe`
+            Just jerry
+
+      it "checks all endpoints before returning 415" $ do
+        get "/foo" `shouldRespondWith` 200
+
+      it "returns 404 if the path does not exist" $ do
+        get "/nonexistent" `shouldRespondWith` 404
+
+type ResponseHeadersApi =
+       Get   '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
+  :<|> Post  '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
+  :<|> Put   '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
+  :<|> Patch '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
+
+
+responseHeadersServer :: Server ResponseHeadersApi
+responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"
+  in h :<|> h :<|> h :<|> h
+
+
+responseHeadersSpec :: Spec
+responseHeadersSpec = describe "ResponseHeaders" $ do
+  with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do
+
+    let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)]
+
+    it "includes the headers in the response" $
+      forM_ methods $ \(method, expected) ->
+        Test.Hspec.Wai.request method "/" [] ""
+          `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]
+                                      , matchStatus  = expected
+                                      }
+
+    it "responds with not found for non-existent endpoints" $
+      forM_ methods $ \(method,_) ->
+        Test.Hspec.Wai.request method "blahblah" [] ""
+          `shouldRespondWith` 404
+
+    it "returns 415 if the Accept header is not supported" $
+      forM_ methods $ \(method,_) ->
+        Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
+          `shouldRespondWith` 415
+
+
+-- | Test server error functionality.
+errorsSpec :: Spec
+errorsSpec = do
+  let he = HttpError status409 (Just "A custom error")
+  let ib = InvalidBody "The body is invalid"
+  let wm = WrongMethod
+  let nf = NotFound
+
+  describe "Servant.Server.Internal.RouteMismatch" $ do
+    it "HttpError > *" $ do
+      ib <> he `shouldBe` he
+      wm <> he `shouldBe` he
+      nf <> he `shouldBe` he
+
+      he <> ib `shouldBe` he
+      he <> wm `shouldBe` he
+      he <> nf `shouldBe` he
+
+    it "HE > InvalidBody > (WM,NF)" $ do
+      he <> ib `shouldBe` he
+      wm <> ib `shouldBe` ib
+      nf <> ib `shouldBe` ib
+
+      ib <> he `shouldBe` he
+      ib <> wm `shouldBe` ib
+      ib <> nf `shouldBe` ib
+
+    it "HE > IB > WrongMethod > NF" $ do
+      he <> wm `shouldBe` he
+      ib <> wm `shouldBe` ib
+      nf <> wm `shouldBe` wm
+
+      wm <> he `shouldBe` he
+      wm <> ib `shouldBe` ib
+      wm <> nf `shouldBe` wm
+
+    it "* > NotFound" $ do
+      he <> nf `shouldBe` he
+      ib <> nf `shouldBe` ib
+      wm <> nf `shouldBe` wm
+
+      nf <> he `shouldBe` he
+      nf <> ib `shouldBe` ib
+      nf <> wm `shouldBe` wm

servant-server/test/Servant/Utils/StaticFilesSpec.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Servant.Utils.StaticFilesSpec where
+
+import Control.Exception (bracket)
+import Data.Proxy (Proxy(Proxy))
+import Network.Wai (Application)
+import System.Directory (getCurrentDirectory, setCurrentDirectory, createDirectory)
+import System.IO.Temp (withSystemTempDirectory)
+import Test.Hspec (Spec, describe, it, around_)
+import Test.Hspec.Wai (with, get, shouldRespondWith)
+
+import Servant.API (JSON)
+import Servant.API.Alternative ((:<|>)((:<|>)))
+import Servant.API.Capture (Capture)
+import Servant.API.Get (Get)
+import Servant.API.Raw (Raw)
+import Servant.API.Sub ((:>))
+import Servant.Server (Server, serve)
+import Servant.ServerSpec (Person(Person))
+import Servant.Utils.StaticFiles (serveDirectory)
+
+type Api =
+       "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person
+  :<|> "static" :> Raw
+
+
+api :: Proxy Api
+api = Proxy
+
+app :: Application
+app = serve api server
+
+server :: Server Api
+server =
+       (\ name_ -> return (Person name_ 42))
+  :<|> serveDirectory "static"
+
+withStaticFiles :: IO () -> IO ()
+withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir ->
+  bracket (setup tmpDir) teardown (const action)
+ where
+  setup tmpDir = do
+    outer <- getCurrentDirectory
+    setCurrentDirectory tmpDir
+    createDirectory "static"
+    writeFile "static/foo.txt" "bar"
+    writeFile "static/index.html" "index"
+    return outer
+
+  teardown outer = do
+    setCurrentDirectory outer
+
+spec :: Spec
+spec = do
+  around_ withStaticFiles $ with (return app) $ do
+    describe "serveDirectory" $ do
+      it "successfully serves files" $ do
+        get "/static/foo.txt" `shouldRespondWith` "bar"
+
+      it "serves the contents of index.html when requesting the root of a directory" $ do
+        get "/static/" `shouldRespondWith` "index"

servant-server/test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2014, Zalora South East Asia Pte Ltd
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Zalora South East Asia Pte Ltd nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

servant/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

servant/test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}