master...a701e8d · typeable/servant

git.iko.soy/typeable/servant

on a701e8d help sign in

nix/shell.nix+1−1

since splitsnapshots

unifiedsplit

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

1{ pkgs ? import <nixpkgs> {}

2−, compiler ? "ghc821"

2+, compiler ? "ghc822"

3, tutorial ? false

4}:

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

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

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE OverloadedStrings #-}

8{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE TypeOperators #-}

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

35 BuildFromStream (..),

36 BuildFromStream (..),

36 ByteStringParser (..),

37 ByteStringParser (..),

37 Capture', CaptureAll,

38 Capture', CaptureAll,

39+ Description, DynHeaders,

38− Description, EmptyAPI,

40+ EmptyAPI,

39 FramingUnrender (..),

41 FramingUnrender (..),

40 Header', Headers (..),

42 Header', Headers (..),

41 HttpVersion, IsSecure,

43 HttpVersion, IsSecure,

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

97class RunClient m => HasClient m api where

99class RunClient m => HasClient m api where

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

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

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

101 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

100

108

101

109

102-- | A client querying function for @a ':<|>' b@ will actually hand you

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

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

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

119 clientWithRoute pm (Proxy :: Proxy b) req

127 clientWithRoute pm (Proxy :: Proxy b) req

120

128

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

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

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

132+

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

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

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

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

123

135

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

134instance RunClient m => HasClient m EmptyAPI where

146instance RunClient m => HasClient m EmptyAPI where

135 type Client m EmptyAPI = EmptyClient

147 type Client m EmptyAPI = EmptyClient

136 clientWithRoute _pm Proxy _ = EmptyClient

148 clientWithRoute _pm Proxy _ = EmptyClient

149+ hoistClientMonad _ _ _ EmptyClient = EmptyClient

137

150

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

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

139-- the corresponding querying function will automatically take

152-- the corresponding querying function will automatically take

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

166

179

167 where p = (toUrlPiece val)

180 where p = (toUrlPiece val)

168

181

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

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

184+

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

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

170-- the corresponding querying function will automatically take an

186-- the corresponding querying function will automatically take an

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

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

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

198

214

199 where ps = map (toUrlPiece) vals

215 where ps = map (toUrlPiece) vals

200

216

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

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

219+

201instance OVERLAPPABLE_

220instance OVERLAPPABLE_

202 -- Note [Non-Empty Content Types]

221 -- Note [Non-Empty Content Types]

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

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

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

213 accept = contentTypes (Proxy :: Proxy ct)

232 accept = contentTypes (Proxy :: Proxy ct)

214 method = reflectMethod (Proxy :: Proxy method)

233 method = reflectMethod (Proxy :: Proxy method)

215

234

235+ hoistClientMonad _ _ f ma = f ma

236+

216instance OVERLAPPING_

237instance OVERLAPPING_

217 ( RunClient m, ReflectMethod method

238 ( RunClient m, ReflectMethod method

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

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

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

223 return NoContent

244 return NoContent

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

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

225

246

247+ hoistClientMonad _ _ f ma = f ma

248+

226instance OVERLAPPING_

249instance OVERLAPPING_

227 -- Note [Non-Empty Content Types]

250 -- Note [Non-Empty Content Types]

228 ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls

251 ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls

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

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

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

245 accept = contentTypes (Proxy :: Proxy ct)

268 accept = contentTypes (Proxy :: Proxy ct)

246

269

270+ hoistClientMonad _ _ f ma = f ma

271+

247instance OVERLAPPING_

272instance OVERLAPPING_

248 ( RunClient m, BuildHeadersTo ls, ReflectMethod method

273 ( RunClient m, BuildHeadersTo ls, ReflectMethod method

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

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

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

256 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

281 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

257 }

282 }

258

283

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+

259instance OVERLAPPABLE_

316instance OVERLAPPABLE_

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

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

261 FramingUnrender framing a, BuildFromStream a (f a)

318 FramingUnrender framing a, BuildFromStream a (f a)

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

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

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

305 k go

362 k go

306

363

364+ hoistClientMonad _ _ f ma = f ma

307

365

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

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

309-- the corresponding querying function will automatically take

367-- the corresponding querying function will automatically take

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

345 add :: a -> Request

403 add :: a -> Request

346 add value = addHeader hname value req

404 add value = addHeader hname value req

347

405

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

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

408+

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

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

349-- functions.

410-- functions.

350instance HasClient m api

411instance HasClient m api

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

356 clientWithRoute pm Proxy =

417 clientWithRoute pm Proxy =

357 clientWithRoute pm (Proxy :: Proxy api)

418 clientWithRoute pm (Proxy :: Proxy api)

358

419

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

421+

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

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

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

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

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

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

362

425

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

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

364

427

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

429+

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

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

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

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

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

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

368

433

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

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

370

435

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

437+

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

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

372-- the corresponding querying function will automatically take

439-- the corresponding querying function will automatically take

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

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

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

410 pname :: Text

477 pname :: Text

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

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

412

479

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

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

482+

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

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

414-- the corresponding querying function will automatically take

484-- the corresponding querying function will automatically take

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

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

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

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

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

454 paramlist' = map (Just . toQueryParam) paramlist

524 paramlist' = map (Just . toQueryParam) paramlist

455

525

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

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

528+

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

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

457-- the corresponding querying function will automatically take

530-- the corresponding querying function will automatically take

458-- an additional 'Bool' argument.

531-- an additional 'Bool' argument.

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

489

562

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

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

491

564

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

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

492

567

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

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

494-- back the full `Response`.

569-- back the full `Response`.

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

500 clientWithRoute _pm Proxy req httpMethod = do

575 clientWithRoute _pm Proxy req httpMethod = do

501 runRequest req { requestMethod = httpMethod }

576 runRequest req { requestMethod = httpMethod }

502

577

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

579+

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

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

504-- the corresponding querying function will automatically take

581-- the corresponding querying function will automatically take

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

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

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

533 req

610 req

534 )

611 )

535

612

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

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

615+

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

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

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

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

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

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

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

543

623

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

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

545

625

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

627+

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

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

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

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

548

630

549 clientWithRoute pm Proxy req =

631 clientWithRoute pm Proxy req =

550 clientWithRoute pm (Proxy :: Proxy api) req

632 clientWithRoute pm (Proxy :: Proxy api) req

551

633

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

635+

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

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

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

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

554

638

555 clientWithRoute pm Proxy req =

639 clientWithRoute pm Proxy req =

556 clientWithRoute pm (Proxy :: Proxy api) req

640 clientWithRoute pm (Proxy :: Proxy api) req

557

641

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

643+

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

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

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

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

560

646

561 clientWithRoute pm Proxy req =

647 clientWithRoute pm Proxy req =

562 clientWithRoute pm (Proxy :: Proxy api) req

648 clientWithRoute pm (Proxy :: Proxy api) req

563

649

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

651+

564instance HasClient m subapi =>

652instance HasClient m subapi =>

565 HasClient m (WithNamedContext name context subapi) where

653 HasClient m (WithNamedContext name context subapi) where

566

654

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

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

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

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

569

657

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

659+

570instance ( HasClient m api

660instance ( HasClient m api

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

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

572 type Client m (AuthProtect tag :> api)

662 type Client m (AuthProtect tag :> api)

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

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

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

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

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

577

667

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

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

670+

578-- * Basic Authentication

671-- * Basic Authentication

579

672

580instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where

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

583 clientWithRoute pm Proxy req val =

676 clientWithRoute pm Proxy req val =

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

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

585

678

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

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

681+

586

682

587{- Note [Non-Empty Content Types]

683{- Note [Non-Empty Content Types]

588~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

684~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

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

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

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE TypeFamilies #-}

11module Servant.Client.Internal.HttpClient where

12module Servant.Client.Internal.HttpClient where

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

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

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

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

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

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+

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

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

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

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

75newtype ClientM a = ClientM

86newtype ClientM a = ClientM

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

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

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

859 p = Proxy :: Proxy a

860

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+

861instance (KnownSymbol sym, HasDocs api)

877instance (KnownSymbol sym, HasDocs api)

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

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

863 docsFor Proxy (endpoint, action) =

879 docsFor Proxy (endpoint, action) =

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

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

44import Data.Maybe (fromMaybe, mapMaybe,

45 isNothing, maybeToList)

46import Data.Either (partitionEithers)

47+import qualified Data.Map.Strict as Map

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

48import Data.String (IsString (..))

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

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

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

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

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

88 MimeRender(..),

89 MimeRender(..),

89 canHandleAcceptH)

90 canHandleAcceptH)

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

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

91− getResponse)

92+ getResponse, DynHeaders,

93+ DynResponse, withDynHeaders)

93import Servant.Server.Internal.Context

95import Servant.Server.Internal.Context

94import Servant.Server.Internal.BasicAuth

96import Servant.Server.Internal.BasicAuth

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

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

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

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

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

282

284

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)

283

296

284instance OVERLAPPABLE_

297instance OVERLAPPABLE_

285 ( MimeRender ctype a, ReflectMethod method,

298 ( MimeRender ctype a, ReflectMethod method,

servant/servant.cabal+1

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

71 build-depends:

72 base >= 4.7 && < 4.11

73 , bytestring >= 0.10.4.0 && < 0.11

74+ , containers >= 0.5 && < 0.6

74 , mtl >= 2.1 && < 2.3

75 , mtl >= 2.1 && < 2.3

75 , text >= 1.2.3.0 && < 1.3

76 , text >= 1.2.3.0 && < 1.3

servant/src/Servant/API.hs+1

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

110 (ReqBody, ReqBody')

111import Servant.API.ResponseHeaders

112 (AddHeader, BuildHeadersTo (buildHeadersTo),

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

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

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

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

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

115 noHeader)

116 noHeader)

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

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

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

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

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

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

37 "foo" :> GET :<|>

38 "foo" :> GET :<|>

38 Vault :> GET :<|>

39 Vault :> GET :<|>

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

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

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

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

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

24-- example above).

25module Servant.API.ResponseHeaders

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

26− ( Headers(..)

27+ Headers(..)

27 , ResponseHeader (..)

28 , ResponseHeader (..)

28 , AddHeader

29 , AddHeader

29 , addHeader

30 , addHeader

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

32 , GetHeaders(getHeaders)

33 , GetHeaders(getHeaders)

33 , HeaderValMap

34 , HeaderValMap

34 , HList(..)

35 , HList(..)

36+

37+ , -- * "Dynamic" response headers

38+ DynHeaders(..)

39+ , DynResponse(..)

40+ , withDynHeaders

35 ) where

41 ) where

37import Data.ByteString.Char8 as BS

43import Data.ByteString.Char8 as BS

38 (ByteString, init, pack, unlines)

44 (ByteString, init, pack, unlines)

39import qualified Data.CaseInsensitive as CI

45import qualified Data.CaseInsensitive as CI

46+import Data.Map

47+ (Map)

40import Data.Proxy

48import Data.Proxy

41import Data.Typeable

49import Data.Typeable

42 (Typeable)

50 (Typeable)

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

51import Servant.API.Header

59import Servant.API.Header

52 (Header)

60 (Header)

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

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

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

55−-- Instead, use 'addOptionalHeader'.

64+-- 'addOptionalHeader'.

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

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

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

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

58 , getHeadersHList :: HList ls

67 , getHeadersHList :: HList ls

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

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

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

167noHeader = addOptionalHeader MissingHeader

176noHeader = addOptionalHeader MissingHeader

168

177

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+

169-- $setup

197-- $setup

170-- >>> import Servant.API

198-- >>> import Servant.API

171-- >>> import Data.Aeson

199-- >>> import Data.Aeson