From 5ead291f8dc70e51cabf00e24e3ccc901bfbcfc9 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 +++++++- servant-client/test/Servant/GenericSpec.hs | 37 ++++++++++++ 5 files changed, 114 insertions(+), 7 deletions(-) create mode 100644 servant-client/test/Servant/GenericSpec.hs diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 3d630110..118908c5 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 3ca4c88a..3c3de1a4 100644 --- a/servant-client/servant-client.cabal +++ b/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 diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index 198c6462..aedc3f91 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -65,9 +65,12 @@ import Servant.API NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), 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 @@ -107,6 +110,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 @@ -141,6 +154,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 @@ -192,7 +206,8 @@ getRoot :<|> getRedirectWithCookie :<|> EmptyClient :<|> uverbGetSuccessOrRedirect - :<|> uverbGetCreated = client api + :<|> uverbGetCreated + :<|> recordRoutes = client api server :: Application server = serve api ( @@ -229,6 +244,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 = diff --git a/servant-client/test/Servant/GenericSpec.hs b/servant-client/test/Servant/GenericSpec.hs new file mode 100644 index 00000000..9ce4f4a4 --- /dev/null +++ b/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 Data.Function ((&)) +import Test.Hspec + +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 & something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"]