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

Add hoistClient to servant-client

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:

nix/shell.nix

@@ -1,5 +1,5 @@
 { pkgs ? import <nixpkgs> {}
-, compiler ? "ghc821"
+, compiler ? "ghc822"
 , tutorial ? false
 }:
 

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

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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

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

servant-client/src/Servant/Client.hs

@@ -9,6 +9,7 @@ module Servant.Client
   , runClientM
   , ClientEnv(..)
   , mkClientEnv
+  , hoistClient
   , module Servant.Client.Core.Reexport
   ) where
 

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,28 @@ 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 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
+  -> (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

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)