wip dynamic headers

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

@@ -36,7 +36,8 @@ import           Servant.API                            ((:<|>) ((:<|>)), (:>),
                                                          BuildFromStream (..),
                                                          ByteStringParser (..),
                                                          Capture', CaptureAll,
-                                                         Description, EmptyAPI,
+                                                         Description, DynHeaders,
+                                                         EmptyAPI,
                                                          FramingUnrender (..),
                                                          Header', Headers (..),
                                                          HttpVersion, IsSecure,
@@ -282,6 +283,36 @@ instance OVERLAPPING_
 
   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)

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

@@ -44,6 +44,7 @@ import qualified Data.ByteString.Lazy       as BL
 import           Data.Maybe                 (fromMaybe, mapMaybe,
                                              isNothing, maybeToList)
 import           Data.Either                (partitionEithers)
+import qualified Data.Map.Strict            as Map
 import           Data.String                (IsString (..))
 import           Data.String.Conversions    (cs, (<>))
 import           Data.Tagged                (Tagged(..), retag, untag)
@@ -88,7 +89,8 @@ import           Servant.API.ContentTypes    (AcceptHeader (..),
                                               MimeRender(..),
                                               canHandleAcceptH)
 import           Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
-                                              getResponse)
+                                              getResponse, DynHeaders,
+                                              DynResponse, withDynHeaders)
 
 import           Servant.Server.Internal.Context
 import           Servant.Server.Internal.BasicAuth
@@ -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 (DynResponse 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,

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

@@ -110,6 +110,7 @@ import           Servant.API.ReqBody
                  (ReqBody, ReqBody')
 import           Servant.API.ResponseHeaders
                  (AddHeader, BuildHeadersTo (buildHeadersTo),
+                 DynHeaders(..), DynResponse(..), withDynHeaders,
                  GetHeaders (getHeaders), HList (..), Headers (..),
                  ResponseHeader (..), addHeader, getHeadersHList, getResponse,
                  noHeader)

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,18 @@ module Servant.API.ResponseHeaders
     , GetHeaders(getHeaders)
     , HeaderValMap
     , HList(..)
+
+    , -- * "Dynamic" response headers
+      DynHeaders(..)
+    , DynResponse(..)
+    , 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 +59,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 +175,25 @@ 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 'DynResponse 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
+
+data DynResponse a = DynResponse
+  { 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 -> DynResponse a
+withDynHeaders = DynResponse
+
 -- $setup
 -- >>> import Servant.API
 -- >>> import Data.Aeson