a701e8d · typeable/servant

git.iko.soy/typeable/servant

wip dynamic headers

commita701e8df23cbc3a79ff0bb10768025e4efb86d76 authorAlp Mestanogullari <alpmestan@gmail.com> dateTue 27 Mar 2018, 12:24 (9 years ago) parentdb2b6d3

8 files changed+97−6

compare with master

unifiedsplit

nix/shell.nix+1−1 servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs+32−1 servant-docs/src/Servant/Docs/Internal.hs+16 servant-server/src/Servant/Server/Internal.hs+14−1 servant/servant.cabal+1 servant/src/Servant/API.hs+1 servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs+1 servant/src/Servant/API/ResponseHeaders.hs+31−3

nix/shell.nix+1−1

@@ -1,5 +1,5 @@

11{ pkgs ? import <nixpkgs> {}

2−, compiler ? "ghc821"

2+, compiler ? "ghc822"

33, tutorial ? false

44}:

servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs+32−1

@@ -36,7 +36,8 @@ import Servant.API ((:<|>) ((:<|>)), (:>),

3636 BuildFromStream (..),

3737 ByteStringParser (..),

3838 Capture', CaptureAll,

39− Description, EmptyAPI,

39+ Description, DynHeaders,

40+ EmptyAPI,

4041 FramingUnrender (..),

4142 Header', Headers (..),

4243 HttpVersion, IsSecure,

@@ -282,6 +283,36 @@ instance OVERLAPPING_

282283

283284 hoistClientMonad _ _ f ma = f ma

284285

286+instance OVERLAPPING_

287+ ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

288+ ) => HasClient m (Verb method status cts' (DynHeaders a)) where

289+ type Client m (Verb method status cts' (DynHeaders a)) = m a

290+ clientWithRoute _pm Proxy req = do

291+ response <- runRequest req

292+ { requestMethod = method

293+ , requestAccept = fromList $ toList accept

294+ }

295+ case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of

296+ Left err -> throwServantError $ DecodeFailure (pack err) response

297+ Right val -> return val

298+

299+ where method = reflectMethod (Proxy :: Proxy method)

300+ accept = contentTypes (Proxy :: Proxy ct)

301+

302+ hoistClientMonad _ _ f ma = f ma

303+

304+instance OVERLAPPING_

305+ ( RunClient m, ReflectMethod method

306+ ) => HasClient m (Verb method status cts (DynHeaders NoContent)) where

307+ type Client m (Verb method status cts (DynHeaders NoContent)) = m NoContent

308+ clientWithRoute _pm Proxy req = do

309+ response <- runRequest req { requestMethod = method }

310+ return NoContent

311+

312+ where method = reflectMethod (Proxy :: Proxy method)

313+

314+ hoistClientMonad _ _ f ma = f ma

315+

285316instance OVERLAPPABLE_

286317 ( RunClient m, MimeUnrender ct a, ReflectMethod method,

287318 FramingUnrender framing a, BuildFromStream a (f a)

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

@@ -858,6 +858,22 @@ instance OVERLAPPING_

858858 status = fromInteger $ natVal (Proxy :: Proxy status)

859859 p = Proxy :: Proxy a

860860

861+instance OVERLAPPING_

862+ ( ToSample a, AllMimeRender (ct ': cts) a, KnownNat status

863+ , ReflectMethod method

864+ ) => HasDocs (Verb method status (ct ': cts) (DynHeaders a)) where

865+ docsFor Proxy (endpoint, action) DocOptions{..} =

866+ single endpoint' action'

867+

868+ where endpoint' = endpoint & method .~ method'

869+ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

870+ & response.respTypes .~ allMime t

871+ & response.respStatus .~ status

872+ t = Proxy :: Proxy (ct ': cts)

873+ method' = reflectMethod (Proxy :: Proxy method)

874+ status = fromInteger $ natVal (Proxy :: Proxy status)

875+ p = Proxy :: Proxy a

876+

861877instance (KnownSymbol sym, HasDocs api)

862878 => HasDocs (Header' mods sym a :> api) where

863879 docsFor Proxy (endpoint, action) =

servant-server/src/Servant/Server/Internal.hs+14−1

@@ -44,6 +44,7 @@ import qualified Data.ByteString.Lazy as BL

4444import Data.Maybe (fromMaybe, mapMaybe,

4545 isNothing, maybeToList)

4646import Data.Either (partitionEithers)

47+import qualified Data.Map.Strict as Map

4748import Data.String (IsString (..))

4849import Data.String.Conversions (cs, (<>))

4950import Data.Tagged (Tagged(..), retag, untag)

@@ -88,7 +89,8 @@ import Servant.API.ContentTypes (AcceptHeader (..),

8889 MimeRender(..),

8990 canHandleAcceptH)

9091import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,

91− getResponse)

92+ getResponse, DynHeaders,

93+ DynResponse, withDynHeaders)

9294

9395import Servant.Server.Internal.Context

9496import Servant.Server.Internal.BasicAuth

@@ -280,6 +282,17 @@ instance OVERLAPPING_

280282 where method = reflectMethod (Proxy :: Proxy method)

281283 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

282284

285+instance OVERLAPPING_

286+ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

287+ ) => HasServer (Verb method status ctypes (DynHeaders a)) context where

288+

289+ type ServerT (Verb method status ctypes (DynHeaders a)) m = m (DynResponse a)

290+ hoistServerWithContext _ _ nt s = nt s

291+

292+ route Proxy _ = methodRouter (\x -> (Map.toList (dynHeaders x), dynResponse x))

293+ method (Proxy :: Proxy ctypes) status

294+ where method = reflectMethod (Proxy :: Proxy method)

295+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

283296

284297instance OVERLAPPABLE_

285298 ( MimeRender ctype a, ReflectMethod method,

servant/servant.cabal+1

@@ -71,6 +71,7 @@ library

7171 build-depends:

7272 base >= 4.7 && < 4.11

7373 , bytestring >= 0.10.4.0 && < 0.11

74+ , containers >= 0.5 && < 0.6

7475 , mtl >= 2.1 && < 2.3

7576 , text >= 1.2.3.0 && < 1.3

7677

servant/src/Servant/API.hs+1

@@ -110,6 +110,7 @@ import Servant.API.ReqBody

110110 (ReqBody, ReqBody')

111111import Servant.API.ResponseHeaders

112112 (AddHeader, BuildHeadersTo (buildHeadersTo),

113+ DynHeaders(..), DynResponse(..), withDynHeaders,

113114 GetHeaders (getHeaders), HList (..), Headers (..),

114115 ResponseHeader (..), addHeader, getHeadersHList, getResponse,

115116 noHeader)

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

@@ -34,6 +34,7 @@ type ComprehensiveAPIWithoutRaw =

3434 ReqBody '[JSON] Int :> GET :<|>

3535 ReqBody' '[Lenient] '[JSON] Int :> GET :<|>

3636 Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>

37+ Get '[JSON] (DynHeaders NoContent) :<|>

3738 "foo" :> GET :<|>

3839 Vault :> GET :<|>

3940 Verb 'POST 204 '[JSON] NoContent :<|>

servant/src/Servant/API/ResponseHeaders.hs+31−3

@@ -23,7 +23,8 @@

2323-- The value is added to the header specified by the type (@Location@ in the

2424-- example above).

2525module Servant.API.ResponseHeaders

26− ( Headers(..)

26+ ( -- * "Static" response headers, tracked at the type-level

27+ Headers(..)

2728 , ResponseHeader (..)

2829 , AddHeader

2930 , addHeader

@@ -32,11 +33,18 @@ module Servant.API.ResponseHeaders

3233 , GetHeaders(getHeaders)

3334 , HeaderValMap

3435 , HList(..)

36+

37+ , -- * "Dynamic" response headers

38+ DynHeaders(..)

39+ , DynResponse(..)

40+ , withDynHeaders

3541 ) where

3642

3743import Data.ByteString.Char8 as BS

3844 (ByteString, init, pack, unlines)

3945import qualified Data.CaseInsensitive as CI

46+import Data.Map

47+ (Map)

4048import Data.Proxy

4149import Data.Typeable

4250 (Typeable)

@@ -51,8 +59,9 @@ import Prelude.Compat

5159import Servant.API.Header

5260 (Header)

5361

54−-- | Response Header objects. You should never need to construct one directly.

55−-- Instead, use 'addOptionalHeader'.

62+-- | Response Header objects where each header name is tracked at the type-level.

63+-- You should never need to construct one directly. Instead, use

64+-- 'addOptionalHeader'.

5665data Headers ls a = Headers { getResponse :: a

5766 -- ^ The underlying value of a 'Headers'

5867 , getHeadersHList :: HList ls

@@ -166,6 +175,25 @@ addHeader = addOptionalHeader . Header

166175noHeader :: AddHeader h v orig new => orig -> new

167176noHeader = addOptionalHeader MissingHeader

168177

178+-- | Combinator to use when you want your endpoint to return a response

179+-- along with some response headers, dynamically,

180+-- by simply building a value of type 'DynResponse a', which is just a

181+-- response of type @a@ along with a map from header names to header values.

182+--

183+-- For all other interpretations than the server one, this combinator basically

184+-- has no effect and behaves just as if you were using @a@ directly.

185+data DynHeaders a

186+

187+data DynResponse a = DynResponse

188+ { dynResponse :: a

189+ , dynHeaders :: Map HTTP.HeaderName ByteString

190+ } deriving (Typeable, Eq, Show, Functor)

191+

192+-- | Build a \"response with headers\", where the headers are

193+-- provided at runtime as a 'Map' from header name to header value.

194+withDynHeaders :: a -> Map HTTP.HeaderName ByteString -> DynResponse a

195+withDynHeaders = DynResponse

196+

169197-- $setup

170198-- >>> import Servant.API

171199-- >>> import Data.Aeson