Headers for all

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-client/src/Servant/Client.hs

@@ -21,6 +21,9 @@ module Servant.Client
   , 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,7 +35,9 @@ 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.ResponseHeaders
 import           Servant.API.ContentTypes
 import           Servant.Common.BaseUrl
 import           Servant.Common.Req
@@ -133,10 +138,10 @@ instance
   (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
   type Client' (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
   clientWithRoute Proxy req host =
-    performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host
+    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 #-}
@@ -146,6 +151,21 @@ instance
   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',
@@ -195,7 +215,7 @@ instance
   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.
@@ -208,6 +228,21 @@ instance
   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
@@ -220,7 +255,7 @@ instance
   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.
@@ -233,6 +268,21 @@ instance
   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
@@ -245,7 +295,7 @@ instance
   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.
@@ -258,6 +308,21 @@ instance
   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',
@@ -492,7 +557,7 @@ 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 req httpMethod host = do

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
+          headers = 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, headers, 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, headers, _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 (headers, 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
 
@@ -105,6 +109,7 @@ server = serve api (
   :<|> (\ name -> case name of
                    Just "alice" -> return alice
                    Just name -> left (400, name ++ " not found")
+
                    Nothing -> left (400, "missing parameter"))
   :<|> (\ names -> return (zipWith Person names [0..]))
   :<|> return
@@ -116,7 +121,8 @@ server = serve api (
   :<|> 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 +138,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 +158,8 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
  :<|> getMatrixFlag
  :<|> getRawSuccess
  :<|> getRawFailure
- :<|> getMultiple)
+ :<|> getMultiple
+ :<|> getRespHeaders)
     = client api
 
 type FailApi =
@@ -218,7 +228,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 +237,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 ->

servant-docs/example/greet.hs

@@ -8,6 +8,7 @@
 import Control.Lens
 import Data.Aeson
 import Data.Proxy
+import Data.ByteString.Conversion
 import Data.String.Conversions
 import Data.Text (Text)
 import GHC.Generics
@@ -53,14 +54,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 +88,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/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)
@@ -33,11 +40,13 @@ import           GHC.Generics
 import           GHC.TypeLits
 import           Servant.API
 import           Servant.API.ContentTypes
+import           Servant.API.ResponseHeaders
 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 +203,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 +215,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:
@@ -371,34 +386,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 +614,7 @@ markdown api = unlines $
           "#### Response:" :
           "" :
           ("- Status code " ++ show (resp ^. respStatus)) :
+          ("- Headers: " ++ show (resp ^. respHeaders)) :
           "" :
           formatTypes (resp ^. respTypes) ++
           bodies
@@ -630,7 +665,7 @@ instance HasDocs Delete where
           action' = action & response.respBody .~ []
                            & response.respStatus .~ 204
 
-instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
+instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
     => HasDocs (Get cts a) where
   docsFor Proxy (endpoint, action) =
     single endpoint' action'
@@ -641,6 +676,20 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
           t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
 
+instance (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 +699,7 @@ 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 (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
     => HasDocs (Post cts a) where
   docsFor Proxy (endpoint, action) =
     single endpoint' action'
@@ -662,7 +711,22 @@ 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 (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 (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
     => HasDocs (Put cts a) where
   docsFor Proxy (endpoint, action) =
     single endpoint' action'
@@ -674,6 +738,21 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
           t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
 
+instance (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 +835,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-server/src/Servant/Server/Internal.hs

@@ -46,7 +46,8 @@ 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)
 
 data ReqBodyState = Uncalled
@@ -335,7 +336,8 @@ 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)
 
@@ -450,7 +452,8 @@ 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)
 
@@ -532,7 +535,8 @@ 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)
 
@@ -612,7 +616,8 @@ 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)
 

servant/shell.nix

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

servant/src/Servant/API.hs

@@ -78,8 +78,9 @@ 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 (Headers, getHeaders,
-                                             , AddHeader(addHeader) )
+                                              getHeadersHList, getResponse,
+                                              buildHeadersTo, addHeader)
 import           Servant.API.Sub             ((:>))
 import           Servant.Common.Text         (FromText (..), ToText (..))
 import           Servant.Utils.Links         (HasLink (..), IsElem, IsElem',

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,22 @@
 -- The value is added to the header specified by the type (@Location@ in the
 -- example above).
 module Servant.API.ResponseHeaders
-    ( Headers
+    ( Headers(..)
+    , addHeader
+    , BuildHeadersTo(buildHeadersTo)
+    , GetHeaders(getHeaders)
+    , getHeadersHList
     , getResponse
-    , getHeaders
+    , HeaderValMap
-    , AddHeader(addHeader)
+    , 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 +51,101 @@ 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 (Header val `HCons` rest) = (headerName , toByteString' val):getHeaders rest
+      where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
+    getHeaders (UndecodableHeader h `HCons` rest) = (headerName,  h) : 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 +154,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.
 --