git.iko.soy/typeable/servant
on master help sign in
Merge pull request #60 from codedmart/fix-baseurl

make BaseUrl an argument to 'client' instead of each function produced by 'client'

commitfc517a2f85cab84f17ccf2d7cb58e3b169f78195 authorJulian Arni <jkarni@gmail.com> dateSat 9 May 2015, 02:28 (11 years ago) parentc758e4bbc8efb2
4 files changed+305−271
compare with master
unifiedsplit
servant-client/src/Servant/Client.hs+121−94 servant-client/test/Servant/ClientSpec.hs+169−165 servant-client/test/Spec.hs+7−1 servant-examples/hackage/hackage.hs+8−11
servant-client/src/Servant/Client.hs+121−94
@@ -52,16 +52,17 @@ import Servant.Common.Req
5252-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
5353-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
5454-- > (getAllBooks :<|> postNewBook) = client myApi
55−client :: HasClient layout => Proxy layout -> Client layout
56−client p = clientWithRoute p defReq
55+client :: HasClient layout => Proxy layout -> BaseUrl -> Client layout
56+client p baseurl = clientWithRoute p defReq baseurl
5757
5858-- | This class lets us define how each API combinator
5959-- influences the creation of an HTTP request. It's mostly
6060-- an internal class, you can just use 'client'.
6161class HasClient layout where
6262 type Client layout :: *
63− clientWithRoute :: Proxy layout -> Req -> Client layout
63+ clientWithRoute :: Proxy layout -> Req -> BaseUrl -> Client layout
6464
65+{-type Client layout = Client layout-}
6566
6667-- | A client querying function for @a ':<|>' b@ will actually hand you
6768-- one function for querying @a@ and another one for querying @b@,
@@ -78,9 +79,9 @@ class HasClient layout where
7879-- > (getAllBooks :<|> postNewBook) = client myApi
7980instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
8081 type Client (a :<|> b) = Client a :<|> Client b
81− clientWithRoute Proxy req =
82− clientWithRoute (Proxy :: Proxy a) req :<|>
83− clientWithRoute (Proxy :: Proxy b) req
82+ clientWithRoute Proxy req baseurl =
83+ clientWithRoute (Proxy :: Proxy a) req baseurl :<|>
84+ clientWithRoute (Proxy :: Proxy b) req baseurl
8485
8586-- | If you use a 'Capture' in one of your endpoints in your API,
8687-- the corresponding querying function will automatically take
@@ -107,9 +108,10 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
107108 type Client (Capture capture a :> sublayout) =
108109 a -> Client sublayout
109110
110− clientWithRoute Proxy req val =
111− clientWithRoute (Proxy :: Proxy sublayout) $
112− appendToPath p req
111+ clientWithRoute Proxy req baseurl val =
112+ clientWithRoute (Proxy :: Proxy sublayout)
113+ (appendToPath p req)
114+ baseurl
113115
114116 where p = unpack (toText val)
115117
@@ -122,9 +124,9 @@ instance
122124 {-# OVERLAPPABLE #-}
123125#endif
124126 (MimeUnrender ct a) => HasClient (Delete (ct ': cts) a) where
125− type Client (Delete (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
126− clientWithRoute Proxy req host =
127− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] host
127+ type Client (Delete (ct ': cts) a) = EitherT ServantError IO a
128+ clientWithRoute Proxy req baseurl =
129+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl
128130
129131-- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content
130132-- HTTP header.
@@ -133,9 +135,9 @@ instance
133135 {-# OVERLAPPING #-}
134136#endif
135137 HasClient (Delete (ct ': cts) ()) where
136− type Client (Delete (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
137− clientWithRoute Proxy req host =
138− void $ performRequestNoBody H.methodDelete req [204] host
138+ type Client (Delete (ct ': cts) ()) = EitherT ServantError IO ()
139+ clientWithRoute Proxy req baseurl =
140+ void $ performRequestNoBody H.methodDelete req [204] baseurl
139141
140142-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the
141143-- corresponding headers.
@@ -145,14 +147,13 @@ instance
145147#endif
146148 ( MimeUnrender ct a, BuildHeadersTo ls
147149 ) => HasClient (Delete (ct ': cts) (Headers ls a)) where
148− type Client (Delete (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
149− clientWithRoute Proxy req host = do
150− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] host
150+ type Client (Delete (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)
151+ clientWithRoute Proxy req baseurl = do
152+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl
151153 return $ Headers { getResponse = resp
152154 , getHeadersHList = buildHeadersTo hdrs
153155 }
154156
155−
156157-- | If you have a 'Get' endpoint in your API, the client
157158-- side querying function that is created when calling 'client'
158159-- will just require an argument that specifies the scheme, host
@@ -162,9 +163,9 @@ instance
162163 {-# OVERLAPPABLE #-}
163164#endif
164165 (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
165− type Client (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
166− clientWithRoute Proxy req host =
167− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host
166+ type Client (Get (ct ': cts) result) = EitherT ServantError IO result
167+ clientWithRoute Proxy req baseurl =
168+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] baseurl
168169
169170-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content
170171-- HTTP status.
@@ -173,9 +174,9 @@ instance
173174 {-# OVERLAPPING #-}
174175#endif
175176 HasClient (Get (ct ': cts) ()) where
176− type Client (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
177− clientWithRoute Proxy req host =
178− performRequestNoBody H.methodGet req [204] host
177+ type Client (Get (ct ': cts) ()) = EitherT ServantError IO ()
178+ clientWithRoute Proxy req baseurl =
179+ performRequestNoBody H.methodGet req [204] baseurl
179180
180181-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the
181182-- corresponding headers.
@@ -185,9 +186,9 @@ instance
185186#endif
186187 ( MimeUnrender ct a, BuildHeadersTo ls
187188 ) => HasClient (Get (ct ': cts) (Headers ls a)) where
188− type Client (Get (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
189− clientWithRoute Proxy req host = do
190− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] host
189+ type Client (Get (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)
190+ clientWithRoute Proxy req baseurl = do
191+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] baseurl
191192 return $ Headers { getResponse = resp
192193 , getHeadersHList = buildHeadersTo hdrs
193194 }
@@ -223,9 +224,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
223224 type Client (Header sym a :> sublayout) =
224225 Maybe a -> Client sublayout
225226
226− clientWithRoute Proxy req mval =
227− clientWithRoute (Proxy :: Proxy sublayout) $
228− maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval
227+ clientWithRoute Proxy req baseurl mval =
228+ clientWithRoute (Proxy :: Proxy sublayout)
229+ (maybe req
230+ (\value -> Servant.Common.Req.addHeader hname value req)
231+ mval
232+ )
233+ baseurl
229234
230235 where hname = symbolVal (Proxy :: Proxy sym)
231236
@@ -238,10 +243,9 @@ instance
238243 {-# OVERLAPPABLE #-}
239244#endif
240245 (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
241− type Client (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
242−
243− clientWithRoute Proxy req uri =
244− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri
246+ type Client (Post (ct ': cts) a) = EitherT ServantError IO a
247+ clientWithRoute Proxy req baseurl =
248+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] baseurl
245249
246250-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content
247251-- HTTP header.
@@ -250,9 +254,9 @@ instance
250254 {-# OVERLAPPING #-}
251255#endif
252256 HasClient (Post (ct ': cts) ()) where
253− type Client (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
254− clientWithRoute Proxy req host =
255− void $ performRequestNoBody H.methodPost req [204] host
257+ type Client (Post (ct ': cts) ()) = EitherT ServantError IO ()
258+ clientWithRoute Proxy req baseurl =
259+ void $ performRequestNoBody H.methodPost req [204] baseurl
256260
257261-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the
258262-- corresponding headers.
@@ -262,9 +266,9 @@ instance
262266#endif
263267 ( MimeUnrender ct a, BuildHeadersTo ls
264268 ) => HasClient (Post (ct ': cts) (Headers ls a)) where
265− type Client (Post (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
266− clientWithRoute Proxy req host = do
267− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] host
269+ type Client (Post (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)
270+ clientWithRoute Proxy req baseurl = do
271+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] baseurl
268272 return $ Headers { getResponse = resp
269273 , getHeadersHList = buildHeadersTo hdrs
270274 }
@@ -278,10 +282,9 @@ instance
278282 {-# OVERLAPPABLE #-}
279283#endif
280284 (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
281− type Client (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
282−
283− clientWithRoute Proxy req host =
284− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host
285+ type Client (Put (ct ': cts) a) = EitherT ServantError IO a
286+ clientWithRoute Proxy req baseurl =
287+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] baseurl
285288
286289-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content
287290-- HTTP header.
@@ -290,9 +293,9 @@ instance
290293 {-# OVERLAPPING #-}
291294#endif
292295 HasClient (Put (ct ': cts) ()) where
293− type Client (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
294− clientWithRoute Proxy req host =
295− void $ performRequestNoBody H.methodPut req [204] host
296+ type Client (Put (ct ': cts) ()) = EitherT ServantError IO ()
297+ clientWithRoute Proxy req baseurl =
298+ void $ performRequestNoBody H.methodPut req [204] baseurl
296299
297300-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the
298301-- corresponding headers.
@@ -302,9 +305,9 @@ instance
302305#endif
303306 ( MimeUnrender ct a, BuildHeadersTo ls
304307 ) => HasClient (Put (ct ': cts) (Headers ls a)) where
305− type Client (Put (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
306− clientWithRoute Proxy req host = do
307− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] host
308+ type Client (Put (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)
309+ clientWithRoute Proxy req baseurl = do
310+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] baseurl
308311 return $ Headers { getResponse = resp
309312 , getHeadersHList = buildHeadersTo hdrs
310313 }
@@ -318,10 +321,9 @@ instance
318321 {-# OVERLAPPABLE #-}
319322#endif
320323 (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
321− type Client (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
322−
323− clientWithRoute Proxy req host =
324− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host
324+ type Client (Patch (ct ': cts) a) = EitherT ServantError IO a
325+ clientWithRoute Proxy req baseurl =
326+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] baseurl
325327
326328-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content
327329-- HTTP header.
@@ -330,9 +332,9 @@ instance
330332 {-# OVERLAPPING #-}
331333#endif
332334 HasClient (Patch (ct ': cts) ()) where
333− type Client (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
334− clientWithRoute Proxy req host =
335− void $ performRequestNoBody H.methodPatch req [204] host
335+ type Client (Patch (ct ': cts) ()) = EitherT ServantError IO ()
336+ clientWithRoute Proxy req baseurl =
337+ void $ performRequestNoBody H.methodPatch req [204] baseurl
336338
337339-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the
338340-- corresponding headers.
@@ -342,9 +344,9 @@ instance
342344#endif
343345 ( MimeUnrender ct a, BuildHeadersTo ls
344346 ) => HasClient (Patch (ct ': cts) (Headers ls a)) where
345− type Client (Patch (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
346− clientWithRoute Proxy req host = do
347− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] host
347+ type Client (Patch (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)
348+ clientWithRoute Proxy req baseurl = do
349+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] baseurl
348350 return $ Headers { getResponse = resp
349351 , getHeadersHList = buildHeadersTo hdrs
350352 }
@@ -381,9 +383,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
381383 Maybe a -> Client sublayout
382384
383385 -- if mparam = Nothing, we don't add it to the query string
384− clientWithRoute Proxy req mparam =
385− clientWithRoute (Proxy :: Proxy sublayout) $
386− maybe req (flip (appendToQueryString pname) req . Just) mparamText
386+ clientWithRoute Proxy req baseurl mparam =
387+ clientWithRoute (Proxy :: Proxy sublayout)
388+ (maybe req
389+ (flip (appendToQueryString pname) req . Just)
390+ mparamText
391+ )
392+ baseurl
387393
388394 where pname = cs pname'
389395 pname' = symbolVal (Proxy :: Proxy sym)
@@ -422,9 +428,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
422428 type Client (QueryParams sym a :> sublayout) =
423429 [a] -> Client sublayout
424430
425− clientWithRoute Proxy req paramlist =
426− clientWithRoute (Proxy :: Proxy sublayout) $
427− foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist'
431+ clientWithRoute Proxy req baseurl paramlist =
432+ clientWithRoute (Proxy :: Proxy sublayout)
433+ (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
434+ req
435+ paramlist'
436+ )
437+ baseurl
428438
429439 where pname = cs pname'
430440 pname' = symbolVal (Proxy :: Proxy sym)
@@ -457,11 +467,13 @@ instance (KnownSymbol sym, HasClient sublayout)
457467 type Client (QueryFlag sym :> sublayout) =
458468 Bool -> Client sublayout
459469
460− clientWithRoute Proxy req flag =
461− clientWithRoute (Proxy :: Proxy sublayout) $
462− if flag
463− then appendToQueryString paramname Nothing req
464− else req
470+ clientWithRoute Proxy req baseurl flag =
471+ clientWithRoute (Proxy :: Proxy sublayout)
472+ (if flag
473+ then appendToQueryString paramname Nothing req
474+ else req
475+ )
476+ baseurl
465477
466478 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
467479
@@ -497,9 +509,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
497509 Maybe a -> Client sublayout
498510
499511 -- if mparam = Nothing, we don't add it to the query string
500− clientWithRoute Proxy req mparam =
501− clientWithRoute (Proxy :: Proxy sublayout) $
502− maybe req (flip (appendToMatrixParams pname . Just) req) mparamText
512+ clientWithRoute Proxy req baseurl mparam =
513+ clientWithRoute (Proxy :: Proxy sublayout)
514+ (maybe req
515+ (flip (appendToMatrixParams pname . Just) req)
516+ mparamText
517+ )
518+ baseurl
503519
504520 where pname = symbolVal (Proxy :: Proxy sym)
505521 mparamText = fmap (cs . toText) mparam
@@ -537,9 +553,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
537553 type Client (MatrixParams sym a :> sublayout) =
538554 [a] -> Client sublayout
539555
540− clientWithRoute Proxy req paramlist =
541− clientWithRoute (Proxy :: Proxy sublayout) $
542− foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value) req paramlist'
556+ clientWithRoute Proxy req baseurl paramlist =
557+ clientWithRoute (Proxy :: Proxy sublayout)
558+ (foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value)
559+ req
560+ paramlist'
561+ )
562+ baseurl
543563
544564 where pname = cs pname'
545565 pname' = symbolVal (Proxy :: Proxy sym)
@@ -572,22 +592,24 @@ instance (KnownSymbol sym, HasClient sublayout)
572592 type Client (MatrixFlag sym :> sublayout) =
573593 Bool -> Client sublayout
574594
575− clientWithRoute Proxy req flag =
576− clientWithRoute (Proxy :: Proxy sublayout) $
577− if flag
578− then appendToMatrixParams paramname Nothing req
579− else req
595+ clientWithRoute Proxy req baseurl flag =
596+ clientWithRoute (Proxy :: Proxy sublayout)
597+ (if flag
598+ then appendToMatrixParams paramname Nothing req
599+ else req
600+ )
601+ baseurl
580602
581603 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
582604
583605-- | Pick a 'Method' and specify where the server you want to query is. You get
584606-- back the full `Response`.
585607instance HasClient Raw where
586− type Client Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
608+ type Client Raw = H.Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
587609
588− clientWithRoute :: Proxy Raw -> Req -> Client Raw
589− clientWithRoute Proxy req httpMethod host = do
590− performRequest httpMethod req (const True) host
610+ clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Client Raw
611+ clientWithRoute Proxy req baseurl httpMethod = do
612+ performRequest httpMethod req (const True) baseurl
591613
592614-- | If you use a 'ReqBody' in one of your endpoints in your API,
593615-- the corresponding querying function will automatically take
@@ -613,18 +635,23 @@ instance (MimeRender ct a, HasClient sublayout)
613635 type Client (ReqBody (ct ': cts) a :> sublayout) =
614636 a -> Client sublayout
615637
616− clientWithRoute Proxy req body =
617− clientWithRoute (Proxy :: Proxy sublayout) $ do
618− let ctProxy = Proxy :: Proxy ct
619− setRQBody (mimeRender ctProxy body) (contentType ctProxy) req
638+ clientWithRoute Proxy req baseurl body =
639+ clientWithRoute (Proxy :: Proxy sublayout)
640+ (let ctProxy = Proxy :: Proxy ct
641+ in setRQBody (mimeRender ctProxy body)
642+ (contentType ctProxy)
643+ req
644+ )
645+ baseurl
620646
621647-- | Make the querying function append @path@ to the request path.
622648instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
623649 type Client (path :> sublayout) = Client sublayout
624650
625− clientWithRoute Proxy req =
626− clientWithRoute (Proxy :: Proxy sublayout) $
627− appendToPath p req
651+ clientWithRoute Proxy req baseurl =
652+ clientWithRoute (Proxy :: Proxy sublayout)
653+ (appendToPath p req)
654+ baseurl
628655
629656 where p = symbolVal (Proxy :: Proxy path)
630657
servant-client/test/Servant/ClientSpec.hs+169−165
@@ -9,6 +9,7 @@
99{-# LANGUAGE TypeOperators #-}
1010{-# OPTIONS_GHC -fcontext-stack=100 #-}
1111{-# OPTIONS_GHC -fno-warn-orphans #-}
12+
1213module Servant.ClientSpec where
1314
1415#if !MIN_VERSION_base(4,8,0)
@@ -80,7 +81,6 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
8081type Api =
8182 "get" :> Get '[JSON] Person
8283 :<|> "delete" :> Delete '[JSON] ()
83− :<|> "deleteString" :> Delete '[JSON] String
8484 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
8585 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
8686 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
@@ -105,7 +105,6 @@ server :: Application
105105server = serve api (
106106 return alice
107107 :<|> return ()
108− :<|> return "ok"
109108 :<|> (\ name -> return $ Person name 0)
110109 :<|> return
111110 :<|> (\ name -> case name of
@@ -129,42 +128,6 @@ server = serve api (
129128withServer :: (BaseUrl -> IO a) -> IO a
130129withServer action = withWaiDaemon (return server) action
131130
132−getGet :: BaseUrl -> EitherT ServantError IO Person
133−getDelete :: BaseUrl -> EitherT ServantError IO ()
134−getDeleteString :: BaseUrl -> EitherT ServantError IO String
135−getCapture :: String -> BaseUrl -> EitherT ServantError IO Person
136−getBody :: Person -> BaseUrl -> EitherT ServantError IO Person
137−getQueryParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
138−getQueryParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
139−getQueryFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
140−getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
141−getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
142−getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
143−getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,
144− MediaType, [HTTP.Header], C.Response ByteString)
145−getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,
146− MediaType, [HTTP.Header], C.Response ByteString)
147−getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
148− -> BaseUrl
149− -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
150−getRespHeaders :: BaseUrl -> EitherT ServantError IO (Headers TestHeaders Bool)
151−( getGet
152− :<|> getDelete
153− :<|> getDeleteString
154− :<|> getCapture
155− :<|> getBody
156− :<|> getQueryParam
157− :<|> getQueryParams
158− :<|> getQueryFlag
159− :<|> getMatrixParam
160− :<|> getMatrixParams
161− :<|> getMatrixFlag
162− :<|> getRawSuccess
163− :<|> getRawFailure
164− :<|> getMultiple
165− :<|> getRespHeaders)
166− = client api
167−
168131type FailApi =
169132 "get" :> Raw
170133 :<|> "capture" :> Capture "name" String :> Raw
@@ -182,141 +145,182 @@ failServer = serve failApi (
182145withFailServer :: (BaseUrl -> IO a) -> IO a
183146withFailServer action = withWaiDaemon (return failServer) action
184147
185−spec :: Spec
186−spec = do
187− it "Servant.API.Get" $ withServer $ \ host -> do
188− (Arrow.left show <$> runEitherT (getGet host)) `shouldReturn` Right alice
189−
190− context "Servant.API.Delete" $ do
191− it "return no body" $ withServer $ \ host -> do
192− (Arrow.left show <$> runEitherT (getDelete host)) `shouldReturn` Right ()
193−
194− it "return body" $ withServer $ \ host -> do
195− (Arrow.left show <$> runEitherT (getDeleteString host)) `shouldReturn` Right "ok"
196−
197− it "Servant.API.Capture" $ withServer $ \ host -> do
198− (Arrow.left show <$> runEitherT (getCapture "Paula" host)) `shouldReturn` Right (Person "Paula" 0)
199−
200− it "Servant.API.ReqBody" $ withServer $ \ host -> do
201− let p = Person "Clara" 42
202− (Arrow.left show <$> runEitherT (getBody p host)) `shouldReturn` Right p
203−
204− it "Servant.API.QueryParam" $ withServer $ \ host -> do
205− Arrow.left show <$> runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice
206− Left FailureResponse{..} <- runEitherT (getQueryParam (Just "bob") host)
207− responseStatus `shouldBe` Status 400 "bob not found"
208−
209− it "Servant.API.QueryParam.QueryParams" $ withServer $ \ host -> do
210− (Arrow.left show <$> runEitherT (getQueryParams [] host)) `shouldReturn` Right []
211− (Arrow.left show <$> runEitherT (getQueryParams ["alice", "bob"] host))
212− `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
213−
214− context "Servant.API.QueryParam.QueryFlag" $
215− forM_ [False, True] $ \ flag ->
216− it (show flag) $ withServer $ \ host -> do
217− (Arrow.left show <$> runEitherT (getQueryFlag flag host)) `shouldReturn` Right flag
218−
219− it "Servant.API.MatrixParam" $ withServer $ \ host -> do
220− Arrow.left show <$> runEitherT (getMatrixParam (Just "alice") host) `shouldReturn` Right alice
221− Left FailureResponse{..} <- runEitherT (getMatrixParam (Just "bob") host)
222− responseStatus `shouldBe` Status 400 "bob not found"
223−
224− it "Servant.API.MatrixParam.MatrixParams" $ withServer $ \ host -> do
225− Arrow.left show <$> runEitherT (getMatrixParams [] host) `shouldReturn` Right []
226− Arrow.left show <$> runEitherT (getMatrixParams ["alice", "bob"] host)
227− `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
228−
229− context "Servant.API.MatrixParam.MatrixFlag" $
230− forM_ [False, True] $ \ flag ->
231− it (show flag) $ withServer $ \ host -> do
232− Arrow.left show <$> runEitherT (getMatrixFlag flag host) `shouldReturn` Right flag
233−
234− it "Servant.API.Raw on success" $ withServer $ \ host -> do
235− res <- runEitherT (getRawSuccess methodGet host)
236− case res of
237− Left e -> assertFailure $ show e
238− Right (code, body, ct, _, response) -> do
239− (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")
240− C.responseBody response `shouldBe` body
241− C.responseStatus response `shouldBe` ok200
242−
243− it "Servant.API.Raw on failure" $ withServer $ \ host -> do
244− res <- runEitherT (getRawFailure methodGet host)
245− case res of
246− Left e -> assertFailure $ show e
247− Right (code, body, ct, _, response) -> do
248− (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream")
249− C.responseBody response `shouldBe` body
250− C.responseStatus response `shouldBe` badRequest400
251−
252− it "Returns headers appropriately" $ withServer $ \ host -> do
253− res <- runEitherT (getRespHeaders host)
254− case res of
255− Left e -> assertFailure $ show e
256− Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
257−
258− modifyMaxSuccess (const 20) $ do
259− it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
260− property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
261− ioProperty $ do
262− withServer $ \ host -> do
263− result <- Arrow.left show <$> runEitherT (getMultiple cap num flag body host)
264− return $
265− result === Right (cap, num, flag, body)
266−
267−
268− context "client correctly handles error status codes" $ do
269− let test :: (WrappedApi, String) -> Spec
270− test (WrappedApi api, desc) =
271− it desc $
272− withWaiDaemon (return (serve api (left $ ServantErr 500 "error message" "" []))) $
273− \ host -> do
274− let getResponse :: BaseUrl -> EitherT ServantError IO ()
275− getResponse = client api
276− Left FailureResponse{..} <- runEitherT (getResponse host)
277− responseStatus `shouldBe` (Status 500 "error message")
278− mapM_ test $
279− (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
280− (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
281− (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
282− (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
283− []
284−
285− context "client returns errors appropriately" $ do
286− it "reports FailureResponse" $ withFailServer $ \ host -> do
287− Left res <- runEitherT (getDelete host)
148+spec :: IO ()
149+spec = withServer $ \ baseUrl -> do
150+ let getGet :: EitherT ServantError IO Person
151+ getDelete :: EitherT ServantError IO ()
152+ getCapture :: String -> EitherT ServantError IO Person
153+ getBody :: Person -> EitherT ServantError IO Person
154+ getQueryParam :: Maybe String -> EitherT ServantError IO Person
155+ getQueryParams :: [String] -> EitherT ServantError IO [Person]
156+ getQueryFlag :: Bool -> EitherT ServantError IO Bool
157+ getMatrixParam :: Maybe String -> EitherT ServantError IO Person
158+ getMatrixParams :: [String] -> EitherT ServantError IO [Person]
159+ getMatrixFlag :: Bool -> EitherT ServantError IO Bool
160+ getRawSuccess :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString)
161+ getRawFailure :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString)
162+ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
163+ getRespHeaders :: EitherT ServantError IO (Headers TestHeaders Bool)
164+ ( getGet
165+ :<|> getDelete
166+ :<|> getCapture
167+ :<|> getBody
168+ :<|> getQueryParam
169+ :<|> getQueryParams
170+ :<|> getQueryFlag
171+ :<|> getMatrixParam
172+ :<|> getMatrixParams
173+ :<|> getMatrixFlag
174+ :<|> getRawSuccess
175+ :<|> getRawFailure
176+ :<|> getMultiple
177+ :<|> getRespHeaders)
178+ = client api baseUrl
179+
180+ hspec $ do
181+ it "Servant.API.Get" $ do
182+ (Arrow.left show <$> runEitherT getGet) `shouldReturn` Right alice
183+
184+ it "Servant.API.Delete" $ do
185+ (Arrow.left show <$> runEitherT getDelete) `shouldReturn` Right ()
186+
187+ it "Servant.API.Capture" $ do
188+ (Arrow.left show <$> runEitherT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)
189+
190+ it "Servant.API.ReqBody" $ do
191+ let p = Person "Clara" 42
192+ (Arrow.left show <$> runEitherT (getBody p)) `shouldReturn` Right p
193+
194+ it "Servant.API.QueryParam" $ do
195+ Arrow.left show <$> runEitherT (getQueryParam (Just "alice")) `shouldReturn` Right alice
196+ Left FailureResponse{..} <- runEitherT (getQueryParam (Just "bob"))
197+ responseStatus `shouldBe` Status 400 "bob not found"
198+
199+ it "Servant.API.QueryParam.QueryParams" $ do
200+ (Arrow.left show <$> runEitherT (getQueryParams [])) `shouldReturn` Right []
201+ (Arrow.left show <$> runEitherT (getQueryParams ["alice", "bob"]))
202+ `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
203+
204+ context "Servant.API.QueryParam.QueryFlag" $
205+ forM_ [False, True] $ \ flag ->
206+ it (show flag) $ do
207+ (Arrow.left show <$> runEitherT (getQueryFlag flag)) `shouldReturn` Right flag
208+
209+ it "Servant.API.MatrixParam" $ do
210+ Arrow.left show <$> runEitherT (getMatrixParam (Just "alice")) `shouldReturn` Right alice
211+ Left FailureResponse{..} <- runEitherT (getMatrixParam (Just "bob"))
212+ responseStatus `shouldBe` Status 400 "bob not found"
213+
214+ it "Servant.API.MatrixParam.MatrixParams" $ do
215+ Arrow.left show <$> runEitherT (getMatrixParams []) `shouldReturn` Right []
216+ Arrow.left show <$> runEitherT (getMatrixParams ["alice", "bob"])
217+ `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
218+
219+ context "Servant.API.MatrixParam.MatrixFlag" $
220+ forM_ [False, True] $ \ flag ->
221+ it (show flag) $ do
222+ Arrow.left show <$> runEitherT (getMatrixFlag flag) `shouldReturn` Right flag
223+
224+ it "Servant.API.Raw on success" $ do
225+ res <- runEitherT (getRawSuccess methodGet)
288226 case res of
289− FailureResponse (Status 404 "Not Found") _ _ -> return ()
290− _ -> fail $ "expected 404 response, but got " <> show res
291−
292− it "reports DecodeFailure" $ withFailServer $ \ host -> do
293− Left res <- runEitherT (getCapture "foo" host)
227+ Left e -> assertFailure $ show e
228+ Right (code, body, ct, _, response) -> do
229+ (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")
230+ C.responseBody response `shouldBe` body
231+ C.responseStatus response `shouldBe` ok200
232+
233+ it "Servant.API.Raw on failure" $ do
234+ res <- runEitherT (getRawFailure methodGet)
294235 case res of
295− DecodeFailure _ ("application/json") _ -> return ()
296− _ -> fail $ "expected DecodeFailure, but got " <> show res
297−
298− it "reports ConnectionError" $ do
299− Right host <- return $ parseBaseUrl "127.0.0.1:987654"
300− Left res <- runEitherT (getGet host)
236+ Left e -> assertFailure $ show e
237+ Right (code, body, ct, _, response) -> do
238+ (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream")
239+ C.responseBody response `shouldBe` body
240+ C.responseStatus response `shouldBe` badRequest400
241+
242+ it "Returns headers appropriately" $ withServer $ \ _ -> do
243+ res <- runEitherT getRespHeaders
301244 case res of
302− ConnectionError (C.FailedConnectionException2 "127.0.0.1" 987654 False _) -> return ()
303− _ -> fail $ "expected ConnectionError, but got " <> show res
245+ Left e -> assertFailure $ show e
246+ Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
247+
248+ modifyMaxSuccess (const 20) $ do
249+ it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
250+ property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
251+ ioProperty $ do
252+ result <- Arrow.left show <$> runEitherT (getMultiple cap num flag body)
253+ return $
254+ result === Right (cap, num, flag, body)
304255
305− it "reports UnsupportedContentType" $ withFailServer $ \ host -> do
306− Left res <- runEitherT (getGet host)
307− case res of
308− UnsupportedContentType ("application/octet-stream") _ -> return ()
309− _ -> fail $ "expected UnsupportedContentType, but got " <> show res
310256
311− it "reports InvalidContentTypeHeader" $ withFailServer $ \ host -> do
312− Left res <- runEitherT (getBody alice host)
313− case res of
314− InvalidContentTypeHeader "fooooo" _ -> return ()
315− _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
257+ context "client correctly handles error status codes" $ do
258+ let test :: (WrappedApi, String) -> Spec
259+ test (WrappedApi api, desc) =
260+ it desc $
261+ withWaiDaemon (return (serve api (left $ ServantErr 500 "error message" "" []))) $
262+ \ host -> do
263+ let getResponse :: EitherT ServantError IO ()
264+ getResponse = client api host
265+ Left FailureResponse{..} <- runEitherT getResponse
266+ responseStatus `shouldBe` (Status 500 "error message")
267+ mapM_ test $
268+ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
269+ (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
270+ (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
271+ (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
272+ []
273+
274+failSpec :: IO ()
275+failSpec = withFailServer $ \ baseUrl -> do
276+ let getGet :: EitherT ServantError IO Person
277+ getDelete :: EitherT ServantError IO ()
278+ getCapture :: String -> EitherT ServantError IO Person
279+ getBody :: Person -> EitherT ServantError IO Person
280+ ( getGet
281+ :<|> getDelete
282+ :<|> getCapture
283+ :<|> getBody
284+ :<|> _ )
285+ = client api baseUrl
286+ getGetWrongHost :: EitherT ServantError IO Person
287+ (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872)
288+
289+ hspec $ do
290+ context "client returns errors appropriately" $ do
291+ it "reports FailureResponse" $ do
292+ Left res <- runEitherT getDelete
293+ case res of
294+ FailureResponse (Status 404 "Not Found") _ _ -> return ()
295+ _ -> fail $ "expected 404 response, but got " <> show res
296+
297+ it "reports DecodeFailure" $ do
298+ Left res <- runEitherT (getCapture "foo")
299+ case res of
300+ DecodeFailure _ ("application/json") _ -> return ()
301+ _ -> fail $ "expected DecodeFailure, but got " <> show res
302+
303+ it "reports ConnectionError" $ do
304+ Left res <- runEitherT getGetWrongHost
305+ case res of
306+ ConnectionError (C.FailedConnectionException2 "127.0.0.1" 19872 False _) -> return ()
307+ _ -> fail $ "expected ConnectionError, but got " <> show res
308+
309+ it "reports UnsupportedContentType" $ do
310+ Left res <- runEitherT getGet
311+ case res of
312+ UnsupportedContentType ("application/octet-stream") _ -> return ()
313+ _ -> fail $ "expected UnsupportedContentType, but got " <> show res
314+
315+ it "reports InvalidContentTypeHeader" $ do
316+ Left res <- runEitherT (getBody alice)
317+ case res of
318+ InvalidContentTypeHeader "fooooo" _ -> return ()
319+ _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
316320
317321data WrappedApi where
318322 WrappedApi :: (HasServer api, Server api ~ EitherT ServantErr IO a,
319− HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
323+ HasClient api, Client api ~ EitherT ServantError IO ()) =>
320324 Proxy api -> WrappedApi
321325
322326
servant-client/test/Spec.hs+7−1
@@ -1 +1,7 @@
1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
1+import Servant.ClientSpec (spec, failSpec)
2+
3+main :: IO ()
4+main = do
5+ spec
6+ failSpec
7+
servant-examples/hackage/hackage.hs+8−11
@@ -54,29 +54,26 @@ instance FromJSON Package
5454hackageAPI :: Proxy HackageAPI
5555hackageAPI = Proxy
5656
57−getUsers :: BaseUrl -> EitherT ServantError IO [UserSummary]
58−getUser :: Username -> BaseUrl -> EitherT ServantError IO UserDetailed
59−getPackages :: BaseUrl -> EitherT ServantError IO [Package]
60−getUsers :<|> getUser :<|> getPackages = client hackageAPI
61−
62−run :: (BaseUrl -> r) -> r
63−run f = f (BaseUrl Http "hackage.haskell.org" 80)
57+getUsers :: EitherT ServantError IO [UserSummary]
58+getUser :: Username -> EitherT ServantError IO UserDetailed
59+getPackages :: EitherT ServantError IO [Package]
60+getUsers :<|> getUser :<|> getPackages = client hackageAPI $ BaseUrl Http "hackage.haskell.org" 80
6461
6562main :: IO ()
6663main = print =<< uselessNumbers
6764
6865uselessNumbers :: IO (Either ServantError ())
6966uselessNumbers = runEitherT $ do
70− users <- run getUsers
67+ users <- getUsers
7168 liftIO . putStrLn $ show (length users) ++ " users"
7269
7370 user <- liftIO $ do
7471 putStrLn "Enter a valid hackage username"
7572 T.getLine
76− userDetailed <- run (getUser user)
73+ userDetailed <- (getUser user)
7774 liftIO . T.putStrLn $ user <> " maintains " <> T.pack (show (length $ groups userDetailed)) <> " packages"
78−
79− packages <- run getPackages
75+
76+ packages <- getPackages
8077 let monadPackages = filter (isMonadPackage . packageName) packages
8178 liftIO . putStrLn $ show (length monadPackages) ++ " monad packages"
8279