Fix servant-server

nix/shell.nix

@@ -1,5 +1,5 @@
 { pkgs ? import <nixpkgs> {}
-, compiler ? "ghc821"
+, compiler ? "ghc822"
 , tutorial ? false
 }:
 

servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
@@ -35,7 +36,8 @@ import           Servant.API                            ((:<|>) ((:<|>)), (:>),
                                                          BuildFromStream (..),
                                                          ByteStringParser (..),
                                                          Capture', CaptureAll,
-                                                         Description, EmptyAPI,
+                                                         Description, DynHeaders,
+                                                         EmptyAPI,
                                                          FramingUnrender (..),
                                                          Header', Headers (..),
                                                          HttpVersion, IsSecure,
@@ -97,6 +99,12 @@ clientIn p pm = clientWithRoute pm p defaultRequest
 class RunClient m => HasClient m api where
   type Client (m :: * -> *) (api :: *) :: *
   clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api
+  hoistClientMonad
+    :: Proxy m
+    -> Proxy api
+    -> (forall x. mon x -> mon' x)
+    -> Client mon api
+    -> Client mon' api
 
 
 -- | A client querying function for @a ':<|>' b@ will actually hand you
@@ -118,6 +126,10 @@ instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where
     clientWithRoute pm (Proxy :: Proxy a) req :<|>
     clientWithRoute pm (Proxy :: Proxy b) req
 
+  hoistClientMonad pm _ f (ca :<|> cb) =
+    hoistClientMonad pm (Proxy :: Proxy a) f ca :<|>
+    hoistClientMonad pm (Proxy :: Proxy b) f cb
+
 -- | Singleton type representing a client for an empty API.
 data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)
 
@@ -134,6 +146,7 @@ data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)
 instance RunClient m => HasClient m EmptyAPI where
   type Client m EmptyAPI = EmptyClient
   clientWithRoute _pm Proxy _ = EmptyClient
+  hoistClientMonad _ _ _ EmptyClient = EmptyClient
 
 -- | If you use a 'Capture' in one of your endpoints in your API,
 -- the corresponding querying function will automatically take
@@ -166,6 +179,9 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
 
     where p = (toUrlPiece val)
 
+  hoistClientMonad pm _ f cl = \a ->
+    hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
+
 -- | If you use a 'CaptureAll' in one of your endpoints in your API,
 -- the corresponding querying function will automatically take an
 -- additional argument of a list of the type specified by your
@@ -198,6 +214,9 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
 
     where ps = map (toUrlPiece) vals
 
+  hoistClientMonad pm _ f cl = \as ->
+    hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
+
 instance OVERLAPPABLE_
   -- Note [Non-Empty Content Types]
   ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
@@ -213,6 +232,8 @@ instance OVERLAPPABLE_
       accept = contentTypes (Proxy :: Proxy ct)
       method = reflectMethod (Proxy :: Proxy method)
 
+  hoistClientMonad _ _ f ma = f ma
+
 instance OVERLAPPING_
   ( RunClient m, ReflectMethod method
   ) => HasClient m (Verb method status cts NoContent) where
@@ -223,6 +244,8 @@ instance OVERLAPPING_
     return NoContent
       where method = reflectMethod (Proxy :: Proxy method)
 
+  hoistClientMonad _ _ f ma = f ma
+
 instance OVERLAPPING_
   -- Note [Non-Empty Content Types]
   ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
@@ -244,6 +267,8 @@ instance OVERLAPPING_
       where method = reflectMethod (Proxy :: Proxy method)
             accept = contentTypes (Proxy :: Proxy ct)
 
+  hoistClientMonad _ _ f ma = f ma
+
 instance OVERLAPPING_
   ( RunClient m, BuildHeadersTo ls, ReflectMethod method
   ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
@@ -256,6 +281,38 @@ instance OVERLAPPING_
                      , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
                      }
 
+  hoistClientMonad _ _ f ma = f ma
+
+instance OVERLAPPING_
+  ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
+  ) => HasClient m (Verb method status cts' (DynHeaders a)) where
+  type Client m (Verb method status cts' (DynHeaders a)) = m a
+  clientWithRoute _pm Proxy req = do
+    response <- runRequest req
+       { requestMethod = method
+       , requestAccept = fromList $ toList accept
+       }
+    case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of
+      Left err -> throwServantError $ DecodeFailure (pack err) response
+      Right val -> return val
+
+    where method = reflectMethod (Proxy :: Proxy method)
+          accept = contentTypes (Proxy :: Proxy ct)
+
+  hoistClientMonad _ _ f ma = f ma
+
+instance OVERLAPPING_
+  ( RunClient m, ReflectMethod method
+  ) => HasClient m (Verb method status cts (DynHeaders NoContent)) where
+  type Client m (Verb method status cts (DynHeaders NoContent)) = m NoContent
+  clientWithRoute _pm Proxy req = do
+    response <- runRequest req { requestMethod = method }
+    return NoContent
+
+    where method = reflectMethod (Proxy :: Proxy method)
+
+  hoistClientMonad _ _ f ma = f ma
+
 instance OVERLAPPABLE_
   ( RunClient m, MimeUnrender ct a, ReflectMethod method,
     FramingUnrender framing a, BuildFromStream a (f a)
@@ -304,6 +361,7 @@ instance OVERLAPPABLE_
           processResult (Left err, _) = Just (Left err)
       k go
 
+  hoistClientMonad _ _ f ma = f ma
 
 -- | If you use a 'Header' in one of your endpoints in your API,
 -- the corresponding querying function will automatically take
@@ -345,6 +403,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
       add :: a -> Request
       add value = addHeader hname value req
 
+  hoistClientMonad pm _ f cl = \arg ->
+    hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
+
 -- | Using a 'HttpVersion' combinator in your API doesn't affect the client
 -- functions.
 instance HasClient m api
@@ -356,18 +417,24 @@ instance HasClient m api
   clientWithRoute pm Proxy =
     clientWithRoute pm (Proxy :: Proxy api)
 
+  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
+
 -- | Ignore @'Summary'@ in client functions.
 instance HasClient m api => HasClient m (Summary desc :> api) where
   type Client m (Summary desc :> api) = Client m api
 
   clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
 
+  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
+
 -- | Ignore @'Description'@ in client functions.
 instance HasClient m api => HasClient m (Description desc :> api) where
   type Client m (Description desc :> api) = Client m api
 
   clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
 
+  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
+
 -- | 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',
@@ -410,6 +477,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
       pname :: Text
       pname  = pack $ symbolVal (Proxy :: Proxy sym)
 
+  hoistClientMonad pm _ f cl = \arg ->
+    hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
+
 -- | If you use a 'QueryParams' in one of your endpoints in your API,
 -- the corresponding querying function will automatically take
 -- an additional argument, a list of values of the type specified
@@ -453,6 +523,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
     where pname = pack $ symbolVal (Proxy :: Proxy sym)
           paramlist' = map (Just . toQueryParam) paramlist
 
+  hoistClientMonad pm _ f cl = \as ->
+    hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
+
 -- | If you use a 'QueryFlag' in one of your endpoints in your API,
 -- the corresponding querying function will automatically take
 -- an additional 'Bool' argument.
@@ -489,6 +562,8 @@ instance (KnownSymbol sym, HasClient m api)
 
     where paramname = pack $ symbolVal (Proxy :: Proxy sym)
 
+  hoistClientMonad pm _ f cl = \b ->
+    hoistClientMonad pm (Proxy :: Proxy api) f (cl b)
 
 -- | Pick a 'Method' and specify where the server you want to query is. You get
 -- back the full `Response`.
@@ -500,6 +575,8 @@ instance RunClient m => HasClient m Raw where
   clientWithRoute _pm Proxy req httpMethod = do
     runRequest req { requestMethod = httpMethod }
 
+  hoistClientMonad _ _ f cl = \meth -> f (cl meth)
+
 -- | If you use a 'ReqBody' in one of your endpoints in your API,
 -- the corresponding querying function will automatically take
 -- an additional argument of the type specified by your 'ReqBody'.
@@ -533,6 +610,9 @@ instance (MimeRender ct a, HasClient m api)
                                           req
                     )
 
+  hoistClientMonad pm _ f cl = \a ->
+    hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
+
 -- | Make the querying function append @path@ to the request path.
 instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
   type Client m (path :> api) = Client m api
@@ -543,30 +623,40 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
 
     where p = pack $ symbolVal (Proxy :: Proxy path)
 
+  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
+
 instance HasClient m api => HasClient m (Vault :> api) where
   type Client m (Vault :> api) = Client m api
 
   clientWithRoute pm Proxy req =
     clientWithRoute pm (Proxy :: Proxy api) req
 
+  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
+
 instance HasClient m api => HasClient m (RemoteHost :> api) where
   type Client m (RemoteHost :> api) = Client m api
 
   clientWithRoute pm Proxy req =
     clientWithRoute pm (Proxy :: Proxy api) req
 
+  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
+
 instance HasClient m api => HasClient m (IsSecure :> api) where
   type Client m (IsSecure :> api) = Client m api
 
   clientWithRoute pm Proxy req =
     clientWithRoute pm (Proxy :: Proxy api) req
 
+  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
+
 instance HasClient m subapi =>
   HasClient m (WithNamedContext name context subapi) where
 
   type Client m (WithNamedContext name context subapi) = Client m subapi
   clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
 
+  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
+
 instance ( HasClient m api
          ) => HasClient m (AuthProtect tag :> api) where
   type Client m (AuthProtect tag :> api)
@@ -575,6 +665,9 @@ instance ( HasClient m api
   clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) =
     clientWithRoute pm (Proxy :: Proxy api) (func val req)
 
+  hoistClientMonad pm _ f cl = \authreq ->
+    hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
+
 -- * Basic Authentication
 
 instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
@@ -583,6 +676,9 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
   clientWithRoute pm Proxy req val =
     clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req)
 
+  hoistClientMonad pm _ f cl = \bauth ->
+    hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
+
 
 {- Note [Non-Empty Content Types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

servant-client/src/Servant/Client/Internal/HttpClient.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TypeFamilies               #-}
 module Servant.Client.Internal.HttpClient where
@@ -70,6 +71,16 @@ mkClientEnv mgr burl = ClientEnv mgr burl Nothing
 client :: HasClient ClientM api => Proxy api -> Client ClientM api
 client api = api `clientIn` (Proxy :: Proxy ClientM)
 
+-- | Change the monad the client functions live in, by
+--   supplying a natural transformation.
+hoistClient
+  :: HasClient ClientM api
+  => Proxy api
+  -> (forall a. m a -> n a)
+  -> Client m api
+  -> Client n api
+hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)
+
 -- | @ClientM@ is the monad in which client functions run. Contains the
 -- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
 newtype ClientM a = ClientM

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

@@ -858,6 +858,22 @@ instance OVERLAPPING_
           status = fromInteger $ natVal (Proxy :: Proxy status)
           p = Proxy :: Proxy a
 
+instance OVERLAPPING_
+  ( ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
+  , ReflectMethod method
+  ) => HasDocs (Verb method status (ct ': cts) (DynHeaders a)) where
+  docsFor Proxy (endpoint, action) DocOptions{..} =
+    single endpoint' action'
+
+    where endpoint' = endpoint & method .~ method'
+          action'   = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
+                             & response.respTypes .~ allMime t
+                             & response.respStatus .~ status
+          t = Proxy :: Proxy (ct ': cts)
+          method' = reflectMethod (Proxy :: Proxy method)
+          status = fromInteger $ natVal (Proxy :: Proxy status)
+          p = Proxy :: Proxy a
+
 instance (KnownSymbol sym, HasDocs api)
       => HasDocs (Header' mods sym a :> api) where
   docsFor Proxy (endpoint, action) =

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

@@ -1,25 +1,24 @@
-{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE ConstraintKinds            #-}
+{-# LANGUAGE ConstraintKinds       #-}
-{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveDataTypeable    #-}
-{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE PolyKinds                  #-}
+{-# LANGUAGE PolyKinds             #-}
-{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE RankNTypes            #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE TupleSections         #-}
-{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE TypeOperators         #-}
-{-# LANGUAGE UndecidableInstances       #-}
 
 #if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
 #define HAS_TYPE_ERROR
 #endif
 
 #ifdef HAS_TYPE_ERROR
-{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE UndecidableInstances  #-}
 #endif
 
 #include "overlapping-compat.h"
@@ -34,71 +33,74 @@ module Servant.Server.Internal
   , module Servant.Server.Internal.ServantErr
   ) where
 
-import           Control.Monad              (join, when)
+import           Control.Monad
-import           Control.Monad.Trans        (liftIO)
+                 (join, when)
-import           Control.Monad.Trans.Resource (runResourceT)
+import           Control.Monad.Trans
-import qualified Data.ByteString            as B
+                 (liftIO)
-import qualified Data.ByteString.Builder    as BB
+import           Control.Monad.Trans.Resource
-import qualified Data.ByteString.Char8      as BC8
+                 (runResourceT)
-import qualified Data.ByteString.Lazy       as BL
+import qualified Data.ByteString                            as B
-import           Data.Maybe                 (fromMaybe, mapMaybe,
+import qualified Data.ByteString.Builder                    as BB
-                                             isNothing, maybeToList)
+import qualified Data.ByteString.Char8                      as BC8
-import           Data.Either                (partitionEithers)
+import qualified Data.ByteString.Lazy                       as BL
-import           Data.String                (IsString (..))
+import           Data.Either
-import           Data.String.Conversions    (cs, (<>))
+                 (partitionEithers)
-import           Data.Tagged                (Tagged(..), retag, untag)
+import qualified Data.Map.Strict                            as Map
-import qualified Data.Text                  as T
+import           Data.Maybe
+                 (fromMaybe, isNothing, mapMaybe, maybeToList)
+import           Data.String
+                 (IsString (..))
+import           Data.String.Conversions
+                 (cs, (<>))
+import           Data.Tagged
+                 (Tagged (..), retag, untag)
+import qualified Data.Text                                  as T
 import           Data.Typeable
-import           GHC.TypeLits               (KnownNat, KnownSymbol, natVal,
+import           GHC.TypeLits
-                                             symbolVal)
+                 (KnownNat, KnownSymbol, natVal, symbolVal)
-import           Network.HTTP.Types         hiding (Header, ResponseHeaders)
+import qualified Network.HTTP.Media                         as NHM
-import qualified Network.HTTP.Media         as NHM
+import           Network.HTTP.Types                         hiding
-import           Network.Socket             (SockAddr)
+                 (Header, ResponseHeaders)
-import           Network.Wai                (Application, Request,
+import           Network.Socket
-                                             httpVersion, isSecure,
+                 (SockAddr)
-                                             lazyRequestBody,
+import           Network.Wai
-                                             rawQueryString, remoteHost,
+                 (Application, Request, httpVersion, isSecure, lazyRequestBody,
-                                             requestHeaders, requestMethod,
+                 rawQueryString, remoteHost, requestHeaders, requestMethod,
-                                             responseLBS, responseStream,
+                 responseLBS, responseStream, vault)
-                                             vault)
+import           Prelude ()
-import           Prelude                    ()
 import           Prelude.Compat
-import           Web.HttpApiData            (FromHttpApiData, parseHeader,
+import           Servant.API
-                                             parseQueryParam,
+                 ((:<|>) (..), (:>), Accept (..), BasicAuth,
-                                             parseUrlPieceMaybe,
+                 BoundaryStrategy (..), Capture', CaptureAll, Description,
-                                             parseUrlPieces)
+                 EmptyAPI, FramingRender (..), Header', If, IsSecure (..),
-import           Servant.API                 ((:<|>) (..), (:>), BasicAuth, Capture',
+                 QueryFlag, QueryParam', QueryParams, Raw,
-                                              CaptureAll, Verb, EmptyAPI,
+                 ReflectMethod (reflectMethod), RemoteHost, ReqBody',
-                                              ReflectMethod(reflectMethod),
+                 SBool (..), SBoolI (..), Stream, StreamGenerator (..),
-                                              IsSecure(..), Header', QueryFlag,
+                 Summary, ToStreamGenerator (..), Vault, Verb,
-                                              QueryParam', QueryParams, Raw,
+                 WithNamedContext)
-                                              RemoteHost, ReqBody', Vault,
+import           Servant.API.ContentTypes
-                                              WithNamedContext,
+                 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
-                                              Description, Summary,
+                 AllMime, MimeRender (..), canHandleAcceptH)
-                                              Accept(..),
+import           Servant.API.Modifiers
-                                              FramingRender(..), Stream,
+                 (FoldLenient, FoldRequired, RequestArgument,
-                                              StreamGenerator(..), ToStreamGenerator(..),
+                 unfoldRequestArgument)
-                                              BoundaryStrategy(..),
+import           Servant.API.ResponseHeaders
-                                              If, SBool (..), SBoolI (..))
+                 (DynHeaders (..), GetHeaders, Headers, getHeaders,
-import           Servant.API.Modifiers       (unfoldRequestArgument, RequestArgument, FoldRequired, FoldLenient)
+                 getResponse)
-import           Servant.API.ContentTypes    (AcceptHeader (..),
+import           Web.HttpApiData
-                                              AllCTRender (..),
+                 (FromHttpApiData, parseHeader, parseQueryParam,
-                                              AllCTUnrender (..),
+                 parseUrlPieceMaybe, parseUrlPieces)
-                                              AllMime,
-                                              MimeRender(..),
-                                              canHandleAcceptH)
-import           Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
-                                              getResponse)
 
-import           Servant.Server.Internal.Context
 import           Servant.Server.Internal.BasicAuth
+import           Servant.Server.Internal.Context
 import           Servant.Server.Internal.Handler
 import           Servant.Server.Internal.Router
 import           Servant.Server.Internal.RoutingApplication
 import           Servant.Server.Internal.ServantErr
 
 #ifdef HAS_TYPE_ERROR
-import GHC.TypeLits (TypeError, ErrorMessage (..))
+import           GHC.TypeLits
+                 (ErrorMessage (..), TypeError)
 #endif
 
 class HasServer api context where
@@ -280,6 +282,17 @@ instance OVERLAPPING_
     where method = reflectMethod (Proxy :: Proxy method)
           status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
 
+instance OVERLAPPING_
+         ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
+         ) => HasServer (Verb method status ctypes (DynHeaders a)) context where
+
+  type ServerT (Verb method status ctypes (DynHeaders a)) m = m (DynHeaders a)
+  hoistServerWithContext _ _ nt s = nt s
+
+  route Proxy _ = methodRouter (\x -> (Map.toList (dynHeaders x), dynResponse x))
+                               method (Proxy :: Proxy ctypes) status
+    where method = reflectMethod (Proxy :: Proxy method)
+          status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
 
 instance OVERLAPPABLE_
          ( MimeRender ctype a, ReflectMethod method,
@@ -758,7 +771,7 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
 -- ...Maybe you haven't applied enough arguments to
 -- ...Capture' '[] "foo"
 -- ...
--- 
+--
 instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
   where
     type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)

servant/servant.cabal

@@ -71,6 +71,7 @@ library
   build-depends:
       base                  >= 4.7      && < 4.11
     , bytestring            >= 0.10.4.0 && < 0.11
+    , containers            >= 0.5      && < 0.6
     , mtl                   >= 2.1      && < 2.3
     , text                  >= 1.2.3.0  && < 1.3
 

servant/src/Servant/API.hs

@@ -109,10 +109,10 @@ import           Servant.API.RemoteHost
 import           Servant.API.ReqBody
                  (ReqBody, ReqBody')
 import           Servant.API.ResponseHeaders
-                 (AddHeader, BuildHeadersTo (buildHeadersTo),
+                 (AddHeader, BuildHeadersTo (buildHeadersTo), DynHeaders (..),
                  GetHeaders (getHeaders), HList (..), Headers (..),
                  ResponseHeader (..), addHeader, getHeadersHList, getResponse,
-                 noHeader)
+                 noHeader, withDynHeaders)
 import           Servant.API.Stream
                  (BoundaryStrategy (..), BuildFromStream (..),
                  ByteStringParser (..), FramingRender (..),

servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs

@@ -34,6 +34,7 @@ type ComprehensiveAPIWithoutRaw =
   ReqBody '[JSON] Int :> GET :<|>
   ReqBody' '[Lenient] '[JSON] Int :> GET :<|>
   Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>
+  Get '[JSON] (DynHeaders NoContent) :<|>
   "foo" :> GET :<|>
   Vault :> GET :<|>
   Verb 'POST 204 '[JSON] NoContent :<|>

servant/src/Servant/API/ResponseHeaders.hs

@@ -23,7 +23,8 @@
 -- The value is added to the header specified by the type (@Location@ in the
 -- example above).
 module Servant.API.ResponseHeaders
-    ( Headers(..)
+    ( -- * "Static" response headers, tracked at the type-level
+      Headers(..)
     , ResponseHeader (..)
     , AddHeader
     , addHeader
@@ -32,11 +33,17 @@ module Servant.API.ResponseHeaders
     , GetHeaders(getHeaders)
     , HeaderValMap
     , HList(..)
+
+    , -- * "Dynamic" response headers
+      DynHeaders(..)
+    , withDynHeaders
     ) where
 
 import           Data.ByteString.Char8     as BS
                  (ByteString, init, pack, unlines)
 import qualified Data.CaseInsensitive      as CI
+import           Data.Map
+                 (Map)
 import           Data.Proxy
 import           Data.Typeable
                  (Typeable)
@@ -51,8 +58,9 @@ import           Prelude.Compat
 import           Servant.API.Header
                  (Header)
 
--- | Response Header objects. You should never need to construct one directly.
+-- | Response Header objects where each header name is tracked at the type-level.
--- Instead, use 'addOptionalHeader'.
+--   You should never need to construct one directly. Instead, use
+--   'addOptionalHeader'.
 data Headers ls a = Headers { getResponse :: a
                             -- ^ The underlying value of a 'Headers'
                             , getHeadersHList :: HList ls
@@ -166,6 +174,23 @@ addHeader = addOptionalHeader . Header
 noHeader :: AddHeader h v orig new => orig -> new
 noHeader = addOptionalHeader MissingHeader
 
+-- | Combinator to use when you want your endpoint to return a response
+--   along with some response headers, dynamically,
+--   by simply building a value of type 'DynHeaders a', which is just a
+--   response of type @a@ along with a map from header names to header values.
+--
+--   For all other interpretations than the server one, this combinator basically
+--   has no effect and behaves just as if you were using @a@ directly.
+data DynHeaders a = DynHeaders
+  { dynResponse :: a
+  , dynHeaders  :: Map HTTP.HeaderName ByteString
+  } deriving (Typeable, Eq, Show, Functor)
+
+-- | Build a \"response with headers\", where the headers are
+--   provided at runtime as a 'Map' from header name to header value.
+withDynHeaders :: a -> Map HTTP.HeaderName ByteString -> DynHeaders a
+withDynHeaders = DynHeaders
+
 -- $setup
 -- >>> import Servant.API
 -- >>> import Data.Aeson