[wip] dynamic headers

cabal.project

@@ -4,8 +4,8 @@ packages: servant/
   servant-docs/
   servant-foreign/
   servant-server/
-  doc/tutorial/
-  doc/cookbook/*/*.cabal
+  -- doc/tutorial/
+  -- doc/cookbook/*/*.cabal
 
 allow-newer:
   servant-js:servant,

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

@@ -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.
--- Instead, use 'addOptionalHeader'.
+-- | Response Header objects where each header name is tracked at the type-level.
+--   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