Merge pull request #57 from haskell-servant/jkarni/pre-0.3

Last tasks for 0.3

.gitignore

@@ -21,3 +21,4 @@ cabal.config
 *.prof
 *.aux
 *.hp
+Setup

scripts/shell.nix

@@ -13,10 +13,8 @@ let modifiedHaskellPackages = haskellngPackages.override {
             ../servant-jquery {}) "--ghc-options=-Werror";
         servant-docs     = appendConfigureFlag (self.callPackage ../servant-docs
             {}) "--ghc-options=-Werror";
-        servant-examples = appendConfigureFlag (self.callPackage ../servant-examples
-            {}) "--ghc-options=-Werror";
       };
     };
 in modifiedHaskellPackages.ghcWithPackages ( p : with p ; [
-    servant servant-server servant-client servant-jquery servant-docs servant-examples
+    servant servant-server servant-client servant-jquery servant-docs
 ])

scripts/start-sandbox.sh

@@ -0,0 +1,30 @@
+#!/bin/bash -
+#===============================================================================
+#
+#          FILE: start-sandbox.sh
+#
+#         USAGE: ./start-sandbox.sh
+#
+#   DESCRIPTION: Create sandbox at top-level and add all packages as add-source
+#
+#  REQUIREMENTS: bash >= 4
+#===============================================================================
+
+set -o nounset
+set -o errexit
+
+DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
+SOURCES_TXT="$( dirname $DIR)/sources.txt"
+CABAL=${CABAL:-cabal}
+
+declare -a SOURCES
+readarray -t SOURCES < "$SOURCES_TXT"
+
+prepare_sandbox () {
+    $CABAL sandbox init
+    for s in ${SOURCES[@]} ; do
+        (cd "$s" && $CABAL sandbox init --sandbox=../.cabal-sandbox && $CABAL sandbox add-source .)
+    done
+}
+
+prepare_sandbox

servant-blaze/LICENSE

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

servant-blaze/Setup.hs

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

servant-blaze/servant-blaze.cabal

@@ -0,0 +1,28 @@
+-- Initial servant-blaze.cabal generated by cabal init.  For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                servant-blaze
+version:             0.1.0.0
+synopsis:            Blaze-html support for servant
+-- description:
+homepage:            http://haskell-servant.github.io/
+license:             BSD3
+license-file:        LICENSE
+author:              Julian K. Arni
+maintainer:          jkarni@gmail.com
+-- copyright:
+category:            Web
+build-type:          Simple
+-- extra-source-files:
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Servant.HTML.Blaze
+  -- other-modules:
+  -- other-extensions:
+  build-depends:       base >=4.7 && <5
+                     , servant
+                     , http-media
+                     , blaze-html
+  hs-source-dirs:      src
+  default-language:    Haskell2010

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

@@ -0,0 +1,45 @@
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE DeriveDataTypeable    #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+#if !MIN_VERSION_base(4,8,0)
+{-# LANGUAGE OverlappingInstances  #-}
+#endif
+
+-- | 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
+-- `HTML` datatype.:
+--
+-- >>> type Eg = Get '[HTML] a
+--
+-- Will then check that @a@ has a `ToMarkup` instance, or is `Html`.
+module Servant.HTML.Blaze where
+
+import           Data.Typeable                 (Typeable)
+import qualified Network.HTTP.Media            as M
+import           Servant.API                   (Accept (..), MimeRender (..))
+import           Text.Blaze.Html               (Html, ToMarkup, toHtml)
+import           Text.Blaze.Html.Renderer.Utf8 (renderHtml)
+
+data HTML deriving Typeable
+
+-- | @text/plain;charset=utf-8@
+instance Accept HTML where
+    contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
+
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPABLE #-}
+#endif
+         ToMarkup a => MimeRender HTML a where
+    mimeRender _ = renderHtml . toHtml
+
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPING #-}
+#endif
+         MimeRender HTML Html where
+    mimeRender _ = renderHtml
+

servant-client/CHANGELOG.md

@@ -7,7 +7,7 @@
 * Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example)
 * Support for PATCH
 * Make () instances expect No Content status code, and not try to decode body.
-* `Canonicalize` API types before generating client functions for them
+* Add support for response headers
 
 0.2.2
 -----

servant-client/src/Servant/Client.hs

@@ -16,11 +16,13 @@
 module Servant.Client
   ( client
   , HasClient(..)
-  , Client
   , ServantError(..)
   , module Servant.Common.BaseUrl
   ) where
 
+#if !MIN_VERSION_base(4,8,0)
+import           Control.Applicative        ((<$>))
+#endif
 import           Control.Monad
 import           Control.Monad.Trans.Either
 import           Data.ByteString.Lazy       (ByteString)
@@ -32,8 +34,8 @@ import           GHC.TypeLits
 import           Network.HTTP.Client        (Response)
 import           Network.HTTP.Media
 import qualified Network.HTTP.Types         as H
+import qualified Network.HTTP.Types.Header  as HTTP
 import           Servant.API
-import           Servant.API.ContentTypes
 import           Servant.Common.BaseUrl
 import           Servant.Common.Req
 
@@ -50,17 +52,16 @@ import           Servant.Common.Req
 -- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
 -- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
 -- > (getAllBooks :<|> postNewBook) = client myApi
-client :: HasClient (Canonicalize layout) => Proxy layout -> Client layout
+client :: HasClient layout => Proxy layout -> Client layout
-client p = clientWithRoute (canonicalize p) defReq
+client p = clientWithRoute p defReq
 
 -- | This class lets us define how each API combinator
 -- influences the creation of an HTTP request. It's mostly
 -- an internal class, you can just use 'client'.
 class HasClient layout where
-  type Client' layout :: *
+  type Client layout :: *
-  clientWithRoute :: Proxy layout -> Req -> Client' layout
+  clientWithRoute :: Proxy layout -> Req -> Client layout
 
-type Client layout = Client' (Canonicalize layout)
 
 -- | A client querying function for @a ':<|>' b@ will actually hand you
 --   one function for querying @a@ and another one for querying @b@,
@@ -76,7 +77,7 @@ type Client layout = Client' (Canonicalize layout)
 -- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
 -- > (getAllBooks :<|> postNewBook) = client myApi
 instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
-  type Client' (a :<|> b) = Client' a :<|> Client' b
+  type Client (a :<|> b) = Client a :<|> Client b
   clientWithRoute Proxy req =
     clientWithRoute (Proxy :: Proxy a) req :<|>
     clientWithRoute (Proxy :: Proxy b) req
@@ -103,8 +104,8 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
 instance (KnownSymbol capture, ToText a, HasClient sublayout)
       => HasClient (Capture capture a :> sublayout) where
 
-  type Client' (Capture capture a :> sublayout) =
+  type Client (Capture capture a :> sublayout) =
-    a -> Client' sublayout
+    a -> Client sublayout
 
   clientWithRoute Proxy req val =
     clientWithRoute (Proxy :: Proxy sublayout) $
@@ -117,7 +118,7 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
 -- will just require an argument that specifies the scheme, host
 -- and port to send the request to.
 instance HasClient Delete where
-  type Client' Delete = BaseUrl -> EitherT ServantError IO ()
+  type Client Delete = BaseUrl -> EitherT ServantError IO ()
 
   clientWithRoute Proxy req host =
     void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host
@@ -131,21 +132,36 @@ instance
          {-# OVERLAPPABLE #-}
 #endif
   (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
-  type Client' (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
+  type Client (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
   clientWithRoute Proxy req host =
-    performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host
+    snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host
 
 -- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content
--- HTTP header.
+-- HTTP status.
 instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
   HasClient (Get (ct ': cts) ()) where
-  type Client' (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
+  type Client (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
   clientWithRoute Proxy req host =
     performRequestNoBody H.methodGet req [204] host
 
+-- | 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)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
+  clientWithRoute Proxy req host = do
+    (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] host
+    return $ Headers { getResponse = resp
+                     , 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',
@@ -174,8 +190,8 @@ instance
 instance (KnownSymbol sym, ToText a, HasClient sublayout)
       => HasClient (Header sym a :> sublayout) where
 
-  type Client' (Header sym a :> sublayout) =
+  type Client (Header sym a :> sublayout) =
-    Maybe a -> Client' sublayout
+    Maybe a -> Client sublayout
 
   clientWithRoute Proxy req mval =
     clientWithRoute (Proxy :: Proxy sublayout) $
@@ -192,10 +208,10 @@ instance
          {-# OVERLAPPABLE #-}
 #endif
   (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
-  type Client' (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
+  type Client (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
 
   clientWithRoute Proxy req uri =
-    performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri
+    snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri
 
 -- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content
 -- HTTP header.
@@ -204,10 +220,25 @@ instance
          {-# OVERLAPPING #-}
 #endif
   HasClient (Post (ct ': cts) ()) where
-  type Client' (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
+  type Client (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
   clientWithRoute Proxy req host =
     void $ performRequestNoBody H.methodPost req [204] host
 
+-- | 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)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
+  clientWithRoute Proxy req host = do
+    (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] host
+    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
@@ -217,10 +248,10 @@ instance
          {-# OVERLAPPABLE #-}
 #endif
   (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
-  type Client' (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
+  type Client (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
 
   clientWithRoute Proxy req host =
-    performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host
+    snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host
 
 -- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content
 -- HTTP header.
@@ -229,10 +260,25 @@ instance
          {-# OVERLAPPING #-}
 #endif
   HasClient (Put (ct ': cts) ()) where
-  type Client' (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
+  type Client (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
   clientWithRoute Proxy req host =
     void $ performRequestNoBody H.methodPut req [204] host
 
+-- | 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)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
+  clientWithRoute Proxy req host = do
+    (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] host
+    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
@@ -242,10 +288,10 @@ instance
          {-# OVERLAPPABLE #-}
 #endif
   (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
-  type Client' (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
+  type Client (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
 
   clientWithRoute Proxy req host =
-    performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host
+    snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host
 
 -- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content
 -- HTTP header.
@@ -254,10 +300,25 @@ instance
          {-# OVERLAPPING #-}
 #endif
   HasClient (Patch (ct ': cts) ()) where
-  type Client' (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
+  type Client (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
   clientWithRoute Proxy req host =
     void $ performRequestNoBody H.methodPatch req [204] host
 
+-- | 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)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
+  clientWithRoute Proxy req host = do
+    (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] host
+    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',
@@ -286,8 +347,8 @@ instance
 instance (KnownSymbol sym, ToText a, HasClient sublayout)
       => HasClient (QueryParam sym a :> sublayout) where
 
-  type Client' (QueryParam sym a :> sublayout) =
+  type Client (QueryParam sym a :> sublayout) =
-    Maybe a -> Client' sublayout
+    Maybe a -> Client sublayout
 
   -- if mparam = Nothing, we don't add it to the query string
   clientWithRoute Proxy req mparam =
@@ -328,8 +389,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
 instance (KnownSymbol sym, ToText a, HasClient sublayout)
       => HasClient (QueryParams sym a :> sublayout) where
 
-  type Client' (QueryParams sym a :> sublayout) =
+  type Client (QueryParams sym a :> sublayout) =
-    [a] -> Client' sublayout
+    [a] -> Client sublayout
 
   clientWithRoute Proxy req paramlist =
     clientWithRoute (Proxy :: Proxy sublayout) $
@@ -363,8 +424,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
 instance (KnownSymbol sym, HasClient sublayout)
       => HasClient (QueryFlag sym :> sublayout) where
 
-  type Client' (QueryFlag sym :> sublayout) =
+  type Client (QueryFlag sym :> sublayout) =
-    Bool -> Client' sublayout
+    Bool -> Client sublayout
 
   clientWithRoute Proxy req flag =
     clientWithRoute (Proxy :: Proxy sublayout) $
@@ -402,8 +463,8 @@ instance (KnownSymbol sym, HasClient sublayout)
 instance (KnownSymbol sym, ToText a, HasClient sublayout)
       => HasClient (MatrixParam sym a :> sublayout) where
 
-  type Client' (MatrixParam sym a :> sublayout) =
+  type Client (MatrixParam sym a :> sublayout) =
-    Maybe a -> Client' sublayout
+    Maybe a -> Client sublayout
 
   -- if mparam = Nothing, we don't add it to the query string
   clientWithRoute Proxy req mparam =
@@ -443,8 +504,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
 instance (KnownSymbol sym, ToText a, HasClient sublayout)
       => HasClient (MatrixParams sym a :> sublayout) where
 
-  type Client' (MatrixParams sym a :> sublayout) =
+  type Client (MatrixParams sym a :> sublayout) =
-    [a] -> Client' sublayout
+    [a] -> Client sublayout
 
   clientWithRoute Proxy req paramlist =
     clientWithRoute (Proxy :: Proxy sublayout) $
@@ -478,8 +539,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
 instance (KnownSymbol sym, HasClient sublayout)
       => HasClient (MatrixFlag sym :> sublayout) where
 
-  type Client' (MatrixFlag sym :> sublayout) =
+  type Client (MatrixFlag sym :> sublayout) =
-    Bool -> Client' sublayout
+    Bool -> Client sublayout
 
   clientWithRoute Proxy req flag =
     clientWithRoute (Proxy :: Proxy sublayout) $
@@ -492,9 +553,9 @@ instance (KnownSymbol sym, HasClient sublayout)
 -- | Pick a 'Method' and specify where the server you want to query is. You get
 -- back the full `Response`.
 instance HasClient Raw where
-  type Client' Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)
+  type Client Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
 
-  clientWithRoute :: Proxy Raw -> Req -> Client' Raw
+  clientWithRoute :: Proxy Raw -> Req -> Client Raw
   clientWithRoute Proxy req httpMethod host = do
     performRequest httpMethod req (const True) host
 
@@ -519,8 +580,8 @@ instance HasClient Raw where
 instance (MimeRender ct a, HasClient sublayout)
       => HasClient (ReqBody (ct ': cts) a :> sublayout) where
 
-  type Client' (ReqBody (ct ': cts) a :> sublayout) =
+  type Client (ReqBody (ct ': cts) a :> sublayout) =
-    a -> Client' sublayout
+    a -> Client sublayout
 
   clientWithRoute Proxy req body =
     clientWithRoute (Proxy :: Proxy sublayout) $ do
@@ -529,7 +590,7 @@ instance (MimeRender ct a, HasClient sublayout)
 
 -- | Make the querying function append @path@ to the request path.
 instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
-  type Client' (path :> sublayout) = Client' sublayout
+  type Client (path :> sublayout) = Client sublayout
 
   clientWithRoute Proxy req =
      clientWithRoute (Proxy :: Proxy sublayout) $

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

@@ -22,6 +22,7 @@ import Network.HTTP.Client hiding (Proxy)
 import Network.HTTP.Client.TLS
 import Network.HTTP.Media
 import Network.HTTP.Types
+import qualified Network.HTTP.Types.Header   as HTTP
 import Network.URI
 import Servant.API.ContentTypes
 import Servant.Common.BaseUrl
@@ -136,7 +137,9 @@ displayHttpRequest :: Method -> String
 displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
 
 
-performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)
+performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl
+               -> EitherT ServantError IO ( Int, ByteString, MediaType
+                                          , [HTTP.Header], Response ByteString)
 performRequest reqMethod req isWantedStatus reqHost = do
   partialRequest <- liftIO $ reqToRequest req reqHost
 
@@ -154,6 +157,7 @@ performRequest reqMethod req isWantedStatus reqHost = do
     Right response -> do
       let status = Client.responseStatus response
           body = Client.responseBody response
+          hrds = Client.responseHeaders response
           status_code = statusCode status
       ct <- case lookup "Content-Type" $ Client.responseHeaders response of
                  Nothing -> pure $ "application"//"octet-stream"
@@ -162,20 +166,19 @@ performRequest reqMethod req isWantedStatus reqHost = do
                    Just t' -> pure t'
       unless (isWantedStatus status_code) $
         left $ FailureResponse status ct body
-      return (status_code, body, ct, response)
+      return (status_code, body, ct, hrds, response)
+
 
 performRequestCT :: MimeUnrender ct result =>
-  Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO result
+  Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ([HTTP.Header], result)
 performRequestCT ct reqMethod req wantedStatus reqHost = do
   let acceptCT = contentType ct
-  (_status, respBody, respCT, _response) <-
+  (_status, respBody, respCT, hrds, _response) <-
     performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost
-  unless (matches respCT (acceptCT)) $
+  unless (matches respCT (acceptCT)) $ left $ UnsupportedContentType respCT respBody
-    left $ UnsupportedContentType respCT respBody
+  case mimeUnrender ct respBody of
-  either
+    Left err -> left $ DecodeFailure err respCT respBody
-    (left . (\s -> DecodeFailure s respCT respBody))
+    Right val -> return (hrds, val)
-    return
-    (mimeUnrender ct respBody)
 
 performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ()
 performRequestNoBody reqMethod req wantedStatus reqHost = do

servant-client/test/Servant/ClientSpec.hs

@@ -7,7 +7,7 @@
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeOperators      #-}
-{-# OPTIONS_GHC -fcontext-stack=25 #-}
+{-# OPTIONS_GHC -fcontext-stack=100 #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Servant.ClientSpec where
 
@@ -28,7 +28,8 @@ import qualified Data.Text                  as T
 import           GHC.Generics
 import qualified Network.HTTP.Client        as C
 import           Network.HTTP.Media
-import           Network.HTTP.Types
+import           Network.HTTP.Types         hiding (Header)
+import qualified Network.HTTP.Types         as HTTP
 import           Network.Socket
 import           Network.Wai                hiding (Response)
 import           Network.Wai.Handler.Warp
@@ -74,6 +75,8 @@ instance Eq C.HttpException where
 alice :: Person
 alice = Person "Alice" 42
 
+type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
+
 type Api =
        "get" :> Get '[JSON] Person
   :<|> "delete" :> Delete
@@ -93,6 +96,7 @@ type Api =
             QueryFlag "third" :>
             ReqBody '[JSON] [(String, [Rational])] :>
             Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
+  :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
 api :: Proxy Api
 api = Proxy
 
@@ -104,19 +108,20 @@ server = serve api (
   :<|> return
   :<|> (\ name -> case name of
                    Just "alice" -> return alice
-                   Just name -> left (400, name ++ " not found")
+                   Just name -> left $ ServantErr 400 (name ++ " not found") "" []
-                   Nothing -> left (400, "missing parameter"))
+                   Nothing -> left $ ServantErr 400 "missing parameter" "" [])
   :<|> (\ names -> return (zipWith Person names [0..]))
   :<|> return
   :<|> (\ name -> case name of
                    Just "alice" -> return alice
-                   Just name -> left (400, name ++ " not found")
+                   Just name -> left $ ServantErr 400 (name ++ " not found") "" []
-                   Nothing -> left (400, "missing parameter"))
+                   Nothing -> left $ ServantErr 400 "missing parameter" "" [])
   :<|> (\ names -> return (zipWith Person names [0..]))
   :<|> return
   :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
   :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
-  :<|> \ a b c d -> return (a, b, c, d)
+  :<|> (\ a b c d -> return (a, b, c, d))
+  :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
  )
 
 withServer :: (BaseUrl -> IO a) -> IO a
@@ -132,11 +137,14 @@ getQueryFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
 getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
 getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
 getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
-getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString)
+getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,
-getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString)
+        MediaType, [HTTP.Header], C.Response ByteString)
+getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,
+        MediaType, [HTTP.Header], C.Response ByteString)
 getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
   -> BaseUrl
   -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
+getRespHeaders :: BaseUrl -> EitherT ServantError IO (Headers TestHeaders Bool)
 (     getGet
  :<|> getDelete
  :<|> getCapture
@@ -149,7 +157,8 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
  :<|> getMatrixFlag
  :<|> getRawSuccess
  :<|> getRawFailure
- :<|> getMultiple)
+ :<|> getMultiple
+ :<|> getRespHeaders)
     = client api
 
 type FailApi =
@@ -218,7 +227,7 @@ spec = do
     res <- runEitherT (getRawSuccess methodGet host)
     case res of
       Left e -> assertFailure $ show e
-      Right (code, body, ct, response) -> do
+      Right (code, body, ct, _, response) -> do
         (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")
         C.responseBody response `shouldBe` body
         C.responseStatus response `shouldBe` ok200
@@ -227,11 +236,17 @@ spec = do
     res <- runEitherT (getRawFailure methodGet host)
     case res of
       Left e -> assertFailure $ show e
-      Right (code, body, ct, response) -> do
+      Right (code, body, ct, _, response) -> do
         (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream")
         C.responseBody response `shouldBe` body
         C.responseStatus response `shouldBe` badRequest400
 
+  it "Returns headers appropriately" $ withServer $ \ host -> do
+    res <- runEitherT (getRespHeaders host)
+    case res of
+      Left e -> assertFailure $ show e
+      Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
+
   modifyMaxSuccess (const 20) $ do
     it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
       property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
@@ -246,7 +261,7 @@ spec = do
     let test :: (WrappedApi, String) -> Spec
         test (WrappedApi api, desc) =
           it desc $
-          withWaiDaemon (return (serve api (left (500, "error message")))) $
+          withWaiDaemon (return (serve api (left $ ServantErr 500 "error message" "" []))) $
           \ host -> do
             let getResponse :: BaseUrl -> EitherT ServantError IO ()
                 getResponse = client api
@@ -292,8 +307,8 @@ spec = do
         _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
 
 data WrappedApi where
-  WrappedApi :: (HasServer (Canonicalize api), Server api ~ EitherT (Int, String) IO a,
+  WrappedApi :: (HasServer api, Server api ~ EitherT ServantErr IO a,
-                 HasClient (Canonicalize api), Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
+                 HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
     Proxy api -> WrappedApi
 
 

servant-docs/CHANGELOG.md

@@ -5,7 +5,9 @@
 * Render endpoints in a canonical order (https://github.com/haskell-servant/servant-docs/pull/15)
 * Remove ToJSON superclass from ToSample
 * Split out Internal module
-* `Canonicalize` API types before generating the docs for them
+* Add support for response headers
+* Allow `ToSample` to return a different type than it's arguments
+* Add Proxy argument to `ToSample`
 
 0.3
 ---

servant-docs/example/greet.hs

@@ -53,14 +53,17 @@ instance ToParam (MatrixParam "lang" String) where
                   "Get the greeting message selected language. Default is en."
                   Normal
 
-instance ToSample Greet where
+instance ToSample Greet Greet where
-  toSample = Just $ Greet "Hello, haskeller!"
+  toSample _ = Just $ Greet "Hello, haskeller!"
 
-  toSamples =
+  toSamples _ =
     [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")
     , ("If you use ?capital=false", Greet "Hello, haskeller")
     ]
 
+instance ToSample Int Int where
+  toSample _ = Just 1729
+
 -- We define some introductory sections, these will appear at the top of the
 -- documentation.
 --
@@ -84,7 +87,7 @@ type TestApi =
 
        -- POST /greet with a Greet as JSON in the request body,
        --             returns a Greet as JSON
-  :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
+  :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] (Headers '[Header "X-Example" Int] Greet)
 
        -- DELETE /greet/:greetid
   :<|> "greet" :> Capture "greetid" Text :> Delete

servant-docs/servant-docs.cabal

@@ -32,8 +32,11 @@ library
   build-depends:
       base >=4.7 && <5
     , bytestring
+    , bytestring-conversion
+    , case-insensitive
     , hashable
     , http-media >= 0.6
+    , http-types >= 0.7
     , lens
     , servant >= 0.2.1
     , string-conversions
@@ -50,6 +53,7 @@ executable greet-docs
   build-depends:
       base
     , aeson
+    , bytestring-conversion
     , lens
     , servant
     , servant-docs

servant-docs/src/Servant/Docs.hs

@@ -77,10 +77,10 @@
 -- >                   "Get the greeting message selected language. Default is en."
 -- >                   Normal
 -- >
--- > instance ToSample Greet where
+-- > instance ToSample Greet Greet where
--- >   toSample = Just $ Greet "Hello, haskeller!"
+-- >   toSample _ = Just $ Greet "Hello, haskeller!"
 -- >
--- >   toSamples =
+-- >   toSamples _ =
 -- >     [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")
 -- >     , ("If you use ?capital=false", Greet "Hello, haskeller")
 -- >     ]

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

@@ -1,9 +1,11 @@
-{-# LANGUAGE CPP                  #-}
 {-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE CPP                    #-}
 {-# LANGUAGE DataKinds              #-}
 {-# LANGUAGE DeriveGeneric          #-}
 {-# LANGUAGE FlexibleContexts       #-}
 {-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE OverloadedStrings      #-}
 {-# LANGUAGE PolyKinds              #-}
 {-# LANGUAGE ScopedTypeVariables    #-}
@@ -12,6 +14,9 @@
 {-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE TypeOperators          #-}
 {-# LANGUAGE UndecidableInstances   #-}
+#if !MIN_VERSION_base(4,8,0)
+{-# LANGUAGE OverlappingInstances   #-}
+#endif
 module Servant.Docs.Internal where
 
 #if !MIN_VERSION_base(4,8,0)
@@ -19,6 +24,7 @@ import           Control.Applicative
 #endif
 import           Control.Lens
 import           Data.ByteString.Lazy.Char8 (ByteString)
+import qualified Data.CaseInsensitive       as CI
 import           Data.Hashable
 import           Data.HashMap.Strict        (HashMap)
 import           Data.List
@@ -26,6 +32,7 @@ import           Data.Maybe
 import           Data.Monoid
 import           Data.Ord                   (comparing)
 import           Data.Proxy
+import           Data.ByteString.Conversion (ToByteString, toByteString)
 import           Data.String.Conversions
 import           Data.Text                  (Text, pack, unpack)
 import           GHC.Exts                   (Constraint)
@@ -38,6 +45,7 @@ import           Servant.Utils.Links
 import qualified Data.HashMap.Strict        as HM
 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
@@ -194,6 +202,7 @@ data Response = Response
   { _respStatus  :: Int
   , _respTypes   :: [M.MediaType]
   , _respBody    :: [(Text, M.MediaType, ByteString)]
+  , _respHeaders :: [HTTP.Header]
   } deriving (Eq, Ord, Show)
 
 -- | Default response: status code 200, no response body.
@@ -205,7 +214,12 @@ data Response = Response
 -- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
 -- > Response {_respStatus = 204, _respBody = Just "[]"}
 defResponse :: Response
-defResponse = Response 200 [] []
+defResponse = Response
+  { _respStatus  = 200
+  , _respTypes   = []
+  , _respBody    = []
+  , _respHeaders = []
+  }
 
 -- | A datatype that represents everything that can happen
 -- at an endpoint, with its lenses:
@@ -276,8 +290,8 @@ makeLenses ''Action
 
 -- | Generate the docs for a given API that implements 'HasDocs'. This is the
 -- default way to create documentation.
-docs :: HasDocs (Canonicalize layout) => Proxy layout -> API
+docs :: HasDocs layout => Proxy layout -> API
-docs p = docsFor (canonicalize p) (defEndpoint, defAction)
+docs p = docsFor p (defEndpoint, defAction)
 
 -- | Closed type family, check if endpoint is exactly within API.
 
@@ -321,11 +335,7 @@ extraInfo p action =
 -- 'extraInfo'.
 --
 -- If you only want to add an introduction, use 'docsWithIntros'.
-docsWith :: HasDocs (Canonicalize layout)
+docsWith :: HasDocs layout => [DocIntro] -> ExtraInfo layout -> Proxy layout -> API
-         => [DocIntro]
-         -> ExtraInfo layout
-         -> Proxy layout
-         -> API
 docsWith intros (ExtraInfo endpoints) p =
     docs p & apiIntros <>~ intros
            & apiEndpoints %~ HM.unionWith combineAction endpoints
@@ -333,7 +343,7 @@ docsWith intros (ExtraInfo endpoints) p =
 
 -- | Generate the docs for a given API that implements 'HasDocs' with with any
 -- number of introduction(s)
-docsWithIntros :: HasDocs (Canonicalize layout) => [DocIntro] -> Proxy layout -> API
+docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API
 docsWithIntros intros = docsWith intros mempty
 
 -- | The class that abstracts away the impact of API combinators
@@ -362,8 +372,8 @@ class HasDocs layout where
 -- > instance FromJSON Greet
 -- > instance ToJSON Greet
 -- >
--- > instance ToSample Greet where
+-- > instance ToSample Greet Greet where
--- >   toSample = Just g
+-- >   toSample _ = Just g
 -- >
 -- >     where g = Greet "Hello, haskeller!"
 --
@@ -371,34 +381,53 @@ class HasDocs layout where
 -- 'toSample': it lets you specify different responses along with
 -- some context (as 'Text') that explains when you're supposed to
 -- get the corresponding response.
-class ToSample a where
+class ToSample a b | a -> b where
   {-# MINIMAL (toSample | toSamples) #-}
-  toSample :: Maybe a
+  toSample :: Proxy a -> Maybe b
-  toSample = snd <$> listToMaybe samples
+  toSample _ = snd <$> listToMaybe samples
-    where samples = toSamples :: [(Text, a)]
+    where samples = toSamples (Proxy :: Proxy a)
 
-  toSamples :: [(Text, a)]
+  toSamples :: Proxy a -> [(Text, b)]
-  toSamples = maybe [] (return . ("",)) s
+  toSamples _ = maybe [] (return . ("",)) s
-    where s = toSample :: Maybe a
+    where s = toSample (Proxy :: Proxy a)
+
+instance ToSample a b => ToSample (Headers ls a) b where
+  toSample _  = toSample (Proxy :: Proxy a)
+  toSamples _ = toSamples (Proxy :: Proxy a)
+
+
+class AllHeaderSamples ls where
+    allHeaderToSample :: Proxy ls -> [HTTP.Header]
+
+instance AllHeaderSamples '[] where
+    allHeaderToSample _  = []
+
+instance (ToByteString l, AllHeaderSamples ls, ToSample l l, KnownSymbol h)
+    => AllHeaderSamples (Header h l ': ls) where
+    allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) :
+                          allHeaderToSample (Proxy :: Proxy ls)
+      where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)
+            mkHeader (Just x) = (headerName, cs $ toByteString x)
+            mkHeader Nothing  = (headerName, "<no header sample provided>")
 
 -- | 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 ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b)
     => Proxy ctypes
     -> Proxy a
     -> [(M.MediaType, ByteString)]
 sampleByteString ctypes@Proxy Proxy =
-    maybe [] (allMimeRender ctypes) (toSample :: Maybe a)
+    maybe [] (allMimeRender ctypes) $ toSample (Proxy :: Proxy a)
 
 -- | Synthesise a list of sample values of a particular type, encoded in the
 -- specified media types.
 sampleByteStrings
-    :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
+    :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b)
     => Proxy ctypes
     -> Proxy a
     -> [(Text, M.MediaType, ByteString)]
 sampleByteStrings ctypes@Proxy Proxy =
-    let samples = toSamples :: [(Text, a)]
+    let samples = toSamples (Proxy :: Proxy a)
         enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
     in concatMap enc samples
 
@@ -580,6 +609,7 @@ markdown api = unlines $
           "#### Response:" :
           "" :
           ("- Status code " ++ show (resp ^. respStatus)) :
+          ("- Headers: " ++ show (resp ^. respHeaders)) :
           "" :
           formatTypes (resp ^. respTypes) ++
           bodies
@@ -630,7 +660,11 @@ instance HasDocs Delete where
           action' = action & response.respBody .~ []
                            & response.respStatus .~ 204
 
-instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPABLe #-}
+#endif
+        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
     => HasDocs (Get cts a) where
   docsFor Proxy (endpoint, action) =
     single endpoint' action'
@@ -641,6 +675,24 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
           t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
 
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPING #-}
+#endif
+        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
+         , AllHeaderSamples ls , GetHeaders (HList ls) )
+    => HasDocs (Get cts (Headers ls a)) where
+  docsFor Proxy (endpoint, action) =
+    single endpoint' action'
+
+    where hdrs = allHeaderToSample (Proxy :: Proxy ls)
+          endpoint' = endpoint & method .~ DocGET
+          action' = action & response.respBody .~ sampleByteStrings t p
+                           & response.respTypes .~ supportedTypes 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) =
@@ -650,7 +702,11 @@ instance (KnownSymbol sym, HasDocs sublayout)
           action' = over headers (|> headername) action
           headername = pack $ symbolVal (Proxy :: Proxy sym)
 
-instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPABLE #-}
+#endif
+        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
     => HasDocs (Post cts a) where
   docsFor Proxy (endpoint, action) =
     single endpoint' action'
@@ -662,7 +718,30 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
           t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
 
-instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPING #-}
+#endif
+         (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
+         , AllHeaderSamples ls , GetHeaders (HList ls) )
+    => HasDocs (Post cts (Headers ls a)) where
+  docsFor Proxy (endpoint, action) =
+    single endpoint' action'
+
+    where hdrs = allHeaderToSample (Proxy :: Proxy ls)
+          endpoint' = endpoint & method .~ DocPOST
+          action' = action & response.respBody .~ sampleByteStrings t p
+                           & response.respTypes .~ supportedTypes 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 b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
     => HasDocs (Put cts a) where
   docsFor Proxy (endpoint, action) =
     single endpoint' action'
@@ -674,6 +753,25 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
           t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
 
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPING #-}
+#endif
+        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
+         , AllHeaderSamples ls , GetHeaders (HList ls) )
+    => HasDocs (Put cts (Headers ls a)) where
+  docsFor Proxy (endpoint, action) =
+    single endpoint' action'
+
+    where hdrs = allHeaderToSample (Proxy :: Proxy ls)
+          endpoint' = endpoint & method .~ DocPUT
+          action' = action & response.respBody .~ sampleByteStrings t p
+                           & response.respTypes .~ supportedTypes t
+                           & response.respStatus .~ 200
+                           & response.respHeaders .~ hdrs
+          t = Proxy :: Proxy cts
+          p = Proxy :: Proxy a
+
 instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
       => HasDocs (QueryParam sym a :> sublayout) where
 
@@ -756,7 +854,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, SupportedTypes cts)
+instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, HasDocs sublayout
+         , SupportedTypes cts)
       => HasDocs (ReqBody cts a :> sublayout) where
 
   docsFor Proxy (endpoint, action) =

servant-docs/test/Servant/DocsSpec.hs

@@ -46,14 +46,14 @@ data Datatype1 = Datatype1 { dt1field1 :: String
 
 instance ToJSON Datatype1
 
-instance ToSample Datatype1 where
+instance ToSample Datatype1 Datatype1 where
-  toSample = Just $ Datatype1 "field 1" 13
+  toSample _ = Just $ Datatype1 "field 1" 13
 
-instance ToSample String where
+instance ToSample String String where
-  toSample = Just "a string"
+  toSample _ = Just "a string"
 
-instance ToSample Int where
+instance ToSample Int Int where
-  toSample = Just 17
+  toSample _ = Just 17
 
 instance MimeRender PlainText Int where
   mimeRender _ = cs . show

servant-examples/auth-combinator/auth-combinator.hs

@@ -26,7 +26,7 @@ isGoodCookie = return . (== "good password")
 data AuthProtected
 
 instance HasServer rest => HasServer (AuthProtected :> rest) where
-  type ServerT' (AuthProtected :> rest) m = ServerT' rest m
+  type ServerT (AuthProtected :> rest) m = ServerT rest m
 
   route Proxy a request respond =
     case lookup "Cookie" (requestHeaders request) of

servant-jquery/src/Servant/JQuery.hs

@@ -26,8 +26,8 @@ import Data.Proxy
 import Servant.API
 import Servant.JQuery.Internal
 
-jquery :: HasJQ (Canonicalize layout) => Proxy layout -> JQ layout
+jquery :: HasJQ layout => Proxy layout -> JQ layout
-jquery p = jqueryFor (canonicalize p) defReq
+jquery p = jqueryFor p defReq
 
 -- js codegen
 generateJS :: AjaxReq -> String
@@ -112,6 +112,5 @@ instance GenerateCode rest => GenerateCode (AjaxReq :<|> rest) where
 -- | Directly generate all the javascript functions for your API
 --   from a 'Proxy' for your API type. You can then write it to
 --   a file or integrate it in a page, for example.
-jsForAPI :: (HasJQ (Canonicalize api), GenerateCode (JQ api))
+jsForAPI :: (HasJQ api, GenerateCode (JQ api)) => Proxy api -> String
-         => Proxy api -> String
 jsForAPI p = jsFor (jquery p)

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

@@ -194,14 +194,12 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where
   Elem a (b ': list) = Elem a list
 
 class HasJQ (layout :: *) where
-  type JQ' layout :: *
+  type JQ layout :: *
-  jqueryFor :: Proxy layout -> AjaxReq -> JQ' layout
+  jqueryFor :: Proxy layout -> AjaxReq -> JQ layout
-
-type JQ layout = JQ' (Canonicalize layout)
 
 instance (HasJQ a, HasJQ b)
       => HasJQ (a :<|> b) where
-  type JQ' (a :<|> b) = JQ' a :<|> JQ' b
+  type JQ (a :<|> b) = JQ a :<|> JQ b
 
   jqueryFor Proxy req =
          jqueryFor (Proxy :: Proxy a) req
@@ -209,7 +207,7 @@ instance (HasJQ a, HasJQ b)
 
 instance (KnownSymbol sym, HasJQ sublayout)
       => HasJQ (Capture sym a :> sublayout) where
-  type JQ' (Capture sym a :> sublayout) = JQ' sublayout
+  type JQ (Capture sym a :> sublayout) = JQ sublayout
 
   jqueryFor Proxy req =
     jqueryFor (Proxy :: Proxy sublayout) $
@@ -218,14 +216,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
     where str = symbolVal (Proxy :: Proxy sym)
 
 instance HasJQ Delete where
-  type JQ' Delete = AjaxReq
+  type JQ Delete = AjaxReq
 
   jqueryFor Proxy req =
     req & funcName  %~ ("delete" <>)
         & reqMethod .~ "DELETE"
 
 instance Elem JSON list => HasJQ (Get list a) where
-  type JQ' (Get list a) = AjaxReq
+  type JQ (Get list a) = AjaxReq
 
   jqueryFor Proxy req =
     req & funcName  %~ ("get" <>)
@@ -233,7 +231,7 @@ instance Elem JSON list => HasJQ (Get list a) where
 
 instance (KnownSymbol sym, HasJQ sublayout)
       => HasJQ (Header sym a :> sublayout) where
-  type JQ' (Header sym a :> sublayout) = JQ' sublayout
+  type JQ (Header sym a :> sublayout) = JQ sublayout
 
   jqueryFor Proxy req =
     jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname])
@@ -242,14 +240,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
           subP = Proxy :: Proxy sublayout
 
 instance Elem JSON list => HasJQ (Post list a) where
-  type JQ' (Post list a) = AjaxReq
+  type JQ (Post list a) = AjaxReq
 
   jqueryFor Proxy req =
     req & funcName  %~ ("post" <>)
         & reqMethod .~ "POST"
 
 instance Elem JSON list => HasJQ (Put list a) where
-  type JQ' (Put list a) = AjaxReq
+  type JQ (Put list a) = AjaxReq
 
   jqueryFor Proxy req =
     req & funcName  %~ ("put" <>)
@@ -257,7 +255,7 @@ instance Elem JSON list => HasJQ (Put list a) where
 
 instance (KnownSymbol sym, HasJQ sublayout)
       => HasJQ (QueryParam sym a :> sublayout) where
-  type JQ' (QueryParam sym a :> sublayout) = JQ' sublayout
+  type JQ (QueryParam sym a :> sublayout) = JQ sublayout
 
   jqueryFor Proxy req =
     jqueryFor (Proxy :: Proxy sublayout) $
@@ -267,7 +265,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
 
 instance (KnownSymbol sym, HasJQ sublayout)
       => HasJQ (QueryParams sym a :> sublayout) where
-  type JQ' (QueryParams sym a :> sublayout) = JQ' sublayout
+  type JQ (QueryParams sym a :> sublayout) = JQ sublayout
 
   jqueryFor Proxy req =
     jqueryFor (Proxy :: Proxy sublayout) $
@@ -277,7 +275,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
 
 instance (KnownSymbol sym, HasJQ sublayout)
       => HasJQ (QueryFlag sym :> sublayout) where
-  type JQ' (QueryFlag sym :> sublayout) = JQ' sublayout
+  type JQ (QueryFlag sym :> sublayout) = JQ sublayout
 
   jqueryFor Proxy req =
     jqueryFor (Proxy :: Proxy sublayout) $
@@ -287,7 +285,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
 
 instance (KnownSymbol sym, HasJQ sublayout)
       => HasJQ (MatrixParam sym a :> sublayout) where
-  type JQ' (MatrixParam sym a :> sublayout) = JQ' sublayout
+  type JQ (MatrixParam sym a :> sublayout) = JQ sublayout
 
   jqueryFor Proxy req =
     jqueryFor (Proxy :: Proxy sublayout) $
@@ -298,7 +296,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
 
 instance (KnownSymbol sym, HasJQ sublayout)
       => HasJQ (MatrixParams sym a :> sublayout) where
-  type JQ' (MatrixParams sym a :> sublayout) = JQ' sublayout
+  type JQ (MatrixParams sym a :> sublayout) = JQ sublayout
 
   jqueryFor Proxy req =
     jqueryFor (Proxy :: Proxy sublayout) $
@@ -308,7 +306,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
 
 instance (KnownSymbol sym, HasJQ sublayout)
       => HasJQ (MatrixFlag sym :> sublayout) where
-  type JQ' (MatrixFlag sym :> sublayout) = JQ' sublayout
+  type JQ (MatrixFlag sym :> sublayout) = JQ sublayout
 
   jqueryFor Proxy req =
     jqueryFor (Proxy :: Proxy sublayout) $
@@ -317,14 +315,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
     where str = symbolVal (Proxy :: Proxy sym)
 
 instance HasJQ Raw where
-  type JQ' Raw = Method -> AjaxReq
+  type JQ Raw = Method -> AjaxReq
 
   jqueryFor Proxy req method =
     req & funcName %~ ((toLower <$> method) <>)
         & reqMethod .~ method
 
 instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout) where
-  type JQ' (ReqBody list a :> sublayout) = JQ' sublayout
+  type JQ (ReqBody list a :> sublayout) = JQ sublayout
 
   jqueryFor Proxy req =
     jqueryFor (Proxy :: Proxy sublayout) $
@@ -332,7 +330,7 @@ instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout
 
 instance (KnownSymbol path, HasJQ sublayout)
       => HasJQ (path :> sublayout) where
-  type JQ' (path :> sublayout) = JQ' sublayout
+  type JQ (path :> sublayout) = JQ sublayout
 
   jqueryFor Proxy req =
     jqueryFor (Proxy :: Proxy sublayout) $

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

@@ -22,7 +22,7 @@ data Authorization (sym :: Symbol) a
 
 instance (KnownSymbol sym, HasJQ sublayout)
     => HasJQ (Authorization sym a :> sublayout) where
-    type JQ' (Authorization sym a :> sublayout) = JQ' sublayout
+    type JQ (Authorization sym a :> sublayout) = JQ sublayout
 
     jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
         req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $
@@ -35,7 +35,7 @@ data MyLovelyHorse a
 
 instance (HasJQ sublayout)
     => HasJQ (MyLovelyHorse a :> sublayout) where
-    type JQ' (MyLovelyHorse a :> sublayout) = JQ' sublayout
+    type JQ (MyLovelyHorse a :> sublayout) = JQ sublayout
 
     jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
         req & reqHeaders <>~ [ ReplaceHeaderArg "X-MyLovelyHorse" tpl ]
@@ -47,7 +47,7 @@ data WhatsForDinner a
 
 instance (HasJQ sublayout)
     => HasJQ (WhatsForDinner a :> sublayout) where
-    type JQ' (WhatsForDinner a :> sublayout) = JQ' sublayout
+    type JQ (WhatsForDinner a :> sublayout) = JQ sublayout
 
     jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
         req & reqHeaders <>~ [ ReplaceHeaderArg "X-WhatsForDinner" tpl ]

servant-lucid/LICENSE

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

servant-lucid/Setup.hs

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

servant-lucid/servant-lucid.cabal

@@ -0,0 +1,28 @@
+-- Initial servant-lucid.cabal generated by cabal init.  For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                servant-lucid
+version:             0.1.0.0
+synopsis:            Servant support for lucid
+-- description:
+homepage:            http://haskell-servant.github.io/
+license:             BSD3
+license-file:        LICENSE
+author:              Julian K. Arni
+maintainer:          jkarni@gmail.com
+-- copyright:
+category:            Web
+build-type:          Simple
+-- extra-source-files:
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Servant.HTML.Lucid
+  -- other-modules:
+  -- other-extensions:
+  build-depends:       base >=4.7 && <5
+                     , http-media
+                     , lucid
+                     , servant
+  hs-source-dirs:      src
+  default-language:    Haskell2010

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

@@ -0,0 +1,43 @@
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE DeriveDataTypeable    #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+#if !MIN_VERSION_base(4,8,0)
+{-# LANGUAGE OverlappingInstances  #-}
+#endif
+
+-- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s
+-- `ToHtml` class and `Html` datatype.
+-- You should only need to import this module for it's instances and the
+-- `HTML` datatype.:
+--
+-- >>> type Eg = Get '[HTML] a
+--
+-- Will then check that @a@ has a `ToHtml` instance, or is `Html`.
+module Servant.HTML.Lucid where
+
+import           Data.Typeable      (Typeable)
+import           Lucid              (Html, ToHtml (..), renderBS)
+import qualified Network.HTTP.Media as M
+import           Servant.API        (Accept (..), MimeRender (..))
+
+data HTML deriving Typeable
+
+-- | @text/plain;charset=utf-8@
+instance Accept HTML where
+    contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
+
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPABLE #-}
+#endif
+         ToHtml a => MimeRender HTML a where
+    mimeRender _ = renderBS . toHtml
+
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPING #-}
+#endif
+         MimeRender HTML (Html a) where
+    mimeRender _ = renderBS

servant-server/CHANGELOG.md

@@ -5,9 +5,11 @@
 * Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3*
 * Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29)
 * Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21)
-* Canonicalize API types before generating the handler types with `Server`
 * Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)
 * Add server support for response headers
+* Use `ServantErr` instead of `(Int,String)` in `EitherT` handlers
+* Add `errXXX` functions for HTTP errors with sensible default reason strings
+* Add `enter` function for applying natural transformations to handlers
 
 0.2.4
 -----

servant-server/servant-server.cabal

@@ -36,6 +36,8 @@ library
     Servant
     Servant.Server
     Servant.Server.Internal
+    Servant.Server.Internal.ServantErr
+    Servant.Server.Internal.Enter
     Servant.Utils.StaticFiles
   build-depends:
         base               >= 4.7  && < 5
@@ -45,6 +47,8 @@ library
       , either             >= 4.3  && < 4.4
       , http-types         >= 0.8  && < 0.9
       , network-uri        >= 2.6  && < 2.7
+      , mtl                >= 2    && < 3
+      , mmorph             >= 1
       , safe               >= 0.3  && < 0.4
       , servant            >= 0.2  && < 0.4
       , split              >= 0.2  && < 0.3
@@ -100,6 +104,18 @@ test-suite spec
     , temporary
     , text
     , transformers
+    , mtl
     , wai
     , wai-extra
     , warp
+
+test-suite doctests
+ build-depends: base
+              , servant
+              , doctest
+              , filemanip
+ type: exitcode-stdio-1.0
+ main-is: test/Doctests.hs
+ buildable: True
+ default-language: Haskell2010
+ ghc-options: -threaded

servant-server/src/Servant/Server.hs

@@ -1,6 +1,7 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE CPP               #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies      #-}
 
 -- | This module lets you implement 'Server's for defined APIs. You'll
 -- most likely just need 'serve'.
@@ -14,13 +15,73 @@ module Servant.Server
   , -- * Handlers for all standard combinators
     HasServer(..)
   , Server
-  , ServerT
+
+    -- * Enter
+    -- $enterDoc
+
+    -- ** Basic functions and datatypes
+  , enter
+  , (:~>)(..)
+    -- ** `Nat` utilities
+  , liftNat
+  , runReaderTNat
+  , evalStateTLNat
+  , evalStateTSNat
+  , logWriterTLNat
+  , logWriterTSNat
+#if MIN_VERSION_mtl(2,2,1)
+  , fromExceptT
+#endif
+  -- ** Functions based on <https://hackage.haskell.org/package/mmorph mmorph>
+  , hoistNat
+  , embedNat
+  , squashNat
+  , generalizeNat
+
+
+    -- * Default error type
+  , ServantErr(..)
+    -- ** 3XX
+  , err300
+  , err301
+  , err302
+  , err303
+  , err304
+  , err305
+  , err307
+    -- ** 4XX
+  , err400
+  , err401
+  , err402
+  , err403
+  , err404
+  , err405
+  , err406
+  , err407
+  , err409
+  , err410
+  , err411
+  , err412
+  , err413
+  , err414
+  , err415
+  , err416
+  , err417
+   -- * 5XX
+  , err500
+  , err501
+  , err502
+  , err503
+  , err504
+  , err505
+
   ) where
 
 import           Data.Proxy                         (Proxy)
 import           Network.Wai                        (Application)
-import Servant.API (Canonicalize, canonicalize)
 import           Servant.Server.Internal
+import           Servant.Server.Internal.Enter
+import           Servant.Server.Internal.ServantErr
 
 
 -- * Implementing Servers
@@ -45,5 +106,30 @@ import Servant.Server.Internal
 -- >
 -- > main :: IO ()
 -- > main = Network.Wai.Handler.Warp.run 8080 app
-serve :: HasServer (Canonicalize layout) => Proxy layout -> Server layout -> Application
+--
-serve p server = toApplication (route (canonicalize p) server)
+serve :: HasServer layout => Proxy layout -> Server layout -> Application
+serve p server = toApplication (route p server)
+
+
+-- Documentation
+
+-- $enterDoc
+-- Sometimes our cherished `EitherT` monad isn't quite the type you'd like for
+-- your handlers. Maybe you want to thread some configuration in a @Reader@
+-- monad. Or have your types ensure that your handlers don't do any IO. Enter
+-- `enter`.
+--
+-- With `enter`, you can provide a function, wrapped in the `(:~>)` / `Nat`
+-- newtype, to convert any number of endpoints from one type constructor to
+-- another. For example
+--
+-- >>> import Control.Monad.Reader
+-- >>> import qualified Control.Category as C
+-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String
+-- >>> let readerServer = return 1797 :<|> ask :: ServerT ReaderAPI (Reader String)
+-- >>> let mainServer = enter (generalizeNat C.. (runReaderTNat "hi")) readerServer :: Server ReaderAPI
+--
+
+-- $setup
+-- >>> import Servant.API
+-- >>> import Servant.Server

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

@@ -38,7 +38,7 @@ import           Network.Wai                 (Application, Request, Response,
                                               requestMethod, responseLBS,
                                               strictRequestBody)
 import           Servant.API                 ((:<|>) (..), (:>), Capture,
-                                              Canonicalize, Delete, Get, Header,
+                                               Delete, Get, Header,
                                               MatrixFlag, MatrixParam, MatrixParams,
                                               Patch, Post, Put, QueryFlag,
                                               QueryParam, QueryParams, Raw,
@@ -46,9 +46,12 @@ import           Servant.API                 ((:<|>) (..), (:>), Capture,
 import           Servant.API.ContentTypes    (AcceptHeader (..),
                                               AllCTRender (..),
                                               AllCTUnrender (..))
-import           Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)
+import           Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
+                                              getHeaders)
 import           Servant.Common.Text         (FromText, fromText)
 
+import           Servant.Server.Internal.ServantErr
+
 data ReqBodyState = Uncalled
                   | Called !B.ByteString
                   | Done !B.ByteString
@@ -174,13 +177,11 @@ processedPathInfo r =
   where pinfo = parsePathInfo r
 
 class HasServer layout where
-  type ServerT' layout (m :: * -> *) :: *
+  type ServerT layout (m :: * -> *) :: *
 
-  route :: Proxy layout -> Server' layout -> RoutingApplication
+  route :: Proxy layout -> Server layout -> RoutingApplication
 
-type Server layout = Server' (Canonicalize layout)
+type Server layout = ServerT layout (EitherT ServantErr IO)
-type Server' layout = ServerT' layout (EitherT (Int, String) IO)
-type ServerT layout m = ServerT' (Canonicalize layout) m
 
 -- * Instances
 
@@ -197,7 +198,7 @@ type ServerT layout m = ServerT' (Canonicalize layout) m
 -- >         postBook book = ...
 instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
 
-  type ServerT' (a :<|> b) m = ServerT' a m :<|> ServerT' b m
+  type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
 
   route Proxy (a :<|> b) request respond =
     route pa a request $ \mResponse ->
@@ -231,8 +232,8 @@ captured _ = fromText
 instance (KnownSymbol capture, FromText a, HasServer sublayout)
       => HasServer (Capture capture a :> sublayout) where
 
-  type ServerT' (Capture capture a :> sublayout) m =
+  type ServerT (Capture capture a :> sublayout) m =
-     a -> ServerT' sublayout m
+     a -> ServerT sublayout m
 
   route Proxy subserver request respond = case processedPathInfo request of
     (first : rest)
@@ -259,16 +260,14 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
 -- are not met.
 instance HasServer Delete where
 
-  type ServerT' Delete m = m ()
+  type ServerT Delete m = m ()
 
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodDelete = do
         e <- runEitherT action
         respond $ succeedWith $ case e of
-          Right () ->
+          Right () -> responseLBS status204 [] ""
-            responseLBS status204 [] ""
+          Left err -> responseServantErr err
-          Left (status, message) ->
-            responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodDelete =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
@@ -292,7 +291,7 @@ instance
 #endif
          ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where
 
-  type ServerT' (Get ctypes a) m = m a
+  type ServerT (Get ctypes a) m = m a
 
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodGet = do
@@ -304,8 +303,7 @@ instance
               Nothing -> failWith UnsupportedMediaType
               Just (contentT, body) -> succeedWith $
                 responseLBS ok200 [ ("Content-Type" , cs contentT)] body
-          Left (status, message) -> succeedWith $
+          Left err -> succeedWith $ responseServantErr err
-            responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodGet =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
@@ -317,15 +315,14 @@ instance
 #endif
           HasServer (Get ctypes ()) where
 
-  type ServerT' (Get ctypes ()) m = m ()
+  type ServerT (Get ctypes ()) m = m ()
 
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodGet = do
         e <- runEitherT action
         respond . succeedWith $ case e of
           Right () -> responseLBS noContent204 [] ""
-          Left (status, message) ->
+          Left err -> responseServantErr err
-            responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodGet =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
@@ -335,9 +332,10 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
-          ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where
+          ( 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)
+  type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
 
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodGet = do
@@ -350,8 +348,7 @@ instance
             Nothing -> failWith UnsupportedMediaType
             Just (contentT, body) -> succeedWith $
               responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
-        Left (status, message) -> succeedWith $
+        Left err -> succeedWith $ responseServantErr err
-          responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodGet =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
@@ -379,8 +376,8 @@ instance
 instance (KnownSymbol sym, FromText a, HasServer sublayout)
       => HasServer (Header sym a :> sublayout) where
 
-  type ServerT' (Header sym a :> sublayout) m =
+  type ServerT (Header sym a :> sublayout) m =
-    Maybe a -> ServerT' sublayout m
+    Maybe a -> ServerT sublayout m
 
   route Proxy subserver request respond = do
     let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
@@ -408,7 +405,7 @@ instance
          ( AllCTRender ctypes a
          ) => HasServer (Post ctypes a) where
 
-  type ServerT' (Post ctypes a) m = m a
+  type ServerT (Post ctypes a) m = m a
 
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodPost = do
@@ -420,8 +417,7 @@ instance
               Nothing -> failWith UnsupportedMediaType
               Just (contentT, body) -> succeedWith $
                 responseLBS status201 [ ("Content-Type" , cs contentT)] body
-          Left (status, message) -> succeedWith $
+          Left err -> succeedWith $ responseServantErr err
-            responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPost =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
@@ -432,15 +428,14 @@ instance
 #endif
          HasServer (Post ctypes ()) where
 
-  type ServerT' (Post ctypes ()) m = m ()
+  type ServerT (Post ctypes ()) m = m ()
 
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodPost = do
         e <- runEitherT action
         respond . succeedWith $ case e of
           Right () -> responseLBS noContent204 [] ""
-          Left (status, message) ->
+          Left err -> responseServantErr err
-            responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPost =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
@@ -450,9 +445,10 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
-         ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where
+         ( 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)
+  type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
 
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodPost = do
@@ -465,8 +461,7 @@ instance
             Nothing -> failWith UnsupportedMediaType
             Just (contentT, body) -> succeedWith $
               responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
-        Left (status, message) -> succeedWith $
+        Left err -> succeedWith $ responseServantErr err
-          responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPost =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
@@ -490,7 +485,7 @@ instance
 #endif
          ( AllCTRender ctypes a) => HasServer (Put ctypes a) where
 
-  type ServerT' (Put ctypes a) m = m a
+  type ServerT (Put ctypes a) m = m a
 
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodPut = do
@@ -502,8 +497,7 @@ instance
               Nothing -> failWith UnsupportedMediaType
               Just (contentT, body) -> succeedWith $
                 responseLBS status200 [ ("Content-Type" , cs contentT)] body
-          Left (status, message) -> succeedWith $
+          Left err -> succeedWith $ responseServantErr err
-            responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPut =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
@@ -514,15 +508,14 @@ instance
 #endif
          HasServer (Put ctypes ()) where
 
-  type ServerT' (Put ctypes ()) m = m ()
+  type ServerT (Put ctypes ()) m = m ()
 
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodPut = do
         e <- runEitherT action
         respond . succeedWith $ case e of
           Right () -> responseLBS noContent204 [] ""
-          Left (status, message) ->
+          Left err -> responseServantErr err
-            responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPut =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
@@ -532,9 +525,10 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
-         ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where
+         ( 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)
+  type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
 
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodPut = do
@@ -547,8 +541,7 @@ instance
             Nothing -> failWith UnsupportedMediaType
             Just (contentT, body) -> succeedWith $
               responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
-        Left (status, message) -> succeedWith $
+        Left err -> succeedWith $ responseServantErr err
-          responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPut =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
@@ -570,7 +563,7 @@ instance
 #endif
          ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where
 
-  type ServerT' (Patch ctypes a) m = m a
+  type ServerT (Patch ctypes a) m = m a
 
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodPatch = do
@@ -582,8 +575,7 @@ instance
               Nothing -> failWith UnsupportedMediaType
               Just (contentT, body) -> succeedWith $
                 responseLBS status200 [ ("Content-Type" , cs contentT)] body
-          Left (status, message) -> succeedWith $
+          Left err -> succeedWith $ responseServantErr err
-            responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPatch =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
@@ -594,15 +586,14 @@ instance
 #endif
           HasServer (Patch ctypes ()) where
 
-  type ServerT' (Patch ctypes ()) m = m ()
+  type ServerT (Patch ctypes ()) m = m ()
 
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodPatch = do
         e <- runEitherT action
         respond . succeedWith $ case e of
           Right () -> responseLBS noContent204 [] ""
-          Left (status, message) ->
+          Left err -> responseServantErr err
-            responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPatch =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
@@ -612,9 +603,10 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
-         ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where
+         ( 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)
+  type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
 
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodPatch = do
@@ -627,8 +619,7 @@ instance
             Nothing -> failWith UnsupportedMediaType
             Just (contentT, body) -> succeedWith $
               responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
-        Left (status, message) -> succeedWith $
+        Left err -> succeedWith $ responseServantErr err
-          responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPatch =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
@@ -657,8 +648,8 @@ instance
 instance (KnownSymbol sym, FromText a, HasServer sublayout)
       => HasServer (QueryParam sym a :> sublayout) where
 
-  type ServerT' (QueryParam sym a :> sublayout) m =
+  type ServerT (QueryParam sym a :> sublayout) m =
-    Maybe a -> ServerT' sublayout m
+    Maybe a -> ServerT sublayout m
 
   route Proxy subserver request respond = do
     let querytext = parseQueryText $ rawQueryString request
@@ -695,8 +686,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
 instance (KnownSymbol sym, FromText a, HasServer sublayout)
       => HasServer (QueryParams sym a :> sublayout) where
 
-  type ServerT' (QueryParams sym a :> sublayout) m =
+  type ServerT (QueryParams sym a :> sublayout) m =
-    [a] -> ServerT' sublayout m
+    [a] -> ServerT sublayout m
 
   route Proxy subserver request respond = do
     let querytext = parseQueryText $ rawQueryString request
@@ -728,8 +719,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
 instance (KnownSymbol sym, HasServer sublayout)
       => HasServer (QueryFlag sym :> sublayout) where
 
-  type ServerT' (QueryFlag sym :> sublayout) m =
+  type ServerT (QueryFlag sym :> sublayout) m =
-    Bool -> ServerT' sublayout m
+    Bool -> ServerT sublayout m
 
   route Proxy subserver request respond = do
     let querytext = parseQueryText $ rawQueryString request
@@ -771,8 +762,8 @@ parseMatrixText = parseQueryText
 instance (KnownSymbol sym, FromText a, HasServer sublayout)
       => HasServer (MatrixParam sym a :> sublayout) where
 
-  type ServerT' (MatrixParam sym a :> sublayout) m =
+  type ServerT (MatrixParam sym a :> sublayout) m =
-    Maybe a -> ServerT' sublayout m
+    Maybe a -> ServerT sublayout m
 
   route Proxy subserver request respond = case parsePathInfo request of
     (first : _)
@@ -809,8 +800,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
 instance (KnownSymbol sym, FromText a, HasServer sublayout)
       => HasServer (MatrixParams sym a :> sublayout) where
 
-  type ServerT' (MatrixParams sym a :> sublayout) m =
+  type ServerT (MatrixParams sym a :> sublayout) m =
-    [a] -> ServerT' sublayout m
+    [a] -> ServerT sublayout m
 
   route Proxy subserver request respond = case parsePathInfo request of
     (first : _)
@@ -843,8 +834,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
 instance (KnownSymbol sym, HasServer sublayout)
       => HasServer (MatrixFlag sym :> sublayout) where
 
-  type ServerT' (MatrixFlag sym :> sublayout) m =
+  type ServerT (MatrixFlag sym :> sublayout) m =
-    Bool -> ServerT' sublayout m
+    Bool -> ServerT sublayout m
 
   route Proxy subserver request respond =  case parsePathInfo request of
     (first : _)
@@ -872,7 +863,7 @@ instance (KnownSymbol sym, HasServer sublayout)
 -- > server = serveDirectory "/var/www/images"
 instance HasServer Raw where
 
-  type ServerT' Raw m = Application
+  type ServerT Raw m = Application
 
   route Proxy rawApplication request respond =
     rawApplication request (respond . succeedWith)
@@ -900,8 +891,8 @@ instance HasServer Raw where
 instance ( AllCTUnrender list a, HasServer sublayout
          ) => HasServer (ReqBody list a :> sublayout) where
 
-  type ServerT' (ReqBody list a :> sublayout) m =
+  type ServerT (ReqBody list a :> sublayout) m =
-    a -> ServerT' sublayout m
+    a -> ServerT sublayout m
 
   route Proxy subserver request respond = do
     -- See HTTP RFC 2616, section 7.2.1
@@ -921,7 +912,7 @@ instance ( AllCTUnrender list a, HasServer sublayout
 -- pass the rest of the request path to @sublayout@.
 instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
 
-  type ServerT' (path :> sublayout) m = ServerT' sublayout m
+  type ServerT (path :> sublayout) m = ServerT sublayout m
 
   route Proxy subserver request respond = case processedPathInfo request of
     (first : rest)

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

@@ -0,0 +1,105 @@
+{-# LANGUAGE CPP                    #-}
+{-# LANGUAGE DeriveDataTypeable     #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE RankNTypes             #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
+module Servant.Server.Internal.Enter where
+
+#if !MIN_VERSION_base(4,8,0)
+import           Control.Applicative
+#endif
+import qualified Control.Category            as C
+#if MIN_VERSION_mtl(2,2,1)
+import           Control.Monad.Except
+#endif
+import           Control.Monad.Identity
+import           Control.Monad.Morph
+import           Control.Monad.Reader
+import qualified Control.Monad.State.Lazy    as LState
+import qualified Control.Monad.State.Strict  as SState
+#if MIN_VERSION_mtl(2,2,1)
+import           Control.Monad.Trans.Either
+#endif
+import qualified Control.Monad.Writer.Lazy   as LWriter
+import qualified Control.Monad.Writer.Strict as SWriter
+import           Data.Typeable
+import           Servant.API
+
+class Enter typ arg ret | typ arg -> ret, typ ret -> arg where
+    enter :: arg -> typ -> ret
+
+-- **  Servant combinators
+instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2
+         , arg1 ~ arg2
+         ) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where
+    enter e (a :<|> b) = enter e a :<|> enter e b
+
+instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where
+    enter arg f a = enter arg (f a)
+
+-- ** Useful instances
+
+-- | A natural transformation from @m@ to @n@. Used to `enter` particular
+-- datatypes.
+newtype m :~> n = Nat { unNat :: forall a. m a -> n a} deriving Typeable
+
+instance C.Category (:~>) where
+    id = Nat id
+    Nat f . Nat g = Nat (f . g)
+
+instance Enter (m a) (m :~> n) (n a) where
+    enter (Nat f) = f
+
+-- | Like `lift`.
+liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m
+liftNat = Nat Control.Monad.Morph.lift
+
+runReaderTNat :: r -> (ReaderT r m :~> m)
+runReaderTNat a = Nat (`runReaderT` a)
+
+evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m)
+evalStateTLNat a = Nat (`LState.evalStateT` a)
+
+evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m)
+evalStateTSNat a = Nat (`SState.evalStateT` a)
+
+-- | Log the contents of `SWriter.WriterT` with the function provided as the
+-- first argument, and return the value of the @WriterT@ computation
+logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m)
+logWriterTSNat logger = Nat $ \x -> do
+    (a, w) <- SWriter.runWriterT x
+    liftIO $ logger w
+    return a
+
+-- | Like `logWriterTSNat`, but for strict @WriterT@.
+logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m)
+logWriterTLNat logger = Nat $ \x -> do
+    (a, w) <- LWriter.runWriterT x
+    liftIO $ logger w
+    return a
+
+#if MIN_VERSION_mtl(2,2,1)
+fromExceptT :: ExceptT e m :~> EitherT e m
+fromExceptT = Nat $ \x -> EitherT $ runExceptT x
+#endif
+
+-- | Like @mmorph@'s `hoist`.
+hoistNat :: (MFunctor t, Monad m) => (m :~> n) ->  (t m :~> t n)
+hoistNat (Nat n) = Nat $ hoist n
+
+-- | Like @mmorph@'s `embed`.
+embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n)
+embedNat (Nat n) = Nat $ embed n
+
+-- | Like @mmorph@'s `squash`.
+squashNat :: (Monad m, MMonad t) => t (t m) :~> t m
+squashNat = Nat squash
+
+-- | Like @mmorph@'s `generalize`.
+generalizeNat :: Applicative m => Identity :~> m
+generalizeNat = Nat (pure . runIdentity)

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

@@ -0,0 +1,229 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+module Servant.Server.Internal.ServantErr where
+
+import qualified Data.ByteString.Char8     as BS
+import qualified Data.ByteString.Lazy      as LBS
+import qualified Network.HTTP.Types        as HTTP
+import           Network.Wai               (responseLBS, Response)
+
+data ServantErr = ServantErr { errHTTPCode     :: Int
+                             , errReasonPhrase :: String
+                             , errBody         :: LBS.ByteString
+                             , errHeaders      :: [HTTP.Header]
+                             } deriving (Show, Eq)
+
+responseServantErr :: ServantErr -> Response
+responseServantErr ServantErr{..} = responseLBS status errHeaders errBody
+  where
+    status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase)
+
+err300 :: ServantErr
+err300 = ServantErr { errHTTPCode = 300
+                    , errReasonPhrase = "Multiple Choices"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err301 :: ServantErr
+err301 = ServantErr { errHTTPCode = 301
+                    , errReasonPhrase = "Moved Permanently"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err302 :: ServantErr
+err302 = ServantErr { errHTTPCode = 302
+                    , errReasonPhrase = "Found"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err303 :: ServantErr
+err303 = ServantErr { errHTTPCode = 303
+                    , errReasonPhrase = "See Other"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err304 :: ServantErr
+err304 = ServantErr { errHTTPCode = 304
+                    , errReasonPhrase = "Not Modified"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err305 :: ServantErr
+err305 = ServantErr { errHTTPCode = 305
+                    , errReasonPhrase = "Use Proxy"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err307 :: ServantErr
+err307 = ServantErr { errHTTPCode = 307
+                    , errReasonPhrase = "Temporary Redirect"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err400 :: ServantErr
+err400 = ServantErr { errHTTPCode = 400
+                    , errReasonPhrase = "Bad Request"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err401 :: ServantErr
+err401 = ServantErr { errHTTPCode = 401
+                    , errReasonPhrase = "Unauthorized"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err402 :: ServantErr
+err402 = ServantErr { errHTTPCode = 402
+                    , errReasonPhrase = "Payment Required"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err403 :: ServantErr
+err403 = ServantErr { errHTTPCode = 403
+                    , errReasonPhrase = "Forbidden"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err404 :: ServantErr
+err404 = ServantErr { errHTTPCode = 404
+                    , errReasonPhrase = "Not Found"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err405 :: ServantErr
+err405 = ServantErr { errHTTPCode = 405
+                    , errReasonPhrase = "Method Not Allowed"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err406 :: ServantErr
+err406 = ServantErr { errHTTPCode = 406
+                    , errReasonPhrase = "Not Acceptable"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err407 :: ServantErr
+err407 = ServantErr { errHTTPCode = 407
+                    , errReasonPhrase = "Proxy Authentication Required"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err409 :: ServantErr
+err409 = ServantErr { errHTTPCode = 409
+                    , errReasonPhrase = "Conflict"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err410 :: ServantErr
+err410 = ServantErr { errHTTPCode = 410
+                    , errReasonPhrase = "Gone"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err411 :: ServantErr
+err411 = ServantErr { errHTTPCode = 411
+                    , errReasonPhrase = "Length Required"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err412 :: ServantErr
+err412 = ServantErr { errHTTPCode = 412
+                    , errReasonPhrase = "Precondition Failed"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err413 :: ServantErr
+err413 = ServantErr { errHTTPCode = 413
+                    , errReasonPhrase = "Request Entity Too Large"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err414 :: ServantErr
+err414 = ServantErr { errHTTPCode = 414
+                    , errReasonPhrase = "Request-URI Too Large"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err415 :: ServantErr
+err415 = ServantErr { errHTTPCode = 415
+                    , errReasonPhrase = "Unsupported Media Type"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err416 :: ServantErr
+err416 = ServantErr { errHTTPCode = 416
+                    , errReasonPhrase = "Request range not satisfiable"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err417 :: ServantErr
+err417 = ServantErr { errHTTPCode = 417
+                    , errReasonPhrase = "Expectation Failed"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err500 :: ServantErr
+err500 = ServantErr { errHTTPCode = 500
+                    , errReasonPhrase = "Internal Server Error"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err501 :: ServantErr
+err501 = ServantErr { errHTTPCode = 501
+                    , errReasonPhrase = "Not Implemented"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err502 :: ServantErr
+err502 = ServantErr { errHTTPCode = 502
+                    , errReasonPhrase = "Bad Gateway"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err503 :: ServantErr
+err503 = ServantErr { errHTTPCode = 503
+                    , errReasonPhrase = "Service Unavailable"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err504 :: ServantErr
+err504 = ServantErr { errHTTPCode = 504
+                    , errReasonPhrase = "Gateway Time-out"
+                    , errBody = ""
+                    , errHeaders = []
+                    }
+
+err505 :: ServantErr
+err505 = ServantErr { errHTTPCode = 505
+                    , errReasonPhrase = "HTTP Version not supported"
+                    , errBody = ""
+                    , errHeaders = []
+                    }

servant-server/test/Doctests.hs

@@ -0,0 +1,18 @@
+module Main where
+
+import           System.FilePath.Find
+import           Test.DocTest
+
+main :: IO ()
+main = do
+    files <- find always (extension ==? ".hs") "src"
+    doctest $ [ "-isrc"
+              , "-optP-include"
+              , "-optPdist/build/autogen/cabal_macros.h"
+              , "-XOverloadedStrings"
+              , "-XFlexibleInstances"
+              , "-XMultiParamTypeClasses"
+              , "-XDataKinds"
+              , "-XTypeOperators"
+              ] ++ files
+

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

@@ -0,0 +1,59 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators     #-}
+module Servant.Server.Internal.EnterSpec where
+
+import qualified Control.Category              as C
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Either
+import           Data.Proxy
+import           Servant.API
+import           Servant.Server
+
+import           Test.Hspec                    (Spec, describe, it)
+import           Test.Hspec.Wai                (get, matchStatus, post,
+                                                shouldRespondWith, with)
+
+spec :: Spec
+spec = describe "module Servant.Server.Enter" $ do
+    enterSpec
+
+type ReaderAPI = "int" :> Get '[JSON] Int
+            :<|> "string" :> Post '[JSON] String
+
+type IdentityAPI = "bool" :> Get '[JSON] Bool
+
+type CombinedAPI = ReaderAPI :<|> IdentityAPI
+
+readerAPI :: Proxy ReaderAPI
+readerAPI = Proxy
+
+combinedAPI :: Proxy CombinedAPI
+combinedAPI = Proxy
+
+readerServer' :: ServerT ReaderAPI (Reader String)
+readerServer' = return 1797 :<|> ask
+
+fReader :: Reader String :~> EitherT ServantErr IO
+fReader = generalizeNat C.. (runReaderTNat "hi")
+
+readerServer :: Server ReaderAPI
+readerServer = enter fReader readerServer'
+
+combinedReaderServer' :: ServerT CombinedAPI (Reader String)
+combinedReaderServer' = readerServer' :<|> enter generalizeNat (return True)
+
+combinedReaderServer :: Server CombinedAPI
+combinedReaderServer = enter fReader combinedReaderServer'
+
+enterSpec :: Spec
+enterSpec = describe "Enter" $ do
+  with (return (serve readerAPI readerServer)) $ do
+
+    it "allows running arbitrary monads" $ do
+      get "int" `shouldRespondWith` "1797"
+      post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 }
+
+  with (return (serve combinedAPI combinedReaderServer)) $ do
+    it "allows combnation of enters" $ do
+      get "bool" `shouldRespondWith` "true"

servant-server/test/Servant/ServerSpec.hs

@@ -35,13 +35,13 @@ import           Test.Hspec.Wai             (get, liftIO, matchHeaders,
                                              shouldRespondWith, with, (<:>))
 
 import           Servant.API                ((:<|>) (..), (:>),
-                                             AddHeader (addHeader), Capture,
+                                             addHeader, Capture,
                                              Delete, Get, Header (..), Headers,
                                              JSON, MatrixFlag, MatrixParam,
                                              MatrixParams, Patch, PlainText,
                                              Post, Put, QueryFlag, QueryParam,
                                              QueryParams, Raw, ReqBody)
-import           Servant.Server             (Server, serve)
+import           Servant.Server             (Server, serve, ServantErr(..), err404)
 import           Servant.Server.Internal    (RouteMismatch (..))
 
 
@@ -96,11 +96,11 @@ spec = do
 type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
 captureApi :: Proxy CaptureApi
 captureApi = Proxy
-captureServer :: Integer -> EitherT (Int, String) IO Animal
+captureServer :: Integer -> EitherT ServantErr IO Animal
 captureServer legs = case legs of
   4 -> return jerry
   2 -> return tweety
-  _ -> left (404, "not found")
+  _ -> left err404
 
 captureSpec :: Spec
 captureSpec = do
@@ -450,11 +450,11 @@ headerApi = Proxy
 headerSpec :: Spec
 headerSpec = describe "Servant.API.Header" $ do
 
-    let expectsInt :: Maybe Int -> EitherT (Int,String) IO ()
+    let expectsInt :: Maybe Int -> EitherT ServantErr IO ()
         expectsInt (Just x) = when (x /= 5) $ error "Expected 5"
         expectsInt Nothing  = error "Expected an int"
 
-    let expectsString :: Maybe String -> EitherT (Int,String) IO ()
+    let expectsString :: Maybe String -> EitherT ServantErr IO ()
         expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
         expectsString Nothing  = error "Expected a string"
 

servant/CHANGELOG.md

@@ -1,6 +1,5 @@
 0.3
 ---
-* Add a `Canonicalize` type family that distributes all `:>`s inside `:<|>`s to get to the canonical type of an API -- which is then used in all other packages to avoid weird handler types in *servant-server*.
 * Multiple content-type/accept support for all the relevant combinators
 * Provide *JSON*, *PlainText*, *OctetStream* and *FormUrlEncoded* content types out of the box
 * Type-safe link generation to API endpoints

servant/shell.nix

@@ -0,0 +1,2 @@
+with (import <nixpkgs> {}).pkgs;
+(haskellngPackages.callPackage ./. {}).env

servant/src/Servant/API.hs

@@ -49,19 +49,14 @@ module Servant.API (
   module Servant.Common.Text,
   -- | Classes and instances for types that can be converted to and from @Text@
 
-  -- * Canonicalizing (flattening) API types
-  Canonicalize,
-  canonicalize,
-
   -- * Utilities
   module Servant.Utils.Links,
   -- | Type-safe internal URIs
   ) where
 
-import           Data.Proxy                  (Proxy (..))
 import           Servant.API.Alternative     ((:<|>) (..))
 import           Servant.API.Capture         (Capture)
-import           Servant.API.ContentTypes    (FormUrlEncoded,
+import           Servant.API.ContentTypes    (Accept (..), FormUrlEncoded,
                                               FromFormUrlEncoded (..), JSON,
                                               MimeRender (..),
                                               MimeUnrender (..), OctetStream,
@@ -78,40 +73,13 @@ import           Servant.API.QueryParam      (QueryFlag, QueryParam,
                                               QueryParams)
 import           Servant.API.Raw             (Raw)
 import           Servant.API.ReqBody         (ReqBody)
-import           Servant.API.ResponseHeaders ( Headers, getHeaders, getResponse
+import           Servant.API.ResponseHeaders (AddHeader (addHeader),
-                                             , AddHeader(addHeader) )
+                                              BuildHeadersTo (buildHeadersTo),
+                                              GetHeaders (getHeaders),
+                                              HList (..), Headers (..),
+                                              getHeadersHList, getResponse)
 import           Servant.API.Sub             ((:>))
 import           Servant.Common.Text         (FromText (..), ToText (..))
 import           Servant.Utils.Links         (HasLink (..), IsElem, IsElem',
                                               URI (..), safeLink)
 
--- | Turn an API type into its canonical form.
---
--- The canonical form of an API type is basically the all-flattened form
--- of the original type. More formally, it takes a type as input and hands you
--- back an /equivalent/ type formed of toplevel `:<|>`-separated chains of `:>`s,
--- i.e with all `:>`s distributed inside the `:<|>`s.
---
--- It basically turns:
---
--- > "hello" :> (Get Hello :<|> ReqBody Hello :> Put Hello)
---
--- into
---
--- > ("hello" :> Get Hello) :<|> ("hello" :> ReqBody Hello :> Put Hello)
---
--- i.e distributing all ':>'-separated bits into the subsequent ':<|>'s.
-type family Canonicalize api :: * where
-  -- requires UndecidableInstances
-  Canonicalize (a :> (b :<|> c)) = a :> Canonicalize b :<|> a :> Canonicalize c
-  Canonicalize ((a :<|> b) :> c) = a :> Canonicalize c :<|> b :> Canonicalize c
-  Canonicalize (a :> b)          = Redex b (Canonicalize b) a
-  Canonicalize (a :<|> b)        = Canonicalize a :<|> Canonicalize b
-  Canonicalize a                 = a
-
-type family Redex a b c :: * where
-  Redex a a first = Canonicalize first :> a
-  Redex a b first = Canonicalize (first :> b)
-
-canonicalize :: Proxy layout -> Proxy (Canonicalize layout)
-canonicalize Proxy = Proxy

servant/src/Servant/API/Alternative.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP                #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE TypeOperators      #-}
+{-# OPTIONS_HADDOCK not-home    #-}
 module Servant.API.Alternative ((:<|>)(..)) where
 
 #if !MIN_VERSION_base(4,8,0)

servant/src/Servant/API/Capture.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE PolyKinds          #-}
+{-# OPTIONS_HADDOCK not-home    #-}
 module Servant.API.Capture (Capture) where
 
 import           Data.Typeable (Typeable)

servant/src/Servant/API/ContentTypes.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
 {-# LANGUAGE UndecidableInstances  #-}
+{-# OPTIONS_HADDOCK not-home       #-}
 
 -- | A collection of basic Content-Types (also known as Internet Media
 -- Types, or MIME types). Additionally, this module provides classes that

servant/src/Servant/API/Delete.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS_HADDOCK not-home    #-}
 module Servant.API.Delete (Delete) where
 
 import Data.Typeable ( Typeable )

servant/src/Servant/API/Get.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE KindSignatures     #-}
+{-# OPTIONS_HADDOCK not-home    #-}
 module Servant.API.Get (Get) where
 
 import           Data.Typeable (Typeable)

servant/src/Servant/API/Header.hs

@@ -1,8 +1,11 @@
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor      #-}
 {-# LANGUAGE PolyKinds          #-}
+{-# OPTIONS_HADDOCK not-home    #-}
 module Servant.API.Header where
 
+import           Data.ByteString (ByteString)
 import           Data.Typeable   (Typeable)
 import           GHC.TypeLits    (Symbol)
 -- | Extract the given header's value as a value of type @a@.
@@ -14,7 +17,9 @@ import           GHC.TypeLits  (Symbol)
 -- >>>            -- GET /view-my-referer
 -- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer
 data Header (sym :: Symbol) a = Header a
-    deriving Typeable
+                              | MissingHeader
+                              | UndecodableHeader ByteString
+    deriving (Typeable, Eq, Show, Functor)
 
 -- $setup
 -- >>> import Servant.API

servant/src/Servant/API/MatrixParam.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE PolyKinds          #-}
+{-# OPTIONS_HADDOCK not-home    #-}
 module Servant.API.MatrixParam (MatrixFlag, MatrixParam, MatrixParams) where
 
 import           Data.Typeable (Typeable)

servant/src/Servant/API/Patch.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE KindSignatures     #-}
+{-# OPTIONS_HADDOCK not-home    #-}
 module Servant.API.Patch (Patch) where
 
 import           Data.Typeable (Typeable)

servant/src/Servant/API/Post.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE KindSignatures     #-}
+{-# OPTIONS_HADDOCK not-home    #-}
 module Servant.API.Post (Post) where
 
 import           Data.Typeable (Typeable)

servant/src/Servant/API/Put.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE KindSignatures     #-}
+{-# OPTIONS_HADDOCK not-home    #-}
 module Servant.API.Put (Put) where
 
 import Data.Typeable ( Typeable )

servant/src/Servant/API/QueryParam.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE TypeOperators      #-}
 {-# LANGUAGE PolyKinds          #-}
+{-# OPTIONS_HADDOCK not-home    #-}
 module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where
 
 import           Data.Typeable (Typeable)

servant/src/Servant/API/Raw.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS_HADDOCK not-home    #-}
 module Servant.API.Raw where
 
 import Data.Typeable (Typeable)

servant/src/Servant/API/ReqBody.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE PolyKinds          #-}
+{-# OPTIONS_HADDOCK not-home    #-}
 module Servant.API.ReqBody where
 
 import           Data.Typeable (Typeable)

servant/src/Servant/API/ResponseHeaders.hs

@@ -9,11 +9,13 @@
 {-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE PolyKinds              #-}
 {-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE TypeOperators          #-}
 {-# LANGUAGE UndecidableInstances   #-}
 #if !MIN_VERSION_base(4,8,0)
 {-# LANGUAGE OverlappingInstances   #-}
 #endif
+{-# OPTIONS_HADDOCK not-home        #-}
 
 -- | This module provides facilities for adding headers to a response.
 --
@@ -22,14 +24,20 @@
 -- The value is added to the header specified by the type (@Location@ in the
 -- example above).
 module Servant.API.ResponseHeaders
-    ( Headers
+    ( Headers(..)
-    , getResponse
-    , getHeaders
     , AddHeader(addHeader)
+    , BuildHeadersTo(buildHeadersTo)
+    , GetHeaders(getHeaders)
+    , HeaderValMap
+    , HList(..)
     ) where
 
-import           Data.ByteString.Char8       (pack)
+#if !MIN_VERSION_base(4,8,0)
-import           Data.ByteString.Conversion  (ToByteString, toByteString')
+import           Control.Applicative         ((<$>))
+#endif
+import           Data.ByteString.Char8       as BS (pack, unlines, init)
+import           Data.ByteString.Conversion  (ToByteString, toByteString',
+                                              FromByteString, fromByteString)
 import qualified Data.CaseInsensitive        as CI
 import           Data.Proxy
 import           GHC.TypeLits                (KnownSymbol, symbolVal)
@@ -41,27 +49,102 @@ import           Servant.API.Header          (Header (..))
 -- Instead, use 'addHeader'.
 data Headers ls a = Headers { getResponse :: a
                             -- ^ The underlying value of a 'Headers'
-                            , getHeaders :: [HTTP.Header]
+                            , getHeadersHList :: HList ls
-                            -- ^ The list of header values of a 'Headers'.
+                            -- ^ HList of headers.
-                            -- These are guaranteed to correspond with the
+                            } deriving (Functor)
-                            -- first type of @Headers@ if constructed with
-                            -- 'addHeader'.
-                            } deriving (Eq, Show, Functor)
 
--- We need all these fundeps to save type inference
+data HList a where
-class AddHeader h v orig new
+    HNil  :: HList '[]
-    | h v orig -> new, new -> h, new -> v, new -> orig where
+    HCons :: Header h x -> HList xs -> HList (Header h x ': xs)
-  addHeader :: v -> orig -> new
+
+type family HeaderValMap (f :: * -> *) (xs :: [*]) where
+    HeaderValMap f '[]                = '[]
+    HeaderValMap f (Header h x ': xs) = Header h (f x) ': (HeaderValMap f xs)
+
+
+class BuildHeadersTo hs where
+    buildHeadersTo :: [HTTP.Header] -> HList hs
+    -- ^ Note: if there are multiple occurences of a header in the argument,
+    -- the values are interspersed with commas before deserialization (see
+    -- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>)
 
 instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
-         ( KnownSymbol h, ToByteString v
+         BuildHeadersTo '[] where
+    buildHeadersTo _ = HNil
+
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPABLE #-}
+#endif
+         ( FromByteString v, BuildHeadersTo xs, KnownSymbol h, Contains h xs ~ 'False
+         ) => BuildHeadersTo ((Header h v) ': xs) where
+    buildHeadersTo headers =
+      let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
+          matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers
+      in case matching of
+        [] -> MissingHeader `HCons` buildHeadersTo headers
+        xs -> case fromByteString (BS.init $ BS.unlines xs) of
+          Nothing -> UndecodableHeader (BS.init $ BS.unlines xs)
+             `HCons` buildHeadersTo headers
+          Just h   -> Header h `HCons` buildHeadersTo headers
+
+-- * Getting
+
+class GetHeaders ls where
+    getHeaders :: ls -> [HTTP.Header]
+
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPING #-}
+#endif
+         GetHeaders (HList '[]) where
+    getHeaders _ = []
+
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPABLE #-}
+#endif
+         ( KnownSymbol h, ToByteString x, GetHeaders (HList xs)
+         ) => GetHeaders (HList (Header h x ': xs)) where
+    getHeaders hdrs = case hdrs of
+        Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest
+        UndecodableHeader h `HCons` rest -> (headerName,  h) : getHeaders rest
+        MissingHeader `HCons` rest -> getHeaders rest
+      where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
+
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPING #-}
+#endif
+         GetHeaders (Headers '[] a) where
+    getHeaders _ = []
+
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPABLE #-}
+#endif
+         ( KnownSymbol h, GetHeaders (HList rest), ToByteString v
+         ) => GetHeaders (Headers (Header h v ': rest) a) where
+    getHeaders hs = getHeaders $ getHeadersHList hs
+
+-- * Adding
+
+-- We need all these fundeps to save type inference
+class AddHeader h v orig new
+    | h v orig -> new, new -> h, new -> v, new -> orig where
+  addHeader :: v -> orig -> new  -- ^ N.B.: The same header can't be added multiple times
+
+
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPING #-}
+#endif
+         ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False
          ) => AddHeader h v (Headers (fst ': rest)  a) (Headers (Header h v  ': fst ': rest) a) where
-    addHeader a (Headers resp heads) = Headers resp ((headerName, toByteString' a) : heads)
+    addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads)
-      where
-        headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
 
 instance
 #if MIN_VERSION_base(4,8,0)
@@ -70,10 +153,12 @@ instance
          ( KnownSymbol h, ToByteString v
          , new ~ (Headers '[Header h v] a)
          ) => AddHeader h v a new where
-    addHeader a resp = Headers resp [(headerName, toByteString' a)]
+    addHeader a resp = Headers resp (HCons (Header a) HNil)
-      where
-        headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
 
+type family Contains x xs where
+    Contains x ((Header x a) ': xs) = 'True
+    Contains x ((Header y a) ': xs) = Contains x xs
+    Contains x '[]                  = 'False
 
 -- $setup
 -- >>> import Servant.API

servant/src/Servant/API/Sub.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE PolyKinds          #-}
 {-# LANGUAGE TypeOperators      #-}
+{-# OPTIONS_HADDOCK not-home    #-}
 module Servant.API.Sub ((:>)) where
 
 import           Data.Typeable (Typeable)

servant/src/Servant/Utils/Links.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE TypeOperators          #-}
 {-# LANGUAGE UndecidableInstances   #-}
+{-# OPTIONS_HADDOCK not-home        #-}
 
 -- | Type safe generation of internal links.
 --

sources.txt

@@ -4,3 +4,5 @@ servant-docs
 servant-jquery
 servant-server
 servant-examples
+servant-blaze
+servant-lucid