From 7e8a1b240d0d8dc1f6b729189b98087612c693d7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Fri, 1 Oct 2021 02:24:21 +0200 Subject: [PATCH] Implementation of HasClient Follows the same design as `HasServer` in the previous commit. A test has been added (which incidentally acts as a test for the HasServer instance). --- servant-client-core/servant-client-core.cabal | 1 + .../src/Servant/Client/Generic.hs | 58 +++++++++++++++++-- servant-client/servant-client.cabal | 1 + .../test/Servant/ClientTestUtils.hs | 24 +++++++- 4 files changed, 77 insertions(+), 7 deletions(-) diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index b1008f36..0d1c2f80 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/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 , containers >= 0.5.7.1 && < 0.7 , deepseq >= 1.4.2.0 && < 1.5 , text >= 1.2.3.0 && < 1.3 diff --git a/servant-client-core/src/Servant/Client/Generic.hs b/servant-client-core/src/Servant/Client/Generic.hs index 836c6599..aee599d4 100644 --- a/servant-client-core/src/Servant/Client/Generic.hs +++ b/servant-client-core/src/Servant/Client/Generic.hs @@ -1,15 +1,23 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Servant.Client.Generic ( AsClientT, genericClient, genericClientHoist, ) where +import Data.Constraint (Dict(..)) import Data.Proxy (Proxy (..)) @@ -49,3 +57,41 @@ genericClientHoist nt where m = Proxy :: Proxy m api = Proxy :: Proxy (ToServantApi routes) + +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 diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 8f69a4ad..31425582 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -90,6 +90,7 @@ test-suite spec Servant.ConnectionErrorSpec Servant.FailSpec Servant.GenAuthSpec + Servant.GenericSpec Servant.HoistClientSpec Servant.StreamSpec Servant.SuccessSpec diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index 842712e1..72663fde 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -59,9 +59,12 @@ import Servant.API NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody, StdMethod (GET), UVerb, Union, WithStatus (WithStatus), addHeader) +import Servant.API.Generic import Servant.Client +import Servant.Client.Generic import qualified Servant.Client.Core.Auth as Auth import Servant.Server +import Servant.Server.Generic import Servant.Server.Experimental.Auth import Servant.Test.ComprehensiveAPI @@ -101,6 +104,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" :> 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 @@ -131,6 +144,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 @@ -180,7 +194,8 @@ getRoot :<|> getRedirectWithCookie :<|> EmptyClient :<|> uverbGetSuccessOrRedirect - :<|> uverbGetCreated = client api + :<|> uverbGetCreated + :<|> recordRoutes = client api server :: Application server = serve api ( @@ -210,6 +225,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 =