Merge pull request #640 from fierce-katie/generic-client

Generic client

servant-client/CHANGELOG.md

@@ -7,6 +7,8 @@
 * client asks for any content-type in Accept contentTypes non-empty list
   ([#615](https://github.com/haskell-servant/servant/pull/615))
 
+* Add `ClientLike` class that matches client functions generated using `client` with client data structure.
+
 0.9.1.1
 -------
 

servant-client/servant-client.cabal

@@ -30,6 +30,7 @@ source-repository head
 library
   exposed-modules:
     Servant.Client
+    Servant.Client.Generic
     Servant.Client.Experimental.Auth
     Servant.Common.BaseUrl
     Servant.Common.BasicAuth
@@ -42,6 +43,7 @@ library
     , base64-bytestring     >= 1.0.0.1  && < 1.1
     , bytestring            >= 0.10     && < 0.11
     , exceptions            >= 0.8      && < 0.9
+    , generics-sop          >= 0.1.0.0  && < 0.3
     , http-api-data         >= 0.3      && < 0.4
     , http-client           >= 0.4.18.1 && < 0.6
     , http-client-tls       >= 0.2.2    && < 0.4
@@ -96,3 +98,4 @@ test-suite spec
     , transformers-compat
     , wai
     , warp
+    , generics-sop

servant-client/src/Servant/Client/Generic.hs

@@ -0,0 +1,164 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+#include "overlapping-compat.h"
+
+module Servant.Client.Generic
+  ( ClientLike(..)
+  , genericMkClientL
+  , genericMkClientP
+  ) where
+
+import Generics.SOP   (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to)
+import Servant.API    ((:<|>)(..))
+import Servant.Client (ClientM)
+
+-- | This class allows us to match client structure with client functions
+-- produced with 'client' without explicit pattern-matching.
+--
+-- The client structure needs a 'Generics.SOP.Generic' instance.
+--
+-- Example:
+--
+-- > type API
+-- >     = "foo" :> Capture "x" Int :> Get '[JSON] Int
+-- >  :<|> "bar" :> QueryParam "a" Char :> QueryParam "b" String :> Post '[JSON] [Int]
+-- >  :<|> Capture "nested" Int :> NestedAPI
+-- >
+-- > type NestedAPI
+-- >     = Get '[JSON] String
+-- >  :<|> "baz" :> QueryParam "c" Char :> Post '[JSON] ()
+-- >
+-- > data APIClient = APIClient
+-- >   { getFoo         :: Int -> ClientM Int
+-- >   , postBar        :: Maybe Char -> Maybe String -> ClientM [Int]
+-- >   , mkNestedClient :: Int -> NestedClient
+-- >   } deriving GHC.Generic
+-- >
+-- > instance Generics.SOP.Generic APIClient
+-- > instance (Client API ~ client) => ClientLike client APIClient
+-- >
+-- > data NestedClient = NestedClient
+-- >  { getString :: ClientM String
+-- >  , postBaz   :: Maybe Char -> ClientM ()
+-- >  } deriving GHC.Generic
+-- >
+-- > instance Generics.SOP.Generic NestedClient
+-- > instance (Client NestedAPI ~ client) => ClientLike client NestedClient
+-- >
+-- > mkAPIClient :: APIClient
+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
+--
+-- By default, left-nested alternatives are expanded:
+--
+-- > type API1
+-- >     = "foo" :> Capture "x" Int :> Get '[JSON] Int
+-- >  :<|> "bar" :> QueryParam "a" Char :> Post '[JSON] String
+-- >
+-- > type API2
+-- >     = "baz" :> QueryParam "c" Char :> Post '[JSON] ()
+-- >
+-- > type API = API1 :<|> API2
+-- >
+-- > data APIClient = APIClient
+-- >   { getFoo  :: Int -> ClientM Int
+-- >   , postBar :: Maybe Char -> ClientM String
+-- >   , postBaz :: Maybe Char -> ClientM ()
+-- >   } deriving GHC.Generic
+-- >
+-- > instance Generics.SOP.Generic APIClient
+-- > instance (Client API ~ client) => ClientLike client APIClient
+-- >
+-- > mkAPIClient :: APIClient
+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
+--
+-- If you want to define client for @API1@ as a separate data structure,
+-- you can use 'genericMkClientP':
+--
+-- > data APIClient1 = APIClient1
+-- >   { getFoo  :: Int -> ClientM Int
+-- >   , postBar :: Maybe Char -> ClientM String
+-- >   } deriving GHC.Generic
+-- >
+-- > instance Generics.SOP.Generic APIClient1
+-- > instance (Client API1 ~ client) => ClientLike client APIClient1
+-- >
+-- > data APIClient = APIClient
+-- >   { mkAPIClient1 :: APIClient1
+-- >   , postBaz      :: Maybe Char -> ClientM ()
+-- >   } deriving GHC.Generic
+-- >
+-- > instance Generics.SOP.Generic APIClient
+-- > instance (Client API ~ client) => ClientLike client APIClient where
+-- >   mkClient = genericMkClientP
+-- >
+-- > mkAPIClient :: APIClient
+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
+class ClientLike client custom where
+  mkClient :: client -> custom
+  default mkClient :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)
+    => client -> custom
+  mkClient = genericMkClientL
+
+instance ClientLike client custom
+      => ClientLike (a -> client) (a -> custom) where
+  mkClient c = mkClient . c
+
+instance ClientLike (ClientM a) (ClientM a) where
+  mkClient = id
+
+-- | Match client structure with client functions, regarding left-nested API clients
+-- as separate data structures.
+class GClientLikeP client xs where
+  gMkClientP :: client -> NP I xs
+
+instance (GClientLikeP b (y ': xs), ClientLike a x)
+      => GClientLikeP (a :<|> b) (x ': y ': xs) where
+  gMkClientP (a :<|> b) = I (mkClient a) :* gMkClientP b
+
+instance ClientLike a x => GClientLikeP a '[x] where
+  gMkClientP a = I (mkClient a) :* Nil
+
+-- | Match client structure with client functions, expanding left-nested API clients
+-- in the same structure.
+class GClientLikeL (xs :: [*]) (ys :: [*]) where
+  gMkClientL :: NP I xs -> NP I ys
+
+instance GClientLikeL '[] '[] where
+  gMkClientL Nil = Nil
+
+instance (ClientLike x y, GClientLikeL xs ys) => GClientLikeL (x ': xs) (y ': ys) where
+  gMkClientL (I x :* xs) = I (mkClient x) :* gMkClientL xs
+
+type family ClientList (client :: *) (acc :: [*]) :: [*] where
+  ClientList (a :<|> b) acc = ClientList a (ClientList b acc)
+  ClientList a acc = a ': acc
+
+class GClientList client (acc :: [*]) where
+  gClientList :: client -> NP I acc -> NP I (ClientList client acc)
+
+instance (GClientList b acc, GClientList a (ClientList b acc))
+  => GClientList (a :<|> b) acc where
+  gClientList (a :<|> b) acc = gClientList a (gClientList b acc)
+
+instance OVERLAPPABLE_ (ClientList client acc ~ (client ': acc))
+  => GClientList client acc where
+  gClientList c acc = I c :* acc
+
+-- | Generate client structure from client type, expanding left-nested API (done by default).
+genericMkClientL :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)
+  => client -> custom
+genericMkClientL = to . SOP . Z . gMkClientL . flip gClientList Nil
+
+-- | Generate client structure from client type, regarding left-nested API clients as separate data structures.
+genericMkClientP :: (Generic custom, Code custom ~ '[xs], GClientLikeP client xs)
+  => client -> custom
+genericMkClientP = to . SOP . Z . gMkClientP
+

servant-client/test/Servant/ClientSpec.hs

@@ -36,6 +36,7 @@ import           Data.Char                  (chr, isPrint)
 import           Data.Foldable              (forM_)
 import           Data.Monoid                hiding (getLast)
 import           Data.Proxy
+import qualified Generics.SOP               as SOP
 import           GHC.Generics               (Generic)
 import qualified Network.HTTP.Client        as C
 import           Network.HTTP.Media
@@ -55,6 +56,7 @@ import           Web.FormUrlEncoded         (FromForm, ToForm)
 import           Servant.API
 import           Servant.API.Internal.Test.ComprehensiveAPI
 import           Servant.Client
+import           Servant.Client.Generic
 import qualified Servant.Common.Req         as SCR
 import           Servant.Server
 import           Servant.Server.Experimental.Auth
@@ -69,6 +71,7 @@ spec = describe "Servant.Client" $ do
     wrappedApiSpec
     basicAuthSpec
     genAuthSpec
+    genericClientSpec
 
 -- * test data types
 
@@ -222,6 +225,53 @@ genAuthServerContext = genAuthHandler :. EmptyContext
 genAuthServer :: Application
 genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
 
+-- * generic client stuff
+
+type GenericClientAPI
+    = QueryParam "sqr" Int :> Get '[JSON] Int
+ :<|> Capture "foo" String :> NestedAPI1
+
+data GenericClient = GenericClient
+  { getSqr          :: Maybe Int -> SCR.ClientM Int
+  , mkNestedClient1 :: String -> NestedClient1
+  } deriving Generic
+instance SOP.Generic GenericClient
+instance (Client GenericClientAPI ~ client) => ClientLike client GenericClient
+
+type NestedAPI1
+    = QueryParam "int" Int :> NestedAPI2
+ :<|> QueryParam "id" Char :> Get '[JSON] Char
+
+data NestedClient1 = NestedClient1
+  { mkNestedClient2 :: Maybe Int -> NestedClient2
+  , idChar          :: Maybe Char -> SCR.ClientM Char
+  } deriving Generic
+instance SOP.Generic NestedClient1
+instance (Client NestedAPI1 ~ client) => ClientLike client NestedClient1
+
+type NestedAPI2
+    = "sum"  :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int
+ :<|> "void" :> Post '[JSON] ()
+
+data NestedClient2 = NestedClient2
+  { getSum    :: Int -> Int -> SCR.ClientM Int
+  , doNothing :: SCR.ClientM ()
+  } deriving Generic
+instance SOP.Generic NestedClient2
+instance (Client NestedAPI2 ~ client) => ClientLike client NestedClient2
+
+genericClientServer :: Application
+genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (
+       (\ mx -> case mx of
+                  Just x -> return (x*x)
+                  Nothing -> throwError $ ServantErr 400 "missing parameter" "" []
+       )
+  :<|> nestedServer1
+ )
+  where
+    nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return)
+    nestedServer2 _int = (\ x y -> return (x + y)) :<|> return ()
+
 {-# NOINLINE manager #-}
 manager :: C.Manager
 manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
@@ -392,6 +442,22 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
       Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl)
       responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
 
+genericClientSpec :: Spec
+genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do
+  describe "Servant.Client.Generic" $ do
+
+    let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI))
+        NestedClient1{..} = mkNestedClient1 "example"
+        NestedClient2{..} = mkNestedClient2 (Just 42)
+
+    it "works for top-level client function" $ \(_, baseUrl) -> do
+      (left show <$> (runClientM (getSqr (Just 5)) (ClientEnv manager baseUrl))) `shouldReturn` Right 25
+
+    it "works for nested clients" $ \(_, baseUrl) -> do
+      (left show <$> (runClientM (idChar (Just 'c')) (ClientEnv manager baseUrl))) `shouldReturn` Right 'c'
+      (left show <$> (runClientM (getSum 3 4) (ClientEnv manager baseUrl))) `shouldReturn` Right 7
+      (left show <$> (runClientM doNothing (ClientEnv manager baseUrl))) `shouldReturn` Right ()
+
 -- * utils
 
 startWaiApp :: Application -> IO (ThreadId, BaseUrl)