Merge branch 'master' into servant-dates

# Conflicts:
#	servant-server/servant-server.cabal
#	servant-server/test/Servant/ServerSpec.hs

CONTRIBUTING.md

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

README.md

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

scripts/bump-versions.sh

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

scripts/clear-sandbox.sh

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

scripts/generate-nix-files.sh

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

scripts/start-sandbox.sh

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

scripts/test-all.sh

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

scripts/upload.sh

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

servant-blaze/include/overlapping-compat.h

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

servant-blaze/servant-blaze.cabal

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

servant-blaze/src/Servant/HTML/Blaze.hs

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

servant-cassava/include/overlapping-compat.h

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

servant-cassava/servant-cassava.cabal

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

servant-cassava/src/Servant/CSV/Cassava.hs

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

servant-client/include/overlapping-compat.h

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

servant-client/servant-client.cabal

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

servant-client/src/Servant/Client.hs

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

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

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

servant-client/test/Servant/ClientSpec.hs

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

servant-docs/README.md

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

servant-docs/include/overlapping-compat.h

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

servant-docs/servant-docs.cabal

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

servant-docs/src/Servant/Docs.hs

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

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

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

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

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

servant-docs/test/Servant/DocsSpec.hs

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

servant-examples/include/overlapping-compat.h

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

servant-foreign/include/overlapping-compat.h

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

servant-foreign/servant-foreign.cabal

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

servant-foreign/src/Servant/Foreign/Internal.hs

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

servant-foreign/test/Servant/ForeignSpec.hs

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

servant-js/include/overlapping-compat.h

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

servant-js/servant-js.cabal

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

servant-js/src/Servant/JS/Angular.hs

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

servant-js/src/Servant/JS/Axios.hs

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

servant-js/src/Servant/JS/JQuery.hs

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

servant-js/src/Servant/JS/Vanilla.hs

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

servant-lucid/include/overlapping-compat.h

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

servant-lucid/servant-lucid.cabal

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

servant-lucid/src/Servant/HTML/Lucid.hs

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

servant-mock/include/overlapping-compat.h

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

servant-mock/servant-mock.cabal

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

servant-mock/src/Servant/Mock.hs

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

servant-server/include/overlapping-compat.h

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

servant-server/servant-server.cabal

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

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

@@ -8,9 +8,8 @@
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeOperators              #-}
-#if !MIN_VERSION_base(4,8,0)
+
-{-# LANGUAGE OverlappingInstances       #-}
+#include "overlapping-compat.h"
-#endif
 
 module Servant.Server.Internal
   ( module Servant.Server.Internal
@@ -22,26 +21,33 @@ module Servant.Server.Internal
 #if !MIN_VERSION_base(4,8,0)
 import           Control.Applicative         ((<$>))
 #endif
-import           Control.Monad.Trans.Except  (ExceptT)
+import           Control.Monad.Trans.Except (ExceptT)
-import qualified Data.ByteString             as B
+import qualified Data.ByteString            as B
-import qualified Data.ByteString.Lazy        as BL
+import qualified Data.ByteString.Lazy       as BL
-import qualified Data.Map                    as M
+import qualified Data.Map                   as M
-import           Data.Maybe                  (fromMaybe, mapMaybe)
+import           Data.Maybe                 (fromMaybe, mapMaybe)
-import           Data.String                 (fromString)
+import           Data.String                (fromString)
-import           Data.String.Conversions     (ConvertibleStrings, cs, (<>))
+import           Data.String.Conversions    (cs, (<>))
-import           Data.Text                   (Text)
+import           Data.Text                  (Text)
 import           Data.Typeable
-import           GHC.TypeLits                (KnownSymbol, symbolVal)
+import           GHC.TypeLits               (KnownNat, KnownSymbol, natVal,
-import           Network.HTTP.Types          hiding (Header, ResponseHeaders)
+                                             symbolVal)
-import           Network.Socket              (SockAddr)
+import           Network.HTTP.Types         hiding (Header, ResponseHeaders)
-import           Network.Wai                 (Application, lazyRequestBody,
+import           Network.Socket             (SockAddr)
-                                              rawQueryString, requestHeaders,
+import           Network.Wai                (Application, Request, Response,
-                                              requestMethod, responseLBS, remoteHost,
+                                             httpVersion, isSecure,
-                                              isSecure, vault, httpVersion, Response,
+                                             lazyRequestBody, pathInfo,
-                                              Request, pathInfo)
+                                             rawQueryString, remoteHost,
+                                             requestHeaders, requestMethod,
+                                             responseLBS, vault)
+import           Web.HttpApiData            (FromHttpApiData)
+import           Web.HttpApiData.Internal   (parseHeaderMaybe,
+                                             parseQueryParamMaybe,
+                                             parseUrlPieceMaybe)
+
 import           Servant.API                 ((:<|>) (..), (:>), Capture,
-                                              Delete, Get, Header,
+                                              Verb, ReflectMethod(reflectMethod),
-                                              IsSecure(..), Patch, Post, Put,
+                                              IsSecure(..), Header,
                                               QueryFlag, QueryParam, QueryParams,
                                               Raw, RemoteHost, ReqBody, Vault)
 import           Servant.API.ContentTypes    (AcceptHeader (..),
@@ -56,8 +62,6 @@ import           Servant.Server.Internal.Router
 import           Servant.Server.Internal.RoutingApplication
 import           Servant.Server.Internal.ServantErr
 
-import           Web.HttpApiData          (FromHttpApiData)
-import           Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe)
 
 
 class HasServer layout where
@@ -132,8 +136,7 @@ allowedMethodHead method request = method == methodGet && requestMethod request
 allowedMethod :: Method -> Request -> Bool
 allowedMethod method request = allowedMethodHead method request || requestMethod request == method
 
-processMethodRouter :: forall a. ConvertibleStrings a B.ByteString
+processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method
-                    => Maybe (a, BL.ByteString) -> Status -> Method
                     -> Maybe [(HeaderName, B.ByteString)]
                     -> Request -> RouteResult Response
 processMethodRouter handleA status method headers request = case handleA of
@@ -163,7 +166,7 @@ methodRouter method proxy status action = LeafRouter route'
       | pathIsEmpty request =
           let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
           in runAction (action `addMethodCheck` methodCheck method request
-                               `addAcceptCheck` acceptCheck proxy  accH
+                               `addAcceptCheck` acceptCheck proxy accH
                        ) respond $ \ output -> do
                let handleA = handleAcceptH proxy (AcceptHeader accH) output
                processMethodRouter handleA status method Nothing request
@@ -179,113 +182,33 @@ methodRouterHeaders method proxy status action = LeafRouter route'
       | pathIsEmpty request =
           let accH    = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
           in runAction (action `addMethodCheck` methodCheck method request
-                               `addAcceptCheck` acceptCheck proxy  accH
+                               `addAcceptCheck` acceptCheck proxy accH
                        ) respond $ \ output -> do
                 let headers = getHeaders output
                     handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
                 processMethodRouter handleA status method (Just headers) request
       | otherwise = respond $ Fail err404
 
-methodRouterEmpty :: Method
+instance OVERLAPPABLE_
-                  -> Delayed (ExceptT ServantErr IO ())
+         ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
-                  -> Router
+         ) => HasServer (Verb method status ctypes a) where
-methodRouterEmpty method action = LeafRouter route'
-  where
-    route' request respond
-      | pathIsEmpty request = do
-          runAction (addMethodCheck action (methodCheck method request)) respond $ \ () ->
-            Route $! responseLBS noContent204 [] ""
-      | otherwise = respond $ Fail err404
 
--- | If you have a 'Delete' endpoint in your API,
+  type ServerT (Verb method status ctypes a) m = m a
--- the handler for this endpoint is meant to delete
--- a resource.
---
--- The code of the handler will, just like
--- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and
--- 'Servant.API.Put.Put', run in @ExceptT ServantErr IO ()@.
--- The 'Int' represents the status code and the 'String' a message
--- to be returned. You can use 'Control.Monad.Trans.Except.throwE' to
--- painlessly error out if the conditions for a successful deletion
--- are not met.
-instance
-#if MIN_VERSION_base(4,8,0)
-         {-# OVERLAPPABLE #-}
-#endif
-         ( AllCTRender ctypes a
-         ) => HasServer (Delete ctypes a) where
 
-  type ServerT (Delete ctypes a) m = m a
+  route Proxy = methodRouter method (Proxy :: Proxy ctypes) status
+    where method = reflectMethod (Proxy :: Proxy method)
+          status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
 
-  route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200
+instance OVERLAPPING_
+         ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
+         , GetHeaders (Headers h a)
+         ) => HasServer (Verb method status ctypes (Headers h a)) where
 
-instance
+  type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
-#if MIN_VERSION_base(4,8,0)
-         {-# OVERLAPPING #-}
-#endif
-         HasServer (Delete ctypes ()) where
 
-  type ServerT (Delete ctypes ()) m = m ()
+  route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status
-
+    where method = reflectMethod (Proxy :: Proxy method)
-  route Proxy = methodRouterEmpty methodDelete
+          status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
-
--- Add response headers
-instance
-#if MIN_VERSION_base(4,8,0)
-         {-# OVERLAPPING #-}
-#endif
-         ( GetHeaders (Headers h v), AllCTRender ctypes v
-         ) => HasServer (Delete ctypes (Headers h v)) where
-
-  type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)
-
-  route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200
-
--- | When implementing the handler for a 'Get' endpoint,
--- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
--- and 'Servant.API.Put.Put', the handler code runs in the
--- @ExceptT ServantErr IO@ monad, where the 'Int' represents
--- the status code and the 'String' a message, returned in case of
--- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'
--- to quickly fail if some conditions are not met.
---
--- If successfully returning a value, we use the type-level list, combined
--- with the request's @Accept@ header, to encode the value for you
--- (returning a status code of 200). If there was no @Accept@ header or it
--- was @*\/\*@, we return encode using the first @Content-Type@ type on the
--- list.
-instance
-#if MIN_VERSION_base(4,8,0)
-         {-# OVERLAPPABLE #-}
-#endif
-         ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where
-
-  type ServerT (Get ctypes a) m = m a
-
-  route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200
-
--- '()' ==> 204 No Content
-instance
-#if MIN_VERSION_base(4,8,0)
-         {-# OVERLAPPING #-}
-#endif
-          HasServer (Get ctypes ()) where
-
-  type ServerT (Get ctypes ()) m = m ()
-
-  route Proxy = methodRouterEmpty methodGet
-
--- Add response headers
-instance
-#if MIN_VERSION_base(4,8,0)
-         {-# OVERLAPPING #-}
-#endif
-          ( GetHeaders (Headers h v), AllCTRender ctypes v
-          ) => HasServer (Get ctypes (Headers h v)) where
-
-  type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
-
-  route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200
 
 -- | If you use 'Header' in one of the endpoints for your API,
 -- this automatically requires your server-side handler to be a function
@@ -318,140 +241,6 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
     in  route (Proxy :: Proxy sublayout) (passToServer subserver mheader)
     where str = fromString $ symbolVal (Proxy :: Proxy sym)
 
--- | When implementing the handler for a 'Post' endpoint,
--- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
--- and 'Servant.API.Put.Put', the handler code runs in the
--- @ExceptT ServantErr IO@ monad, where the 'Int' represents
--- the status code and the 'String' a message, returned in case of
--- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'
--- to quickly fail if some conditions are not met.
---
--- If successfully returning a value, we use the type-level list, combined
--- with the request's @Accept@ header, to encode the value for you
--- (returning a status code of 201). If there was no @Accept@ header or it
--- was @*\/\*@, we return encode using the first @Content-Type@ type on the
--- list.
-instance
-#if MIN_VERSION_base(4,8,0)
-         {-# OVERLAPPABLE #-}
-#endif
-         ( AllCTRender ctypes a
-         ) => HasServer (Post ctypes a) where
-
-  type ServerT (Post ctypes a) m = m a
-
-  route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201
-
-instance
-#if MIN_VERSION_base(4,8,0)
-         {-# OVERLAPPING #-}
-#endif
-         HasServer (Post ctypes ()) where
-
-  type ServerT (Post ctypes ()) m = m ()
-
-  route Proxy = methodRouterEmpty methodPost
-
--- Add response headers
-instance
-#if MIN_VERSION_base(4,8,0)
-         {-# OVERLAPPING #-}
-#endif
-         ( GetHeaders (Headers h v), AllCTRender ctypes v
-         ) => HasServer (Post ctypes (Headers h v)) where
-
-  type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
-
-  route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201
-
--- | When implementing the handler for a 'Put' endpoint,
--- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
--- and 'Servant.API.Post.Post', the handler code runs in the
--- @ExceptT ServantErr IO@ monad, where the 'Int' represents
--- the status code and the 'String' a message, returned in case of
--- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'
--- to quickly fail if some conditions are not met.
---
--- If successfully returning a value, we use the type-level list, combined
--- with the request's @Accept@ header, to encode the value for you
--- (returning a status code of 200). If there was no @Accept@ header or it
--- was @*\/\*@, we return encode using the first @Content-Type@ type on the
--- list.
-instance
-#if MIN_VERSION_base(4,8,0)
-         {-# OVERLAPPABLE #-}
-#endif
-         ( AllCTRender ctypes a) => HasServer (Put ctypes a) where
-
-  type ServerT (Put ctypes a) m = m a
-
-  route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200
-
-instance
-#if MIN_VERSION_base(4,8,0)
-         {-# OVERLAPPING #-}
-#endif
-         HasServer (Put ctypes ()) where
-
-  type ServerT (Put ctypes ()) m = m ()
-
-  route Proxy = methodRouterEmpty methodPut
-
--- Add response headers
-instance
-#if MIN_VERSION_base(4,8,0)
-         {-# OVERLAPPING #-}
-#endif
-         ( GetHeaders (Headers h v), AllCTRender ctypes v
-         ) => HasServer (Put ctypes (Headers h v)) where
-
-  type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
-
-  route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200
-
--- | When implementing the handler for a 'Patch' endpoint,
--- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
--- and 'Servant.API.Put.Put', the handler code runs in the
--- @ExceptT ServantErr IO@ monad, where the 'Int' represents
--- the status code and the 'String' a message, returned in case of
--- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'
--- to quickly fail if some conditions are not met.
---
--- If successfully returning a value, we just require that its type has
--- a 'ToJSON' instance and servant takes care of encoding it for you,
--- yielding status code 200 along the way.
-instance
-#if MIN_VERSION_base(4,8,0)
-         {-# OVERLAPPABLE #-}
-#endif
-         ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where
-
-  type ServerT (Patch ctypes a) m = m a
-
-  route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200
-
-instance
-#if MIN_VERSION_base(4,8,0)
-         {-# OVERLAPPING #-}
-#endif
-          HasServer (Patch ctypes ()) where
-
-  type ServerT (Patch ctypes ()) m = m ()
-
-  route Proxy = methodRouterEmpty methodPatch
-
--- Add response headers
-instance
-#if MIN_VERSION_base(4,8,0)
-         {-# OVERLAPPING #-}
-#endif
-         ( GetHeaders (Headers h v), AllCTRender ctypes v
-         ) => HasServer (Patch ctypes (Headers h v)) where
-
-  type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
-
-  route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200
-
 -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
 -- this automatically requires your server-side handler to be a function
 -- that takes an argument of type @'Maybe' 'Text'@.

servant-server/test/Doctests.hs

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

servant-server/test/Servant/Server/ErrorSpec.hs

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

servant-server/test/Servant/Server/Internal/EnterSpec.hs

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

servant-server/test/Servant/ServerSpec.hs

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

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

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

servant/CHANGELOG.md

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

servant/include/overlapping-compat.h

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

servant/servant.cabal

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

servant/src/Servant/API.hs

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

servant/src/Servant/API/ContentTypes.hs

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

servant/src/Servant/API/Delete.hs

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

servant/src/Servant/API/Get.hs

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

servant/src/Servant/API/Patch.hs

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

servant/src/Servant/API/Post.hs

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

servant/src/Servant/API/Put.hs

@@ -1,25 +0,0 @@
-{-# LANGUAGE DataKinds          #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE KindSignatures     #-}
-{-# OPTIONS_HADDOCK not-home    #-}
-module Servant.API.Put (Put) where
-
-import           Data.Typeable (Typeable)
-
--- | Endpoint for PUT requests, usually used to update a ressource.
--- The type @a@ is the type of the response body that's returned.
---
--- Example:
---
--- >>> -- PUT /books/:isbn
--- >>> -- with a Book as request body, returning the updated Book
--- >>> type MyApi = "books" :> Capture "isbn" Text :> ReqBody '[JSON] Book :> Put '[JSON] Book
-data Put (contentTypes :: [*]) a
-  deriving Typeable
-
--- $setup
--- >>> import Servant.API
--- >>> import Data.Aeson
--- >>> import Data.Text
--- >>> data Book
--- >>> instance ToJSON Book where { toJSON = undefined }

servant/src/Servant/API/ResponseHeaders.hs

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

servant/src/Servant/API/Verbs.hs

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

servant/src/Servant/Utils/Links.hs

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

servant/test/Doctests.hs

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

servant/test/Servant/Utils/LinksSpec.hs

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