From a701e8df23cbc3a79ff0bb10768025e4efb86d76 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Tue, 27 Mar 2018 12:24:54 +0200 Subject: [PATCH] wip dynamic headers --- nix/shell.nix | 2 +- .../Servant/Client/Core/Internal/HasClient.hs | 33 +++++++++++++++++- servant-docs/src/Servant/Docs/Internal.hs | 16 +++++++++ servant-server/src/Servant/Server/Internal.hs | 15 +++++++- servant/servant.cabal | 1 + servant/src/Servant/API.hs | 1 + .../API/Internal/Test/ComprehensiveAPI.hs | 1 + servant/src/Servant/API/ResponseHeaders.hs | 34 +++++++++++++++++-- 8 files changed, 97 insertions(+), 6 deletions(-) diff --git a/nix/shell.nix b/nix/shell.nix index 9c0cef9e..4e43c606 100644 --- a/nix/shell.nix +++ b/nix/shell.nix @@ -1,5 +1,5 @@ { pkgs ? import {} -, compiler ? "ghc821" +, compiler ? "ghc822" , tutorial ? false }: diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs index 55bfaddb..85f3e6d8 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs +++ b/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) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 4ba7c962..d49637e9 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/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) = diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 65b71a63..8cbe26f2 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/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, diff --git a/servant/servant.cabal b/servant/servant.cabal index 9ae471b9..483acf63 100644 --- a/servant/servant.cabal +++ b/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 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index d236b0da..0b84dea2 100644 --- a/servant/src/Servant/API.hs +++ b/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) diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index ed1b520c..df181b4c 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/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 :<|> diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index cd6f1ad6..21879d97 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/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