master...a701e8d · typeable/servant

git.iko.soy/typeable/servant

9 files changed+173−6

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