git.iko.soy/typeable/servant
on master help sign in
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).

commit5ead291f8dc70e51cabf00e24e3ccc901bfbcfc9 authorGaël Deest <gael.deest@tweag.io> dateFri 1 Oct 2021, 02:24 (5 years ago) parentb0b02f1
5 files changed+114−7
compare with master
unifiedsplit
servant-client-core/servant-client-core.cabal+1 servant-client-core/src/Servant/Client/Generic.hs+52−6 servant-client/servant-client.cabal+1 servant-client/test/Servant/ClientTestUtils.hs+23−1 servant-client/test/Servant/GenericSpec.hs+37
servant-client-core/servant-client-core.cabal+1
@@ -52,6 +52,7 @@ library
5252 build-depends:
5353 base >= 4.9 && < 4.16
5454 , bytestring >= 0.10.8.1 && < 0.12
55+ , constraints
5556 , containers >= 0.5.7.1 && < 0.7
5657 , deepseq >= 1.4.2.0 && < 1.5
5758 , text >= 1.2.3.0 && < 1.3
servant-client-core/src/Servant/Client/Generic.hs+52−6
@@ -1,15 +1,23 @@
1−{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE KindSignatures #-}
4−{-# LANGUAGE RankNTypes #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TypeFamilies #-}
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE InstanceSigs #-}
6+{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE QuantifiedConstraints #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeApplications #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE UndecidableInstances #-}
714module Servant.Client.Generic (
815 AsClientT,
916 genericClient,
1017 genericClientHoist,
1118 ) where
1219
20+import Data.Constraint (Dict(..))
1321import Data.Proxy
1422 (Proxy (..))
1523
@@ -49,3 +57,41 @@ genericClientHoist nt
4957 where
5058 m = Proxy :: Proxy m
5159 api = Proxy :: Proxy (ToServantApi routes)
60+
61+type GClientConstraints api m =
62+ ( GenericServant api (AsClientT m)
63+ , Client m (ToServantApi api) ~ ToServant api (AsClientT m)
64+ )
65+
66+class GClient (api :: * -> *) m where
67+ proof :: Dict (GClientConstraints api m)
68+
69+instance GClientConstraints api m => GClient api m where
70+ proof = Dict
71+
72+instance
73+ ( forall n. GClient api n
74+ , HasClient m (ToServantApi api)
75+ , RunClient m
76+ )
77+ => HasClient m (NamedRoutes api) where
78+ type Client m (NamedRoutes api) = api (AsClientT m)
79+
80+ clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
81+ clientWithRoute pm _ request =
82+ case proof @api @m of
83+ Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
84+
85+ hoistClientMonad
86+ :: forall ma mb.
87+ Proxy m
88+ -> Proxy (NamedRoutes api)
89+ -> (forall x. ma x -> mb x)
90+ -> Client ma (NamedRoutes api)
91+ -> Client mb (NamedRoutes api)
92+ hoistClientMonad _ _ nat clientA =
93+ case (proof @api @ma, proof @api @mb) of
94+ (Dict, Dict) ->
95+ fromServant @api @(AsClientT mb) $
96+ hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
97+ toServant @api @(AsClientT ma) clientA
servant-client/servant-client.cabal+1
@@ -93,6 +93,7 @@ test-suite spec
9393 Servant.ConnectionErrorSpec
9494 Servant.FailSpec
9595 Servant.GenAuthSpec
96+ Servant.GenericSpec
9697 Servant.HoistClientSpec
9798 Servant.StreamSpec
9899 Servant.SuccessSpec
servant-client/test/Servant/ClientTestUtils.hs+23−1
@@ -65,9 +65,12 @@ import Servant.API
6565 NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
6666 QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
6767 WithStatus (WithStatus), addHeader)
68+import Servant.API.Generic
6869import Servant.Client
70+import Servant.Client.Generic
6971import qualified Servant.Client.Core.Auth as Auth
7072import Servant.Server
73+import Servant.Server.Generic
7174import Servant.Server.Experimental.Auth
7275import Servant.Test.ComprehensiveAPI
7376
@@ -107,6 +110,16 @@ carol = Person "Carol" 17
107110
108111type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
109112
113+data RecordRoutes mode = RecordRoutes
114+ { version :: mode :- "version" :> Get '[JSON] Int
115+ , echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String
116+ , otherRoutes :: mode :- "other" :> NamedRoutes OtherRoutes
117+ } deriving Generic
118+
119+data OtherRoutes mode = OtherRoutes
120+ { something :: mode :- "something" :> Get '[JSON] [String]
121+ } deriving Generic
122+
110123type Api =
111124 Get '[JSON] Person
112125 :<|> "get" :> Get '[JSON] Person
@@ -141,6 +154,7 @@ type Api =
141154 UVerb 'GET '[PlainText] '[WithStatus 200 Person,
142155 WithStatus 301 Text]
143156 :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
157+ :<|> NamedRoutes RecordRoutes
144158
145159
146160api :: Proxy Api
@@ -192,7 +206,8 @@ getRoot
192206 :<|> getRedirectWithCookie
193207 :<|> EmptyClient
194208 :<|> uverbGetSuccessOrRedirect
195− :<|> uverbGetCreated = client api
209+ :<|> uverbGetCreated
210+ :<|> recordRoutes = client api
196211
197212server :: Application
198213server = serve api (
@@ -229,6 +244,13 @@ server = serve api (
229244 then respond (WithStatus @301 ("redirecting" :: Text))
230245 else respond (WithStatus @200 alice ))
231246 :<|> respond (WithStatus @201 carol)
247+ :<|> RecordRoutes
248+ { version = pure 42
249+ , echo = pure
250+ , otherRoutes = OtherRoutes
251+ { something = pure ["foo", "bar", "pweet"]
252+ }
253+ }
232254 )
233255
234256type FailApi =
servant-client/test/Servant/GenericSpec.hsnew file+37
@@ -0,0 +1,37 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+{-# OPTIONS_GHC -freduction-depth=100 #-}
15+{-# OPTIONS_GHC -fno-warn-orphans #-}
16+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
17+
18+module Servant.GenericSpec (spec) where
19+
20+import Data.Function ((&))
21+import Test.Hspec
22+
23+import Servant.ClientTestUtils
24+
25+spec :: Spec
26+spec = describe "Servant.GenericSpec" $ do
27+ genericSpec
28+
29+genericSpec :: Spec
30+genericSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
31+ context "Record clients work as expected" $ do
32+
33+ it "Client functions return expected values" $ \(_,baseUrl) -> do
34+ runClient (recordRoutes & version) baseUrl `shouldReturn` Right 42
35+ runClient (recordRoutes & echo $ "foo") baseUrl `shouldReturn` Right "foo"
36+ it "Clients can be nested" $ \(_,baseUrl) -> do
37+ runClient (recordRoutes & otherRoutes & something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"]