master...4e53c38 · typeable/servant

git.iko.soy/typeable/servant

9 files changed+242−79

since splitsnapshots

unifiedsplit

nix/shell.nix+1−1 servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs+97−1 servant-client/src/Servant/Client/Internal/HttpClient.hs+11 servant-docs/src/Servant/Docs/Internal.hs+16 servant-server/src/Servant/Server/Internal.hs+85−72 servant/servant.cabal+1 servant/src/Servant/API.hs+2−2 servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs+1 servant/src/Servant/API/ResponseHeaders.hs+28−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+97−1

@@ -6,6 +6,7 @@

66{-# LANGUAGE MultiParamTypeClasses #-}

77{-# LANGUAGE OverloadedStrings #-}

88{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE RankNTypes #-}

910{-# LANGUAGE ScopedTypeVariables #-}

1011{-# LANGUAGE TypeFamilies #-}

1112{-# LANGUAGE TypeOperators #-}

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

3536 BuildFromStream (..),

3637 ByteStringParser (..),

3738 Capture', CaptureAll,

38− Description, EmptyAPI,

39+ Description, DynHeaders,

40+ EmptyAPI,

3941 FramingUnrender (..),

4042 Header', Headers (..),

4143 HttpVersion, IsSecure,

@@ -97,6 +99,12 @@ clientIn p pm = clientWithRoute pm p defaultRequest

9799class RunClient m => HasClient m api where

98100 type Client (m :: * -> *) (api :: *) :: *

99101 clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api

102+ hoistClientMonad

103+ :: Proxy m

104+ -> Proxy api

105+ -> (forall x. mon x -> mon' x)

106+ -> Client mon api

107+ -> Client mon' api

100108

101109

102110-- | 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

118126 clientWithRoute pm (Proxy :: Proxy a) req :<|>

119127 clientWithRoute pm (Proxy :: Proxy b) req

120128

129+ hoistClientMonad pm _ f (ca :<|> cb) =

130+ hoistClientMonad pm (Proxy :: Proxy a) f ca :<|>

131+ hoistClientMonad pm (Proxy :: Proxy b) f cb

132+

121133-- | Singleton type representing a client for an empty API.

122134data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)

123135

@@ -134,6 +146,7 @@ data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)

134146instance RunClient m => HasClient m EmptyAPI where

135147 type Client m EmptyAPI = EmptyClient

136148 clientWithRoute _pm Proxy _ = EmptyClient

149+ hoistClientMonad _ _ _ EmptyClient = EmptyClient

137150

138151-- | If you use a 'Capture' in one of your endpoints in your API,

139152-- the corresponding querying function will automatically take

@@ -166,6 +179,9 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)

166179

167180 where p = (toUrlPiece val)

168181

182+ hoistClientMonad pm _ f cl = \a ->

183+ hoistClientMonad pm (Proxy :: Proxy api) f (cl a)

184+

169185-- | If you use a 'CaptureAll' in one of your endpoints in your API,

170186-- the corresponding querying function will automatically take an

171187-- additional argument of a list of the type specified by your

@@ -198,6 +214,9 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)

198214

199215 where ps = map (toUrlPiece) vals

200216

217+ hoistClientMonad pm _ f cl = \as ->

218+ hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)

219+

201220instance OVERLAPPABLE_

202221 -- Note [Non-Empty Content Types]

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

@@ -213,6 +232,8 @@ instance OVERLAPPABLE_

213232 accept = contentTypes (Proxy :: Proxy ct)

214233 method = reflectMethod (Proxy :: Proxy method)

215234

235+ hoistClientMonad _ _ f ma = f ma

236+

216237instance OVERLAPPING_

217238 ( RunClient m, ReflectMethod method

218239 ) => HasClient m (Verb method status cts NoContent) where

@@ -223,6 +244,8 @@ instance OVERLAPPING_

223244 return NoContent

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

225246

247+ hoistClientMonad _ _ f ma = f ma

248+

226249instance OVERLAPPING_

227250 -- Note [Non-Empty Content Types]

228251 ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls

@@ -244,6 +267,8 @@ instance OVERLAPPING_

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

245268 accept = contentTypes (Proxy :: Proxy ct)

246269

270+ hoistClientMonad _ _ f ma = f ma

271+

247272instance OVERLAPPING_

248273 ( RunClient m, BuildHeadersTo ls, ReflectMethod method

249274 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where

@@ -256,6 +281,38 @@ instance OVERLAPPING_

256281 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

257282 }

258283

284+ hoistClientMonad _ _ f ma = f ma

285+

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+

259316instance OVERLAPPABLE_

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

261318 FramingUnrender framing a, BuildFromStream a (f a)

@@ -304,6 +361,7 @@ instance OVERLAPPABLE_

304361 processResult (Left err, _) = Just (Left err)

305362 k go

306363

364+ hoistClientMonad _ _ f ma = f ma

307365

308366-- | If you use a 'Header' in one of your endpoints in your API,

309367-- the corresponding querying function will automatically take

@@ -345,6 +403,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire

345403 add :: a -> Request

346404 add value = addHeader hname value req

347405

406+ hoistClientMonad pm _ f cl = \arg ->

407+ hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)

408+

348409-- | Using a 'HttpVersion' combinator in your API doesn't affect the client

349410-- functions.

350411instance HasClient m api

@@ -356,18 +417,24 @@ instance HasClient m api

356417 clientWithRoute pm Proxy =

357418 clientWithRoute pm (Proxy :: Proxy api)

358419

420+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

421+

359422-- | Ignore @'Summary'@ in client functions.

360423instance HasClient m api => HasClient m (Summary desc :> api) where

361424 type Client m (Summary desc :> api) = Client m api

362425

363426 clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)

364427

428+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

429+

365430-- | Ignore @'Description'@ in client functions.

366431instance HasClient m api => HasClient m (Description desc :> api) where

367432 type Client m (Description desc :> api) = Client m api

368433

369434 clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)

370435

436+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

437+

371438-- | If you use a 'QueryParam' in one of your endpoints in your API,

372439-- the corresponding querying function will automatically take

373440-- an additional argument of the type specified by your 'QueryParam',

@@ -410,6 +477,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire

410477 pname :: Text

411478 pname = pack $ symbolVal (Proxy :: Proxy sym)

412479

480+ hoistClientMonad pm _ f cl = \arg ->

481+ hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)

482+

413483-- | If you use a 'QueryParams' in one of your endpoints in your API,

414484-- the corresponding querying function will automatically take

415485-- an additional argument, a list of values of the type specified

@@ -453,6 +523,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)

453523 where pname = pack $ symbolVal (Proxy :: Proxy sym)

454524 paramlist' = map (Just . toQueryParam) paramlist

455525

526+ hoistClientMonad pm _ f cl = \as ->

527+ hoistClientMonad pm (Proxy :: Proxy api) f (cl as)

528+

456529-- | If you use a 'QueryFlag' in one of your endpoints in your API,

457530-- the corresponding querying function will automatically take

458531-- an additional 'Bool' argument.

@@ -489,6 +562,8 @@ instance (KnownSymbol sym, HasClient m api)

489562

490563 where paramname = pack $ symbolVal (Proxy :: Proxy sym)

491564

565+ hoistClientMonad pm _ f cl = \b ->

566+ hoistClientMonad pm (Proxy :: Proxy api) f (cl b)

492567

493568-- | Pick a 'Method' and specify where the server you want to query is. You get

494569-- back the full `Response`.

@@ -500,6 +575,8 @@ instance RunClient m => HasClient m Raw where

500575 clientWithRoute _pm Proxy req httpMethod = do

501576 runRequest req { requestMethod = httpMethod }

502577

578+ hoistClientMonad _ _ f cl = \meth -> f (cl meth)

579+

503580-- | If you use a 'ReqBody' in one of your endpoints in your API,

504581-- the corresponding querying function will automatically take

505582-- an additional argument of the type specified by your 'ReqBody'.

@@ -533,6 +610,9 @@ instance (MimeRender ct a, HasClient m api)

533610 req

534611 )

535612

613+ hoistClientMonad pm _ f cl = \a ->

614+ hoistClientMonad pm (Proxy :: Proxy api) f (cl a)

615+

536616-- | Make the querying function append @path@ to the request path.

537617instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where

538618 type Client m (path :> api) = Client m api

@@ -543,30 +623,40 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where

543623

544624 where p = pack $ symbolVal (Proxy :: Proxy path)

545625

626+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

627+

546628instance HasClient m api => HasClient m (Vault :> api) where

547629 type Client m (Vault :> api) = Client m api

548630

549631 clientWithRoute pm Proxy req =

550632 clientWithRoute pm (Proxy :: Proxy api) req

551633

634+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

635+

552636instance HasClient m api => HasClient m (RemoteHost :> api) where

553637 type Client m (RemoteHost :> api) = Client m api

554638

555639 clientWithRoute pm Proxy req =

556640 clientWithRoute pm (Proxy :: Proxy api) req

557641

642+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

643+

558644instance HasClient m api => HasClient m (IsSecure :> api) where

559645 type Client m (IsSecure :> api) = Client m api

560646

561647 clientWithRoute pm Proxy req =

562648 clientWithRoute pm (Proxy :: Proxy api) req

563649

650+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

651+

564652instance HasClient m subapi =>

565653 HasClient m (WithNamedContext name context subapi) where

566654

567655 type Client m (WithNamedContext name context subapi) = Client m subapi

568656 clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)

569657

658+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl

659+

570660instance ( HasClient m api

571661 ) => HasClient m (AuthProtect tag :> api) where

572662 type Client m (AuthProtect tag :> api)

@@ -575,6 +665,9 @@ instance ( HasClient m api

575665 clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) =

576666 clientWithRoute pm (Proxy :: Proxy api) (func val req)

577667

668+ hoistClientMonad pm _ f cl = \authreq ->

669+ hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)

670+

578671-- * Basic Authentication

579672

580673instance 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

583676 clientWithRoute pm Proxy req val =

584677 clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req)

585678

679+ hoistClientMonad pm _ f cl = \bauth ->

680+ hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)

681+

586682

587683{- Note [Non-Empty Content Types]

588684~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

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

@@ -6,6 +6,7 @@

66{-# LANGUAGE GeneralizedNewtypeDeriving #-}

77{-# LANGUAGE MultiParamTypeClasses #-}

88{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE RankNTypes #-}

910{-# LANGUAGE ScopedTypeVariables #-}

1011{-# LANGUAGE TypeFamilies #-}

1112module Servant.Client.Internal.HttpClient where

@@ -70,6 +71,16 @@ mkClientEnv mgr burl = ClientEnv mgr burl Nothing

7071client :: HasClient ClientM api => Proxy api -> Client ClientM api

7172client api = api `clientIn` (Proxy :: Proxy ClientM)

7273

74+-- | Change the monad the client functions live in, by

75+-- supplying a natural transformation.

76+hoistClient

77+ :: HasClient ClientM api

78+ => Proxy api

79+ -> (forall a. m a -> n a)

80+ -> Client m api

81+ -> Client n api

82+hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)

83+

7384-- | @ClientM@ is the monad in which client functions run. Contains the

7485-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.

7586newtype ClientM a = ClientM

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+85−72

@@ -1,25 +1,24 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE DeriveDataTypeable #-}

5−{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE FlexibleInstances #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE OverloadedStrings #-}

9−{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE RankNTypes #-}

11−{-# LANGUAGE ScopedTypeVariables #-}

12−{-# LANGUAGE TupleSections #-}

13−{-# LANGUAGE TypeFamilies #-}

14−{-# LANGUAGE TypeOperators #-}

15−{-# LANGUAGE UndecidableInstances #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE DeriveDataTypeable #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE TupleSections #-}

13+{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE TypeOperators #-}

1615

1716#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802

1817#define HAS_TYPE_ERROR

1918#endif

2019

2120#ifdef HAS_TYPE_ERROR

22−{-# LANGUAGE UndecidableInstances #-}

21+{-# LANGUAGE UndecidableInstances #-}

2322#endif

2423

2524#include "overlapping-compat.h"

@@ -34,71 +33,74 @@ module Servant.Server.Internal

3433 , module Servant.Server.Internal.ServantErr

3534 ) where

3635

37−import Control.Monad (join, when)

38−import Control.Monad.Trans (liftIO)

39−import Control.Monad.Trans.Resource (runResourceT)

40−import qualified Data.ByteString as B

41−import qualified Data.ByteString.Builder as BB

42−import qualified Data.ByteString.Char8 as BC8

43−import qualified Data.ByteString.Lazy as BL

44−import Data.Maybe (fromMaybe, mapMaybe,

45− isNothing, maybeToList)

46−import Data.Either (partitionEithers)

47−import Data.String (IsString (..))

48−import Data.String.Conversions (cs, (<>))

49−import Data.Tagged (Tagged(..), retag, untag)

50−import qualified Data.Text as T

36+import Control.Monad

37+ (join, when)

38+import Control.Monad.Trans

39+ (liftIO)

40+import Control.Monad.Trans.Resource

41+ (runResourceT)

42+import qualified Data.ByteString as B

43+import qualified Data.ByteString.Builder as BB

44+import qualified Data.ByteString.Char8 as BC8

45+import qualified Data.ByteString.Lazy as BL

46+import Data.Either

47+ (partitionEithers)

48+import qualified Data.Map.Strict as Map

49+import Data.Maybe

50+ (fromMaybe, isNothing, mapMaybe, maybeToList)

51+import Data.String

52+ (IsString (..))

53+import Data.String.Conversions

54+ (cs, (<>))

55+import Data.Tagged

56+ (Tagged (..), retag, untag)

57+import qualified Data.Text as T

5158import Data.Typeable

52−import GHC.TypeLits (KnownNat, KnownSymbol, natVal,

53− symbolVal)

54−import Network.HTTP.Types hiding (Header, ResponseHeaders)

55−import qualified Network.HTTP.Media as NHM

56−import Network.Socket (SockAddr)

57−import Network.Wai (Application, Request,

58− httpVersion, isSecure,

59− lazyRequestBody,

60− rawQueryString, remoteHost,

61− requestHeaders, requestMethod,

62− responseLBS, responseStream,

63− vault)

64−import Prelude ()

59+import GHC.TypeLits

60+ (KnownNat, KnownSymbol, natVal, symbolVal)

61+import qualified Network.HTTP.Media as NHM

62+import Network.HTTP.Types hiding

63+ (Header, ResponseHeaders)

64+import Network.Socket

65+ (SockAddr)

66+import Network.Wai

67+ (Application, Request, httpVersion, isSecure, lazyRequestBody,

68+ rawQueryString, remoteHost, requestHeaders, requestMethod,

69+ responseLBS, responseStream, vault)

70+import Prelude ()

6571import Prelude.Compat

66−import Web.HttpApiData (FromHttpApiData, parseHeader,

67− parseQueryParam,

68− parseUrlPieceMaybe,

69− parseUrlPieces)

70−import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture',

71− CaptureAll, Verb, EmptyAPI,

72− ReflectMethod(reflectMethod),

73− IsSecure(..), Header', QueryFlag,

74− QueryParam', QueryParams, Raw,

75− RemoteHost, ReqBody', Vault,

76− WithNamedContext,

77− Description, Summary,

78− Accept(..),

79− FramingRender(..), Stream,

80− StreamGenerator(..), ToStreamGenerator(..),

81− BoundaryStrategy(..),

82− If, SBool (..), SBoolI (..))

83−import Servant.API.Modifiers (unfoldRequestArgument, RequestArgument, FoldRequired, FoldLenient)

84−import Servant.API.ContentTypes (AcceptHeader (..),

85− AllCTRender (..),

86− AllCTUnrender (..),

87− AllMime,

88− MimeRender(..),

89− canHandleAcceptH)

90−import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,

91− getResponse)

72+import Servant.API

73+ ((:<|>) (..), (:>), Accept (..), BasicAuth,

74+ BoundaryStrategy (..), Capture', CaptureAll, Description,

75+ EmptyAPI, FramingRender (..), Header', If, IsSecure (..),

76+ QueryFlag, QueryParam', QueryParams, Raw,

77+ ReflectMethod (reflectMethod), RemoteHost, ReqBody',

78+ SBool (..), SBoolI (..), Stream, StreamGenerator (..),

79+ Summary, ToStreamGenerator (..), Vault, Verb,

80+ WithNamedContext)

81+import Servant.API.ContentTypes

82+ (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

83+ AllMime, MimeRender (..), canHandleAcceptH)

84+import Servant.API.Modifiers

85+ (FoldLenient, FoldRequired, RequestArgument,

86+ unfoldRequestArgument)

87+import Servant.API.ResponseHeaders

88+ (DynHeaders (..), GetHeaders, Headers, getHeaders,

89+ getResponse)

90+import Web.HttpApiData

91+ (FromHttpApiData, parseHeader, parseQueryParam,

92+ parseUrlPieceMaybe, parseUrlPieces)

9293

93−import Servant.Server.Internal.Context

9494import Servant.Server.Internal.BasicAuth

95+import Servant.Server.Internal.Context

9596import Servant.Server.Internal.Handler

9697import Servant.Server.Internal.Router

9798import Servant.Server.Internal.RoutingApplication

9899import Servant.Server.Internal.ServantErr

99100

100101#ifdef HAS_TYPE_ERROR

101−import GHC.TypeLits (TypeError, ErrorMessage (..))

102+import GHC.TypeLits

103+ (ErrorMessage (..), TypeError)

102104#endif

103105

104106class HasServer api context where

@@ -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 (DynHeaders 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,

@@ -758,7 +771,7 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA

758771-- ...Maybe you haven't applied enough arguments to

759772-- ...Capture' '[] "foo"

760773-- ...

761−--

774+--

762775instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context

763776 where

764777 type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)

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+2−2

@@ -109,10 +109,10 @@ import Servant.API.RemoteHost

109109import Servant.API.ReqBody

110110 (ReqBody, ReqBody')

111111import Servant.API.ResponseHeaders

112− (AddHeader, BuildHeadersTo (buildHeadersTo),

112+ (AddHeader, BuildHeadersTo (buildHeadersTo), DynHeaders (..),

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

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

115− noHeader)

115+ noHeader, withDynHeaders)

116116import Servant.API.Stream

117117 (BoundaryStrategy (..), BuildFromStream (..),

118118 ByteStringParser (..), FramingRender (..),

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+28−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,17 @@ module Servant.API.ResponseHeaders

3233 , GetHeaders(getHeaders)

3334 , HeaderValMap

3435 , HList(..)

36+

37+ , -- * "Dynamic" response headers

38+ DynHeaders(..)

39+ , withDynHeaders

3540 ) where

3641

3742import Data.ByteString.Char8 as BS

3843 (ByteString, init, pack, unlines)

3944import qualified Data.CaseInsensitive as CI

45+import Data.Map

46+ (Map)

4047import Data.Proxy

4148import Data.Typeable

4249 (Typeable)

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

5158import Servant.API.Header

5259 (Header)

5360

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

55−-- Instead, use 'addOptionalHeader'.

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

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

63+-- 'addOptionalHeader'.

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

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

5866 , getHeadersHList :: HList ls

@@ -166,6 +174,23 @@ addHeader = addOptionalHeader . Header

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

167175noHeader = addOptionalHeader MissingHeader

168176

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

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

179+-- by simply building a value of type 'DynHeaders a', which is just a

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

181+--

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

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

184+data DynHeaders a = DynHeaders

185+ { dynResponse :: a

186+ , dynHeaders :: Map HTTP.HeaderName ByteString

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

188+

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

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

191+withDynHeaders :: a -> Map HTTP.HeaderName ByteString -> DynHeaders a

192+withDynHeaders = DynHeaders

193+

169194-- $setup

170195-- >>> import Servant.API

171196-- >>> import Data.Aeson