6be8291 · typeable/servant

git.iko.soy/typeable/servant

Merge pull request #936 from haskell-servant/alp/hoistClient

Add hoistClient to servant-client

commit6be8291fe8185431179871e9fd7b3e79a0da6ed4 authorOleg Grenrus <oleg.grenrus@iki.fi> dateMon 9 Apr 2018, 15:19 (9 years ago) parenta8cd6e3 a155d5d

8 files changed+184−1

compare with master

unifiedsplit

doc/tutorial/Client.lhs+57 nix/shell.nix+1−1 servant-client-core/CHANGELOG.md+7 servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs+65 servant-client/CHANGELOG.md+7 servant-client/src/Servant/Client.hs+1 servant-client/src/Servant/Client/Internal/HttpClient.hs+23 servant-client/test/Servant/ClientSpec.hs+23

doc/tutorial/Client.lhs+57

@@ -155,6 +155,63 @@ Email {from = "great@company.com", to = "alp@foo.com", subject = "Hey Alp, we mi

155155

156156The types of the arguments for the functions are the same as for (server-side) request handlers.

157157

158+## Changing the monad the client functions live in

159+

160+Just like `hoistServer` allows us to change the monad in which request handlers

161+of a web application live in, we also have `hoistClient` for changing the monad

162+in which _client functions_ live. Consider the following trivial API:

163+

164+``` haskell

165+type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int

166+

167+hoistClientAPI :: Proxy HoistClientAPI

168+hoistClientAPI = Proxy

169+```

170+

171+We already know how to derive client functions for this API, and as we have

172+seen above they all return results in the `ClientM` monad when using `servant-client`.

173+However, `ClientM` rarely (or never) is the actual monad we need to use the client

174+functions in. Sometimes we need to run them in IO, sometimes in a custom monad

175+stack. `hoistClient` is a very simple solution to the problem of "changing" the monad

176+the clients run in.

177+

178+``` haskell ignore

179+hoistClient

180+ :: HasClient ClientM api -- we need a valid API

181+ => Proxy api -- a Proxy to the API type

182+ -> (forall a. m a -> n a) -- a "monad conversion function" (natural transformation)

183+ -> Client m api -- clients in the source monad

184+ -> Client n api -- result: clients in the target monad

185+```

186+

187+The "conversion function" argument above, just like the ones given to `hoistServer`, must

188+be able to turn an `m a` into an `n a` for any choice of type `a`.

189+

190+Let's see this in action on our example. We first derive our client functions as usual,

191+with all of them returning a result in `ClientM`.

192+

193+``` haskell

194+getIntClientM :: ClientM Int

195+postIntClientM :: Int -> ClientM Int

196+getIntClientM :<|> postIntClientM = client hoistClientAPI

197+```

198+

199+And we finally decide that we want the handlers to run in IO instead, by

200+"post-applying" `runClientM` to a fixed client environment.

201+

202+``` haskell

203+-- our conversion function has type: forall a. ClientM a -> IO a

204+-- the result has type:

205+-- Client IO HoistClientAPI = IO Int :<|> (Int -> IO Int)

206+getClients :: ClientEnv -> Client IO HoistClientAPI

207+getClients clientEnv

208+ = hoistClient hoistClientAPI

209+ ( fmap (either (error . show) id)

210+ . flip runClientM clientEnv

211+ )

212+ (client hoistClientAPI)

213+```

214+

158215## Querying Streaming APIs.

159216

160217Consider the following streaming API type:

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/CHANGELOG.md+7

@@ -1,6 +1,13 @@

11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md)

22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)

4+0.14

5+----

7+- Add a `hoistClientMonad` method to the `HasClient` typeclass, for

8+ changing the monad in which client functions run.

9+ ([#936](https://github.com/haskell-servant/servant/pull/936))

10+

4110.13

512----

613

servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs+65

@@ -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 #-}

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

9798class RunClient m => HasClient m api where

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

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

101+ hoistClientMonad

102+ :: Proxy m

103+ -> Proxy api

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

105+ -> Client mon api

106+ -> Client mon' api

100107

101108

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

@@ -118,6 +125,10 @@ instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where

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

119126 clientWithRoute pm (Proxy :: Proxy b) req

120127

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

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

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

131+

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

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

123134

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

134145instance RunClient m => HasClient m EmptyAPI where

135146 type Client m EmptyAPI = EmptyClient

136147 clientWithRoute _pm Proxy _ = EmptyClient

148+ hoistClientMonad _ _ _ EmptyClient = EmptyClient

137149

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

139151-- the corresponding querying function will automatically take

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

166178

167179 where p = (toUrlPiece val)

168180

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

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

183+

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

170185-- the corresponding querying function will automatically take an

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

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

198213

199214 where ps = map (toUrlPiece) vals

200215

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

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

218+

201219instance OVERLAPPABLE_

202220 -- Note [Non-Empty Content Types]

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

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

213231 accept = contentTypes (Proxy :: Proxy ct)

214232 method = reflectMethod (Proxy :: Proxy method)

215233

234+ hoistClientMonad _ _ f ma = f ma

235+

216236instance OVERLAPPING_

217237 ( RunClient m, ReflectMethod method

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

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

223243 return NoContent

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

225245

246+ hoistClientMonad _ _ f ma = f ma

247+

226248instance OVERLAPPING_

227249 -- Note [Non-Empty Content Types]

228250 ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls

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

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

245267 accept = contentTypes (Proxy :: Proxy ct)

246268

269+ hoistClientMonad _ _ f ma = f ma

270+

247271instance OVERLAPPING_

248272 ( RunClient m, BuildHeadersTo ls, ReflectMethod method

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

@@ -256,6 +280,8 @@ instance OVERLAPPING_

256280 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

257281 }

258282

283+ hoistClientMonad _ _ f ma = f ma

284+

259285instance OVERLAPPABLE_

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

261287 FramingUnrender framing a, BuildFromStream a (f a)

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

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

305331 k go

306332

333+ hoistClientMonad _ _ f ma = f ma

307334

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

309336-- the corresponding querying function will automatically take

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

345372 add :: a -> Request

346373 add value = addHeader hname value req

347374

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

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

377+

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

349379-- functions.

350380instance HasClient m api

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

356386 clientWithRoute pm Proxy =

357387 clientWithRoute pm (Proxy :: Proxy api)

358388

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

390+

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

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

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

362394

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

364396

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

398+

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

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

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

368402

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

370404

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

406+

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

372408-- the corresponding querying function will automatically take

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

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

410446 pname :: Text

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

412448

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

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

451+

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

414453-- the corresponding querying function will automatically take

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

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

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

454493 paramlist' = map (Just . toQueryParam) paramlist

455494

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

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

497+

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

457499-- the corresponding querying function will automatically take

458500-- an additional 'Bool' argument.

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

489531

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

491533

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

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

492536

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

494538-- back the full `Response`.

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

500544 clientWithRoute _pm Proxy req httpMethod = do

501545 runRequest req { requestMethod = httpMethod }

502546

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

548+

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

504550-- the corresponding querying function will automatically take

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

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

533579 req

534580 )

535581

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

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

584+

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

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

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

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

543592

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

545594

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

596+

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

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

548599

549600 clientWithRoute pm Proxy req =

550601 clientWithRoute pm (Proxy :: Proxy api) req

551602

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

604+

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

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

554607

555608 clientWithRoute pm Proxy req =

556609 clientWithRoute pm (Proxy :: Proxy api) req

557610

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

612+

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

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

560615

561616 clientWithRoute pm Proxy req =

562617 clientWithRoute pm (Proxy :: Proxy api) req

563618

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

620+

564621instance HasClient m subapi =>

565622 HasClient m (WithNamedContext name context subapi) where

566623

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

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

569626

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

628+

570629instance ( HasClient m api

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

572631 type Client m (AuthProtect tag :> api)

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

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

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

577636

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

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

639+

578640-- * Basic Authentication

579641

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

@@ -583,6 +645,9 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where

583645 clientWithRoute pm Proxy req val =

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

585647

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

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

650+

586651

587652{- Note [Non-Empty Content Types]

588653~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

servant-client/CHANGELOG.md+7

@@ -1,6 +1,13 @@

11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md)

22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)

4+0.14

5+----

7+- Add `hoistClient` for changing the monad in which

8+ client functions run.

9+ ([#936](https://github.com/haskell-servant/servant/pull/936))

10+

4110.13

512----

613

servant-client/src/Servant/Client.hs+1

@@ -9,6 +9,7 @@ module Servant.Client

99 , runClientM

1010 , ClientEnv(..)

1111 , mkClientEnv

12+ , hoistClient

1213 , module Servant.Client.Core.Reexport

1314 ) where

1415

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

@@ -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,28 @@ 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 conversion function

76+-- (a natural transformation to be precise).

77+--

78+-- For example, assuming you have some @manager :: 'Manager'@ and

79+-- @baseurl :: 'BaseUrl'@ around:

80+--

81+-- > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int

82+-- > api :: Proxy API

83+-- > api = Proxy

84+-- > getInt :: IO Int

85+-- > postInt :: Int -> IO Int

86+-- > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api)

87+-- > where cenv = mkClientEnv manager baseurl

88+hoistClient

89+ :: HasClient ClientM api

90+ => Proxy api

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

92+ -> Client m api

93+ -> Client n api

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

95+

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

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

7598newtype ClientM a = ClientM

servant-client/test/Servant/ClientSpec.hs+23

@@ -89,6 +89,7 @@ spec = describe "Servant.Client" $ do

8989 basicAuthSpec

9090 genAuthSpec

9191 genericClientSpec

92+ hoistClientSpec

9293

9394-- * test data types

9495

@@ -491,6 +492,28 @@ genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWa

491492 left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7

492493 left show <$> runClient doNothing baseUrl `shouldReturn` Right ()

493494

495+-- * hoistClient

496+

497+type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int

498+

499+hoistClientAPI :: Proxy HoistClientAPI

500+hoistClientAPI = Proxy

501+

502+hoistClientServer :: Application -- implements HoistClientAPI

503+hoistClientServer = serve hoistClientAPI $ return 5 :<|> (\n -> return n)

504+

505+hoistClientSpec :: Spec

506+hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do

507+ describe "Servant.Client.hoistClient" $ do

508+ it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do

509+ let (getInt :<|> postInt)

510+ = hoistClient hoistClientAPI

511+ (fmap (either (error . show) id) . flip runClient baseUrl)

512+ (client hoistClientAPI)

513+

514+ getInt `shouldReturn` 5

515+ postInt 5 `shouldReturn` 5

516+

494517-- * utils

495518

496519startWaiApp :: Application -> IO (ThreadId, BaseUrl)