git.iko.soy/typeable/servant
on master help sign in
Implementation of HasClient
5ead291Gaël Deest
servant-client-core/servant-client-core.cabal+1
compare with master
unifiedsplit
@@ -52,6 +52,7 @@ library
52 build-depends:
52 build-depends:
53 base >= 4.9 && < 4.16
53 base >= 4.9 && < 4.16
54 , bytestring >= 0.10.8.1 && < 0.12
54 , bytestring >= 0.10.8.1 && < 0.12
55+ , constraints
55 , containers >= 0.5.7.1 && < 0.7
56 , containers >= 0.5.7.1 && < 0.7
56 , deepseq >= 1.4.2.0 && < 1.5
57 , deepseq >= 1.4.2.0 && < 1.5
57 , text >= 1.2.3.0 && < 1.3
58 , text >= 1.2.3.0 && < 1.3
servant-client-core/src/Servant/Client/Generic.hs+52−6
@@ -1,15 +1,23 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
1−{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE InstanceSigs #-}
3−{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE QuantifiedConstraints #-}
4−{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE RankNTypes #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeApplications #-}
6−{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE UndecidableInstances #-}
7module Servant.Client.Generic (
14module Servant.Client.Generic (
8 AsClientT,
15 AsClientT,
9 genericClient,
16 genericClient,
10 genericClientHoist,
17 genericClientHoist,
11 ) where
18 ) where
12
19
20+import Data.Constraint (Dict(..))
13import Data.Proxy
21import Data.Proxy
14 (Proxy (..))
22 (Proxy (..))
15
23
@@ -49,3 +57,41 @@ genericClientHoist nt
49 where
57 where
50 m = Proxy :: Proxy m
58 m = Proxy :: Proxy m
51 api = Proxy :: Proxy (ToServantApi routes)
59 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
93 Servant.ConnectionErrorSpec
93 Servant.ConnectionErrorSpec
94 Servant.FailSpec
94 Servant.FailSpec
95 Servant.GenAuthSpec
95 Servant.GenAuthSpec
96+ Servant.GenericSpec
96 Servant.HoistClientSpec
97 Servant.HoistClientSpec
97 Servant.StreamSpec
98 Servant.StreamSpec
98 Servant.SuccessSpec
99 Servant.SuccessSpec
servant-client/test/Servant/ClientTestUtils.hs+23−1
@@ -65,9 +65,12 @@ import Servant.API
65 NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
65 NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
66 QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
66 QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
67 WithStatus (WithStatus), addHeader)
67 WithStatus (WithStatus), addHeader)
68+import Servant.API.Generic
68import Servant.Client
69import Servant.Client
70+import Servant.Client.Generic
69import qualified Servant.Client.Core.Auth as Auth
71import qualified Servant.Client.Core.Auth as Auth
70import Servant.Server
72import Servant.Server
73+import Servant.Server.Generic
71import Servant.Server.Experimental.Auth
74import Servant.Server.Experimental.Auth
72import Servant.Test.ComprehensiveAPI
75import Servant.Test.ComprehensiveAPI
73
76
@@ -107,6 +110,16 @@ carol = Person "Carol" 17
107
110
108type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
111type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
109
112
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+
110type Api =
123type Api =
111 Get '[JSON] Person
124 Get '[JSON] Person
112 :<|> "get" :> Get '[JSON] Person
125 :<|> "get" :> Get '[JSON] Person
@@ -141,6 +154,7 @@ type Api =
141 UVerb 'GET '[PlainText] '[WithStatus 200 Person,
154 UVerb 'GET '[PlainText] '[WithStatus 200 Person,
142 WithStatus 301 Text]
155 WithStatus 301 Text]
143 :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
156 :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
157+ :<|> NamedRoutes RecordRoutes
144
158
145
159
146api :: Proxy Api
160api :: Proxy Api
@@ -192,7 +206,8 @@ getRoot
192 :<|> getRedirectWithCookie
206 :<|> getRedirectWithCookie
193 :<|> EmptyClient
207 :<|> EmptyClient
194 :<|> uverbGetSuccessOrRedirect
208 :<|> uverbGetSuccessOrRedirect
195− :<|> uverbGetCreated = client api
209+ :<|> uverbGetCreated
210+ :<|> recordRoutes = client api
196
211
197server :: Application
212server :: Application
198server = serve api (
213server = serve api (
@@ -229,6 +244,13 @@ server = serve api (
229 then respond (WithStatus @301 ("redirecting" :: Text))
244 then respond (WithStatus @301 ("redirecting" :: Text))
230 else respond (WithStatus @200 alice ))
245 else respond (WithStatus @200 alice ))
231 :<|> respond (WithStatus @201 carol)
246 :<|> respond (WithStatus @201 carol)
247+ :<|> RecordRoutes
248+ { version = pure 42
249+ , echo = pure
250+ , otherRoutes = OtherRoutes
251+ { something = pure ["foo", "bar", "pweet"]
252+ }
253+ }
232 )
254 )
233
255
234type FailApi =
256type 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"]