Merge pull request #1388 from gdeest/generic-apis

Improve API for composing generic routes

Author: Gaël Deest

servant-client-core/servant-client-core.cabal

@@ -52,6 +52,7 @@ library
   build-depends:
       base                  >= 4.9      && < 4.16
     , bytestring            >= 0.10.8.1 && < 0.12
+    , constraints           >= 0.2      && < 0.14
     , containers            >= 0.5.7.1  && < 0.7
     , deepseq               >= 1.4.2.0  && < 1.5
     , text                  >= 1.2.3.0  && < 1.3

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

@@ -1,27 +1,26 @@
 {-# LANGUAGE ConstraintKinds       #-}
-{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE InstanceSigs          #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
 {-# LANGUAGE UndecidableInstances  #-}
 
-#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
-#define HAS_TYPE_ERROR
-#endif
-
 module Servant.Client.Core.HasClient (
     clientIn,
     HasClient (..),
     EmptyClient (..),
+    AsClientT,
+    (//),
+    (/:),
     foldMapUnion,
     matchUnion,
     ) where
@@ -39,6 +38,7 @@ import           Data.ByteString.Builder
 import qualified Data.ByteString.Lazy                     as BL
 import           Data.Either
                  (partitionEithers)
+import           Data.Constraint (Dict(..))
 import           Data.Foldable
                  (toList)
 import           Data.List
@@ -47,7 +47,8 @@ import           Data.Sequence
                  (fromList)
 import qualified Data.Text                       as T
 import           Network.HTTP.Media
-                 (MediaType, matches, parseAccept, (//))
+                 (MediaType, matches, parseAccept)
+import qualified Network.HTTP.Media as Media
 import qualified Data.Sequence as Seq
 import           Data.SOP.BasicFunctors
                  (I (I), (:.:) (Comp))
@@ -79,7 +80,10 @@ import           Servant.API
                  ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
                  StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
                  Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
-                 getResponse, toEncodedUrlPiece, toUrlPiece)
+                 getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
+import           Servant.API.Generic
+                 (GenericMode(..), ToServant, ToServantApi
+                 , GenericServant, toServant, fromServant)
 import           Servant.API.ContentTypes
                  (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
 import           Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
@@ -792,11 +796,7 @@ instance ( HasClient m api
 -- > getBooks = client myApi
 -- > -- then you can just use "getBooksBy" to query that endpoint.
 -- > -- 'getBooks' for all books.
-#ifdef HAS_TYPE_ERROR
 instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
-#else
-instance ( HasClient m api
-#endif
          ) => HasClient m (Fragment a :> api) where
 
   type Client m (Fragment a :> api) = Client m api
@@ -816,6 +816,119 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
   hoistClientMonad pm _ f cl = \bauth ->
     hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
 
+-- | A type that specifies that an API record contains a client implementation.
+data AsClientT (m :: * -> *)
+instance GenericMode (AsClientT m) where
+    type AsClientT m :- api = Client m api
+
+
+type GClientConstraints api m =
+  ( GenericServant api (AsClientT m)
+  , Client m (ToServantApi api) ~ ToServant api (AsClientT m)
+  )
+
+class GClient (api :: * -> *) m where
+  proof :: Dict (GClientConstraints api m)
+
+instance GClientConstraints api m => GClient api m where
+  proof = Dict
+
+instance
+  ( forall n. GClient api n
+  , HasClient m (ToServantApi api)
+  , RunClient m
+  )
+  => HasClient m (NamedRoutes api) where
+  type Client m (NamedRoutes api) = api (AsClientT m)
+
+  clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
+  clientWithRoute pm _ request =
+    case proof @api @m of
+      Dict -> fromServant $ clientWithRoute  pm (Proxy @(ToServantApi api)) request
+
+  hoistClientMonad
+    :: forall ma mb.
+       Proxy m
+    -> Proxy (NamedRoutes api)
+    -> (forall x. ma x -> mb x)
+    -> Client ma (NamedRoutes api)
+    -> Client mb (NamedRoutes api)
+  hoistClientMonad _ _ nat clientA =
+    case (proof @api @ma, proof @api @mb) of
+      (Dict, Dict) ->
+        fromServant @api @(AsClientT mb) $
+        hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
+        toServant @api @(AsClientT ma) clientA
+
+infixl 1 //
+infixl 2 /:
+
+-- | Helper to make code using records of clients more readable.
+--
+-- Can be mixed with (/:) for supplying arguments.
+--
+-- Example:
+--
+-- @@
+-- type Api = NamedRoutes RootApi
+--
+-- data RootApi mode = RootApi
+--   { subApi :: mode :- NamedRoutes SubApi
+--   , …
+--   } deriving Generic
+--
+-- data SubApi mode = SubApi
+--   { endpoint :: mode :- Get '[JSON] Person
+--   , …
+--   } deriving Generic
+--
+-- api :: Proxy API
+-- api = Proxy
+--
+-- rootClient :: RootApi (AsClientT ClientM)
+-- rootClient = client api
+--
+-- endpointClient :: ClientM Person
+-- endpointClient = client // subApi // endpoint
+-- @@
+(//) :: a -> (a -> b) -> b
+x // f = f x
+
+-- | Convenience function for supplying arguments to client functions when
+-- working with records of clients.
+--
+-- Intended to be used in conjunction with '(//)'.
+--
+-- Example:
+--
+-- @@
+-- type Api = NamedRoutes RootApi
+--
+-- data RootApi mode = RootApi
+--   { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
+--   , hello :: mode :- Capture "name" String :> Get '[JSON] String
+--   , …
+--   } deriving Generic
+--
+-- data SubApi mode = SubApi
+--   { endpoint :: mode :- Get '[JSON] Person
+--   , …
+--   } deriving Generic
+--
+-- api :: Proxy API
+-- api = Proxy
+--
+-- rootClient :: RootApi (AsClientT ClientM)
+-- rootClient = client api
+--
+-- hello :: String -> ClientM String
+-- hello name = rootClient // hello /: name
+--
+-- endpointClient :: ClientM Person
+-- endpointClient = client // subApi /: "foobar123" // endpoint
+-- @@
+(/:) :: (a -> b -> c) -> b -> a -> c
+(/:) = flip
 
 
 {- Note [Non-Empty Content Types]
@@ -841,7 +954,7 @@ for empty and one for non-empty lists).
 checkContentTypeHeader :: RunClient m => Response -> m MediaType
 checkContentTypeHeader response =
   case lookup "Content-Type" $ toList $ responseHeaders response of
-    Nothing -> return $ "application"//"octet-stream"
+    Nothing -> return $ "application" Media.// "octet-stream"
     Just t -> case parseAccept t of
       Nothing -> throwClientError $ InvalidContentTypeHeader response
       Just t' -> return t'

servant-client-core/src/Servant/Client/Core/Reexport.hs

@@ -7,6 +7,9 @@ module Servant.Client.Core.Reexport
     HasClient(..)
   , foldMapUnion
   , matchUnion
+  , AsClientT
+  , (//)
+  , (/:)
 
     -- * Response (for @Raw@)
   , Response
@@ -23,6 +26,7 @@ module Servant.Client.Core.Reexport
   , showBaseUrl
   , parseBaseUrl
   , InvalidBaseUrlException
+
   ) where
 
 

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

@@ -1,9 +1,10 @@
-{-# LANGUAGE ConstraintKinds     #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE KindSignatures      #-}
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies        #-}
+{-# OPTIONS_GHC -fno-warn-orphans  #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeFamilies          #-}
+
 module  Servant.Client.Generic (
     AsClientT,
     genericClient,
@@ -15,11 +16,7 @@ import           Data.Proxy
 
 import           Servant.API.Generic
 import           Servant.Client.Core
-
--- | A type that specifies that an API record contains a client implementation.
-data AsClientT (m :: * -> *)
-instance GenericMode (AsClientT m) where
-    type AsClientT m :- api = Client m api
+import           Servant.Client.Core.HasClient (AsClientT)
 
 -- | Generate a record of client functions.
 genericClient

servant-client/servant-client.cabal

@@ -93,6 +93,7 @@ test-suite spec
       Servant.ConnectionErrorSpec
       Servant.FailSpec
       Servant.GenAuthSpec
+      Servant.GenericSpec
       Servant.HoistClientSpec
       Servant.StreamSpec
       Servant.SuccessSpec

servant-client/test/Servant/ClientTestUtils.hs

@@ -64,7 +64,8 @@ import           Servant.API
                  JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
                  NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
                  QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
-                 WithStatus (WithStatus), addHeader)
+                 WithStatus (WithStatus), NamedRoutes, addHeader)
+import           Servant.API.Generic ((:-))
 import           Servant.Client
 import qualified Servant.Client.Core.Auth         as Auth
 import           Servant.Server
@@ -107,6 +108,16 @@ carol = Person "Carol" 17
 
 type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
 
+data RecordRoutes mode = RecordRoutes
+  { version :: mode :- "version" :> Get '[JSON] Int
+  , echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String
+  , otherRoutes :: mode :- "other" :> Capture "someParam" Int :> NamedRoutes OtherRoutes
+  } deriving Generic
+
+data OtherRoutes mode = OtherRoutes
+  { something :: mode :- "something" :> Get '[JSON] [String]
+  } deriving Generic
+
 type Api =
   Get '[JSON] Person
   :<|> "get" :> Get '[JSON] Person
@@ -141,6 +152,7 @@ type Api =
             UVerb 'GET '[PlainText] '[WithStatus 200 Person,
                                       WithStatus 301 Text]
   :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
+  :<|> NamedRoutes RecordRoutes
 
 
 api :: Proxy Api
@@ -170,6 +182,7 @@ uverbGetSuccessOrRedirect :: Bool
                           -> ClientM (Union '[WithStatus 200 Person,
                                               WithStatus 301 Text])
 uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])
+recordRoutes :: RecordRoutes (AsClientT ClientM)
 
 getRoot
   :<|> getGet
@@ -192,7 +205,8 @@ getRoot
   :<|> getRedirectWithCookie
   :<|> EmptyClient
   :<|> uverbGetSuccessOrRedirect
-  :<|> uverbGetCreated = client api
+  :<|> uverbGetCreated
+  :<|> recordRoutes = client api
 
 server :: Application
 server = serve api (
@@ -229,6 +243,13 @@ server = serve api (
                               then respond (WithStatus @301 ("redirecting" :: Text))
                               else respond (WithStatus @200 alice ))
   :<|> respond (WithStatus @201 carol)
+  :<|> RecordRoutes
+         { version = pure 42
+         , echo = pure
+         , otherRoutes = \_ -> OtherRoutes
+             { something = pure ["foo", "bar", "pweet"]
+             }
+         }
   )
 
 type FailApi =

servant-client/test/Servant/GenericSpec.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE CPP                    #-}
+{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE DataKinds              #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE GADTs                  #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE PolyKinds              #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
+{-# OPTIONS_GHC -freduction-depth=100 #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Servant.GenericSpec (spec) where
+
+import           Test.Hspec
+
+import           Servant.Client ((//), (/:))
+import           Servant.ClientTestUtils
+
+spec :: Spec
+spec = describe "Servant.GenericSpec" $ do
+    genericSpec
+
+genericSpec :: Spec
+genericSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
+  context "Record clients work as expected" $ do
+
+    it "Client functions return expected values" $ \(_,baseUrl) -> do
+      runClient (recordRoutes // version) baseUrl `shouldReturn` Right 42
+      runClient (recordRoutes // echo /: "foo") baseUrl `shouldReturn` Right "foo"
+    it "Clients can be nested" $ \(_,baseUrl) -> do
+      runClient (recordRoutes // otherRoutes /: 42 // something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"]