From 200311ee26cc1e1253f2e0313fe138cc3a4e198e Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Fri, 23 Mar 2018 17:36:24 +0100 Subject: [PATCH 1/4] add hoistClient to HasClient class --- .../Servant/Client/Core/Internal/HasClient.hs | 65 +++++++++++++++++++ .../src/Servant/Client/Internal/HttpClient.hs | 11 ++++ 2 files changed, 76 insertions(+) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs index 372e6027..55bfaddb 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -97,6 +98,12 @@ clientIn p pm = clientWithRoute pm p defaultRequest class RunClient m => HasClient m api where type Client (m :: * -> *) (api :: *) :: * clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api + hoistClientMonad + :: Proxy m + -> Proxy api + -> (forall x. mon x -> mon' x) + -> Client mon api + -> Client mon' api -- | 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 clientWithRoute pm (Proxy :: Proxy a) req :<|> clientWithRoute pm (Proxy :: Proxy b) req + hoistClientMonad pm _ f (ca :<|> cb) = + hoistClientMonad pm (Proxy :: Proxy a) f ca :<|> + hoistClientMonad pm (Proxy :: Proxy b) f cb + -- | Singleton type representing a client for an empty API. data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) @@ -134,6 +145,7 @@ data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) instance RunClient m => HasClient m EmptyAPI where type Client m EmptyAPI = EmptyClient clientWithRoute _pm Proxy _ = EmptyClient + hoistClientMonad _ _ _ EmptyClient = EmptyClient -- | If you use a 'Capture' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -166,6 +178,9 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api) where p = (toUrlPiece val) + hoistClientMonad pm _ f cl = \a -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl a) + -- | If you use a 'CaptureAll' in one of your endpoints in your API, -- the corresponding querying function will automatically take an -- additional argument of a list of the type specified by your @@ -198,6 +213,9 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout) where ps = map (toUrlPiece) vals + hoistClientMonad pm _ f cl = \as -> + hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as) + instance OVERLAPPABLE_ -- Note [Non-Empty Content Types] ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) @@ -213,6 +231,8 @@ instance OVERLAPPABLE_ accept = contentTypes (Proxy :: Proxy ct) method = reflectMethod (Proxy :: Proxy method) + hoistClientMonad _ _ f ma = f ma + instance OVERLAPPING_ ( RunClient m, ReflectMethod method ) => HasClient m (Verb method status cts NoContent) where @@ -223,6 +243,8 @@ instance OVERLAPPING_ return NoContent where method = reflectMethod (Proxy :: Proxy method) + hoistClientMonad _ _ f ma = f ma + instance OVERLAPPING_ -- Note [Non-Empty Content Types] ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls @@ -244,6 +266,8 @@ instance OVERLAPPING_ where method = reflectMethod (Proxy :: Proxy method) accept = contentTypes (Proxy :: Proxy ct) + hoistClientMonad _ _ f ma = f ma + instance OVERLAPPING_ ( RunClient m, BuildHeadersTo ls, ReflectMethod method ) => HasClient m (Verb method status cts (Headers ls NoContent)) where @@ -256,6 +280,8 @@ instance OVERLAPPING_ , getHeadersHList = buildHeadersTo . toList $ responseHeaders response } + hoistClientMonad _ _ f ma = f ma + instance OVERLAPPABLE_ ( RunClient m, MimeUnrender ct a, ReflectMethod method, FramingUnrender framing a, BuildFromStream a (f a) @@ -304,6 +330,7 @@ instance OVERLAPPABLE_ processResult (Left err, _) = Just (Left err) k go + hoistClientMonad _ _ f ma = f ma -- | If you use a 'Header' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -345,6 +372,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire add :: a -> Request add value = addHeader hname value req + hoistClientMonad pm _ f cl = \arg -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl arg) + -- | Using a 'HttpVersion' combinator in your API doesn't affect the client -- functions. instance HasClient m api @@ -356,18 +386,24 @@ instance HasClient m api clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy api) + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + -- | Ignore @'Summary'@ in client functions. instance HasClient m api => HasClient m (Summary desc :> api) where type Client m (Summary desc :> api) = Client m api clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + -- | Ignore @'Description'@ in client functions. instance HasClient m api => HasClient m (Description desc :> api) where type Client m (Description desc :> api) = Client m api clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + -- | If you use a 'QueryParam' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'QueryParam', @@ -410,6 +446,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire pname :: Text pname = pack $ symbolVal (Proxy :: Proxy sym) + hoistClientMonad pm _ f cl = \arg -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl arg) + -- | If you use a 'QueryParams' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument, a list of values of the type specified @@ -453,6 +492,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) where pname = pack $ symbolVal (Proxy :: Proxy sym) paramlist' = map (Just . toQueryParam) paramlist + hoistClientMonad pm _ f cl = \as -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl as) + -- | If you use a 'QueryFlag' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional 'Bool' argument. @@ -489,6 +531,8 @@ instance (KnownSymbol sym, HasClient m api) where paramname = pack $ symbolVal (Proxy :: Proxy sym) + hoistClientMonad pm _ f cl = \b -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl b) -- | Pick a 'Method' and specify where the server you want to query is. You get -- back the full `Response`. @@ -500,6 +544,8 @@ instance RunClient m => HasClient m Raw where clientWithRoute _pm Proxy req httpMethod = do runRequest req { requestMethod = httpMethod } + hoistClientMonad _ _ f cl = \meth -> f (cl meth) + -- | If you use a 'ReqBody' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'ReqBody'. @@ -533,6 +579,9 @@ instance (MimeRender ct a, HasClient m api) req ) + hoistClientMonad pm _ f cl = \a -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl a) + -- | Make the querying function append @path@ to the request path. instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where type Client m (path :> api) = Client m api @@ -543,30 +592,40 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where where p = pack $ symbolVal (Proxy :: Proxy path) + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + instance HasClient m api => HasClient m (Vault :> api) where type Client m (Vault :> api) = Client m api clientWithRoute pm Proxy req = clientWithRoute pm (Proxy :: Proxy api) req + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + instance HasClient m api => HasClient m (RemoteHost :> api) where type Client m (RemoteHost :> api) = Client m api clientWithRoute pm Proxy req = clientWithRoute pm (Proxy :: Proxy api) req + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + instance HasClient m api => HasClient m (IsSecure :> api) where type Client m (IsSecure :> api) = Client m api clientWithRoute pm Proxy req = clientWithRoute pm (Proxy :: Proxy api) req + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + instance HasClient m subapi => HasClient m (WithNamedContext name context subapi) where type Client m (WithNamedContext name context subapi) = Client m subapi clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi) + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl + instance ( HasClient m api ) => HasClient m (AuthProtect tag :> api) where type Client m (AuthProtect tag :> api) @@ -575,6 +634,9 @@ instance ( HasClient m api clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) = clientWithRoute pm (Proxy :: Proxy api) (func val req) + hoistClientMonad pm _ f cl = \authreq -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq) + -- * Basic Authentication instance 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 clientWithRoute pm Proxy req val = clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req) + hoistClientMonad pm _ f cl = \bauth -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth) + {- Note [Non-Empty Content Types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index eddb0afc..947220c8 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -6,6 +6,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Servant.Client.Internal.HttpClient where @@ -70,6 +71,16 @@ mkClientEnv mgr burl = ClientEnv mgr burl Nothing client :: HasClient ClientM api => Proxy api -> Client ClientM api client api = api `clientIn` (Proxy :: Proxy ClientM) +-- | Change the monad the client functions live in, by +-- supplying a natural transformation. +hoistClient + :: HasClient ClientM api + => Proxy api + -> (forall a. m a -> n a) + -> Client m api + -> Client n api +hoistClient = hoistClientMonad (Proxy :: Proxy ClientM) + -- | @ClientM@ is the monad in which client functions run. Contains the -- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment. newtype ClientM a = ClientM From 9eb57a6119f9c9045dbd49050bed6f1282611d99 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Wed, 4 Apr 2018 01:14:18 +0200 Subject: [PATCH 2/4] add a test for hoistClient --- nix/shell.nix | 2 +- servant-client/src/Servant/Client.hs | 1 + servant-client/test/Servant/ClientSpec.hs | 23 +++++++++++++++++++++++ 3 files changed, 25 insertions(+), 1 deletion(-) diff --git a/nix/shell.nix b/nix/shell.nix index 9c0cef9e..4e43c606 100644 --- a/nix/shell.nix +++ b/nix/shell.nix @@ -1,5 +1,5 @@ { pkgs ? import {} -, compiler ? "ghc821" +, compiler ? "ghc822" , tutorial ? false }: diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index d3243198..ee5506cd 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -9,6 +9,7 @@ module Servant.Client , runClientM , ClientEnv(..) , mkClientEnv + , hoistClient , module Servant.Client.Core.Reexport ) where diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 6d33cd27..a2e62be5 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -89,6 +89,7 @@ spec = describe "Servant.Client" $ do basicAuthSpec genAuthSpec genericClientSpec + hoistClientSpec -- * test data types @@ -491,6 +492,28 @@ genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWa left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7 left show <$> runClient doNothing baseUrl `shouldReturn` Right () +-- * hoistClient + +type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int + +hoistClientAPI :: Proxy HoistClientAPI +hoistClientAPI = Proxy + +hoistClientServer :: Application -- implements HoistClientAPI +hoistClientServer = serve hoistClientAPI $ return 5 :<|> (\n -> return n) + +hoistClientSpec :: Spec +hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do + describe "Servant.Client.hoistClient" $ do + it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do + let (getInt :<|> postInt) + = hoistClient hoistClientAPI + (fmap (either (error . show) id) . flip runClient baseUrl) + (client hoistClientAPI) + + getInt `shouldReturn` 5 + postInt 5 `shouldReturn` 5 + -- * utils startWaiApp :: Application -> IO (ThreadId, BaseUrl) From fc3c6089b8bb210a0e867c2535293f715abb5e77 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Wed, 4 Apr 2018 01:48:19 +0200 Subject: [PATCH 3/4] document hoistClient (haddocks, tutorial) --- doc/tutorial/Client.lhs | 57 +++++++++++++++++++ .../src/Servant/Client/Internal/HttpClient.hs | 14 ++++- 2 files changed, 70 insertions(+), 1 deletion(-) diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index e221245a..abb71d6c 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -155,6 +155,63 @@ Email {from = "great@company.com", to = "alp@foo.com", subject = "Hey Alp, we mi The types of the arguments for the functions are the same as for (server-side) request handlers. +## Changing the monad the client functions live in + +Just like `hoistServer` allows us to change the monad in which request handlers +of a web application live in, we also have `hoistClient` for changing the monad +in which _client functions_ live. Consider the following trivial API: + +``` haskell +type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int + +hoistClientAPI :: Proxy HoistClientAPI +hoistClientAPI = Proxy +``` + +We already know how to derive client functions for this API, and as we have +seen above they all return results in the `ClientM` monad when using `servant-client`. +However, `ClientM` rarely (or never) is the actual monad we need to use the client +functions in. Sometimes we need to run them in IO, sometimes in a custom monad +stack. `hoistClient` is a very simple solution to the problem of "changing" the monad +the clients run in. + +``` haskell ignore +hoistClient + :: HasClient ClientM api -- we need a valid API + => Proxy api -- a Proxy to the API type + -> (forall a. m a -> n a) -- a "monad conversion function" (natural transformation) + -> Client m api -- clients in the source monad + -> Client n api -- result: clients in the target monad +``` + +The "conversion function" argument above, just like the ones given to `hoistServer`, must +be able to turn an `m a` into an `n a` for any choice of type `a`. + +Let's see this in action on our example. We first derive our client functions as usual, +with all of them returning a result in `ClientM`. + +``` haskell +getIntClientM :: ClientM Int +postIntClientM :: Int -> ClientM Int +getIntClientM :<|> postIntClientM = client hoistClientAPI +``` + +And we finally decide that we want the handlers to run in IO instead, by +"post-applying" `runClientM` to a fixed client environment. + +``` haskell +-- our conversion function has type: forall a. ClientM a -> IO a +-- the result has type: +-- Client IO HoistClientAPI = IO Int :<|> (Int -> IO Int) +getClients :: ClientEnv -> Client IO HoistClientAPI +getClients clientEnv + = hoistClient hoistClientAPI + ( fmap (either (error . show) id) + . flip runClientM clientEnv + ) + (client hoistClientAPI) +``` + ## Querying Streaming APIs. Consider the following streaming API type: diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index 947220c8..52eec9e8 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -72,7 +72,19 @@ client :: HasClient ClientM api => Proxy api -> Client ClientM api client api = api `clientIn` (Proxy :: Proxy ClientM) -- | Change the monad the client functions live in, by --- supplying a natural transformation. +-- supplying a conversion function +-- (a natural transformation to be precise). +-- +-- For example, assuming you have some @manager :: 'Manager'@ and +-- @baseurl :: 'BaseUrl'@ around: +-- +-- > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int +-- > api :: Proxy API +-- > api = Proxy +-- > getInt :: IO Int +-- > postInt :: Int -> IO Int +-- > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api) +-- > where cenv = mkClientEnv manager baseurl hoistClient :: HasClient ClientM api => Proxy api From a155d5d497b83428356a391b554c87a4d144461b Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Mon, 9 Apr 2018 13:57:31 +0200 Subject: [PATCH 4/4] changelog entries --- servant-client-core/CHANGELOG.md | 7 +++++++ servant-client/CHANGELOG.md | 7 +++++++ 2 files changed, 14 insertions(+) diff --git a/servant-client-core/CHANGELOG.md b/servant-client-core/CHANGELOG.md index 19cbde38..03275e50 100644 --- a/servant-client-core/CHANGELOG.md +++ b/servant-client-core/CHANGELOG.md @@ -1,6 +1,13 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.14 +---- + +- Add a `hoistClientMonad` method to the `HasClient` typeclass, for + changing the monad in which client functions run. + ([#936](https://github.com/haskell-servant/servant/pull/936)) + 0.13 ---- diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index 9df704ca..6e689dff 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -1,6 +1,13 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.14 +---- + +- Add `hoistClient` for changing the monad in which + client functions run. + ([#936](https://github.com/haskell-servant/servant/pull/936)) + 0.13 ----