@@ -1,514 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE FunctionalDependencies #-}
8−{-# LANGUAGE GADTs #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE OverloadedStrings #-}
11−{-# LANGUAGE PolyKinds #-}
12−{-# LANGUAGE RecordWildCards #-}
13−{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE StandaloneDeriving #-}
15−{-# LANGUAGE TypeApplications #-}
16−{-# LANGUAGE TypeFamilies #-}
17−{-# LANGUAGE TypeOperators #-}
18−{-# LANGUAGE UndecidableInstances #-}
19−{-# OPTIONS_GHC -freduction-depth=100 #-}
20−{-# OPTIONS_GHC -fno-warn-orphans #-}
21−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
22−
23−module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where
24−
25−import Prelude ()
26−import Prelude.Compat
27−
28−import Control.Arrow
29− (left)
30−import Control.Concurrent
31− (ThreadId, forkIO, killThread)
32−import Control.Concurrent.STM
33− (atomically)
34−import Control.Concurrent.STM.TVar
35− (newTVar, readTVar)
36−import Control.Exception
37− (bracket, fromException)
38−import Control.Monad.Error.Class
39− (throwError)
40−import Data.Aeson
41−import Data.Char
42− (chr, isPrint)
43−import Data.Foldable
44− (forM_, toList)
45−import Data.Maybe
46− (isJust, listToMaybe)
47−import Data.Monoid ()
48−import Data.Proxy
49−import Data.Semigroup
50− ((<>))
51−import GHC.Generics
52− (Generic)
53−import qualified Network.HTTP.Client as C
54−import qualified Network.HTTP.Types as HTTP
55−import Network.Socket
56−import qualified Network.Wai as Wai
57−import Network.Wai.Handler.Warp
58−import System.IO.Unsafe
59− (unsafePerformIO)
60−import Test.Hspec
61−import Test.Hspec.QuickCheck
62−import Test.HUnit
63−import Test.QuickCheck
64−import Web.FormUrlEncoded
65− (FromForm, ToForm)
66−
67−import Servant.API
68− ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
69− BasicAuthData (..), Capture, CaptureAll, Delete,
70− DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
71− Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
72− QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
73−import Servant.Client
74−import qualified Servant.Client.Core.Auth as Auth
75−import qualified Servant.Client.Core.Request as Req
76−import Servant.Server
77−import Servant.Server.Experimental.Auth
78−import Servant.Test.ComprehensiveAPI
79−
80−-- This declaration simply checks that all instances are in place.
81−_ = client comprehensiveAPIWithoutStreaming
82−
83−spec :: Spec
84−spec = describe "Servant.Client" $ do
85− sucessSpec
86− failSpec
87− wrappedApiSpec
88− basicAuthSpec
89− genAuthSpec
90− hoistClientSpec
91− connectionErrorSpec
92−
93−-- * test data types
94−
95−data Person = Person
96− { _name :: String
97− , _age :: Integer
98− } deriving (Eq, Show, Generic)
99−
100−instance ToJSON Person
101−instance FromJSON Person
102−
103−instance ToForm Person
104−instance FromForm Person
105−
106−instance Arbitrary Person where
107− arbitrary = Person <$> arbitrary <*> arbitrary
108−
109−alice :: Person
110−alice = Person "Alice" 42
111−
112−carol :: Person
113−carol = Person "Carol" 17
114−
115−type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
116−
117−type Api =
118− Get '[JSON] Person
119− :<|> "get" :> Get '[JSON] Person
120− :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
121− :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
122− :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
123− :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
124− :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
125− :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
126− :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
127− :<|> "rawSuccess" :> Raw
128− :<|> "rawFailure" :> Raw
129− :<|> "multiple" :>
130− Capture "first" String :>
131− QueryParam "second" Int :>
132− QueryFlag "third" :>
133− ReqBody '[JSON] [(String, [Rational])] :>
134− Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
135− :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
136− :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
137− :<|> "redirectWithCookie" :> Raw
138− :<|> "empty" :> EmptyAPI
139−
140−api :: Proxy Api
141−api = Proxy
142−
143−getRoot :: ClientM Person
144−getGet :: ClientM Person
145−getDeleteEmpty :: ClientM NoContent
146−getCapture :: String -> ClientM Person
147−getCaptureAll :: [String] -> ClientM [Person]
148−getBody :: Person -> ClientM Person
149−getQueryParam :: Maybe String -> ClientM Person
150−getQueryParams :: [String] -> ClientM [Person]
151−getQueryFlag :: Bool -> ClientM Bool
152−getRawSuccess :: HTTP.Method -> ClientM Response
153−getRawFailure :: HTTP.Method -> ClientM Response
154−getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
155− -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
156−getRespHeaders :: ClientM (Headers TestHeaders Bool)
157−getDeleteContentType :: ClientM NoContent
158−getRedirectWithCookie :: HTTP.Method -> ClientM Response
159−
160−getRoot
161− :<|> getGet
162− :<|> getDeleteEmpty
163− :<|> getCapture
164− :<|> getCaptureAll
165− :<|> getBody
166− :<|> getQueryParam
167− :<|> getQueryParams
168− :<|> getQueryFlag
169− :<|> getRawSuccess
170− :<|> getRawFailure
171− :<|> getMultiple
172− :<|> getRespHeaders
173− :<|> getDeleteContentType
174− :<|> getRedirectWithCookie
175− :<|> EmptyClient = client api
176−
177−server :: Application
178−server = serve api (
179− return carol
180− :<|> return alice
181− :<|> return NoContent
182− :<|> (\ name -> return $ Person name 0)
183− :<|> (\ names -> return (zipWith Person names [0..]))
184− :<|> return
185− :<|> (\ name -> case name of
186− Just "alice" -> return alice
187− Just n -> throwError $ ServerError 400 (n ++ " not found") "" []
188− Nothing -> throwError $ ServerError 400 "missing parameter" "" [])
189− :<|> (\ names -> return (zipWith Person names [0..]))
190− :<|> return
191− :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
192− :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
193− :<|> (\ a b c d -> return (a, b, c, d))
194− :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
195− :<|> return NoContent
196− :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
197− :<|> emptyServer)
198−
199−type FailApi =
200− "get" :> Raw
201− :<|> "capture" :> Capture "name" String :> Raw
202− :<|> "body" :> Raw
203−failApi :: Proxy FailApi
204−failApi = Proxy
205−
206−failServer :: Application
207−failServer = serve failApi (
208− (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "")
209− :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
210− :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
211− )
212−
213−-- * basic auth stuff
214−
215−type BasicAuthAPI =
216− BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person
217−
218−basicAuthAPI :: Proxy BasicAuthAPI
219−basicAuthAPI = Proxy
220−
221−basicAuthHandler :: BasicAuthCheck ()
222−basicAuthHandler =
223− let check (BasicAuthData username password) =
224− if username == "servant" && password == "server"
225− then return (Authorized ())
226− else return Unauthorized
227− in BasicAuthCheck check
228−
229−basicServerContext :: Context '[ BasicAuthCheck () ]
230−basicServerContext = basicAuthHandler :. EmptyContext
231−
232−basicAuthServer :: Application
233−basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
234−
235−-- * general auth stuff
236−
237−type GenAuthAPI =
238− AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person
239−
240−genAuthAPI :: Proxy GenAuthAPI
241−genAuthAPI = Proxy
242−
243−type instance AuthServerData (AuthProtect "auth-tag") = ()
244−type instance Auth.AuthClientData (AuthProtect "auth-tag") = ()
245−
246−genAuthHandler :: AuthHandler Wai.Request ()
247−genAuthHandler =
248− let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
249− Nothing -> throwError (err401 { errBody = "Missing auth header" })
250− Just _ -> return ()
251− in mkAuthHandler handler
252−
253−genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
254−genAuthServerContext = genAuthHandler :. EmptyContext
255−
256−genAuthServer :: Application
257−genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
258−
259−{-# NOINLINE manager' #-}
260−manager' :: C.Manager
261−manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
262−
263−runClient :: ClientM a -> BaseUrl -> IO (Either ClientError a)
264−runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
265−
266−sucessSpec :: Spec
267−sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
268− it "Servant.API.Get root" $ \(_, baseUrl) -> do
269− left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
270−
271− it "Servant.API.Get" $ \(_, baseUrl) -> do
272− left show <$> runClient getGet baseUrl `shouldReturn` Right alice
273−
274− describe "Servant.API.Delete" $ do
275− it "allows empty content type" $ \(_, baseUrl) -> do
276− left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent
277−
278− it "allows content type" $ \(_, baseUrl) -> do
279− left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent
280−
281− it "Servant.API.Capture" $ \(_, baseUrl) -> do
282− left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0)
283−
284− it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
285− let expected = [(Person "Paula" 0), (Person "Peta" 1)]
286− left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected
287−
288− it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
289− let p = Person "Clara" 42
290− left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p
291−
292− it "Servant.API FailureResponse" $ \(_, baseUrl) -> do
293− left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
294− Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl
295− Req.requestPath req `shouldBe` (baseUrl, "/param")
296− toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")]
297− Req.requestMethod req `shouldBe` HTTP.methodGet
298−
299− it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
300− left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
301− Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
302− responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
303−
304− it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
305− left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
306− left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
307− `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
308−
309− context "Servant.API.QueryParam.QueryFlag" $
310− forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
311− left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
312−
313− it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
314− res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
315− case res of
316− Left e -> assertFailure $ show e
317− Right r -> do
318− responseStatusCode r `shouldBe` HTTP.status200
319− responseBody r `shouldBe` "rawSuccess"
320−
321− it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
322− res <- runClient (getRawFailure HTTP.methodGet) baseUrl
323− case res of
324− Right _ -> assertFailure "expected Left, but got Right"
325− Left (FailureResponse _ r) -> do
326− responseStatusCode r `shouldBe` HTTP.status400
327− responseBody r `shouldBe` "rawFailure"
328− Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
329−
330− it "Returns headers appropriately" $ \(_, baseUrl) -> do
331− res <- runClient getRespHeaders baseUrl
332− case res of
333− Left e -> assertFailure $ show e
334− Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
335−
336− it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
337− mgr <- C.newManager C.defaultManagerSettings
338− cj <- atomically . newTVar $ C.createCookieJar []
339− _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj))
340− cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj)
341− C.cookie_name <$> cookie `shouldBe` Just "testcookie"
342− C.cookie_value <$> cookie `shouldBe` Just "test"
343−
344− modifyMaxSuccess (const 20) $ do
345− it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
346− property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
347− ioProperty $ do
348− result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
349− return $
350− result === Right (cap, num, flag, body)
351−
352−
353−wrappedApiSpec :: Spec
354−wrappedApiSpec = describe "error status codes" $ do
355− let serveW api = serve api $ throwError $ ServerError 500 "error message" "" []
356− context "are correctly handled by the client" $
357− let test :: (WrappedApi, String) -> Spec
358− test (WrappedApi api, desc) =
359− it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
360− let getResponse :: ClientM ()
361− getResponse = client api
362− Left (FailureResponse _ r) <- runClient getResponse baseUrl
363− responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")
364− in mapM_ test $
365− (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
366− (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
367− (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
368− (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
369− []
370−
371−failSpec :: Spec
372−failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
373−
374− context "client returns errors appropriately" $ do
375− it "reports FailureResponse" $ \(_, baseUrl) -> do
376− let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
377− Left res <- runClient getDeleteEmpty baseUrl
378− case res of
379− FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
380− _ -> fail $ "expected 404 response, but got " <> show res
381−
382− it "reports DecodeFailure" $ \(_, baseUrl) -> do
383− let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
384− Left res <- runClient (getCapture "foo") baseUrl
385− case res of
386− DecodeFailure _ _ -> return ()
387− _ -> fail $ "expected DecodeFailure, but got " <> show res
388−
389− it "reports ConnectionError" $ \_ -> do
390− let (getGetWrongHost :<|> _) = client api
391− Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")
392− case res of
393− ConnectionError _ -> return ()
394− _ -> fail $ "expected ConnectionError, but got " <> show res
395−
396− it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
397− let (_ :<|> getGet :<|> _ ) = client api
398− Left res <- runClient getGet baseUrl
399− case res of
400− UnsupportedContentType ("application/octet-stream") _ -> return ()
401− _ -> fail $ "expected UnsupportedContentType, but got " <> show res
402−
403− it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
404− let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
405− Left res <- runClient (getBody alice) baseUrl
406− case res of
407− InvalidContentTypeHeader _ -> return ()
408− _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
409−
410−data WrappedApi where
411− WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
412− HasClient ClientM api, Client ClientM api ~ ClientM ()) =>
413− Proxy api -> WrappedApi
414−
415−basicAuthSpec :: Spec
416−basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
417− context "Authentication works when requests are properly authenticated" $ do
418−
419− it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
420− let getBasic = client basicAuthAPI
421− let basicAuthData = BasicAuthData "servant" "server"
422− left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice
423−
424− context "Authentication is rejected when requests are not authenticated properly" $ do
425−
426− it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
427− let getBasic = client basicAuthAPI
428− let basicAuthData = BasicAuthData "not" "password"
429− Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl
430− responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
431−
432−genAuthSpec :: Spec
433−genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
434− context "Authentication works when requests are properly authenticated" $ do
435−
436− it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
437− let getProtected = client genAuthAPI
438− let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req)
439− left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice
440−
441− context "Authentication is rejected when requests are not authenticated properly" $ do
442−
443− it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
444− let getProtected = client genAuthAPI
445− let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)
446− Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
447− responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
448−
449−-- * hoistClient
450−
451−type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
452−
453−hoistClientAPI :: Proxy HoistClientAPI
454−hoistClientAPI = Proxy
455−
456−hoistClientServer :: Application -- implements HoistClientAPI
457−hoistClientServer = serve hoistClientAPI $ return 5 :<|> (\n -> return n)
458−
459−hoistClientSpec :: Spec
460−hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do
461− describe "Servant.Client.hoistClient" $ do
462− it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do
463− let (getInt :<|> postInt)
464− = hoistClient hoistClientAPI
465− (fmap (either (error . show) id) . flip runClient baseUrl)
466− (client hoistClientAPI)
467−
468− getInt `shouldReturn` 5
469− postInt 5 `shouldReturn` 5
470−
471−-- * ConnectionError
472−type ConnectionErrorAPI = Get '[JSON] Int
473−
474−connectionErrorAPI :: Proxy ConnectionErrorAPI
475−connectionErrorAPI = Proxy
476−
477−connectionErrorSpec :: Spec
478−connectionErrorSpec = describe "Servant.Client.ClientError" $
479− it "correctly catches ConnectionErrors when the HTTP request can't go through" $ do
480− let getInt = client connectionErrorAPI
481− let baseUrl' = BaseUrl Http "example.invalid" 80 ""
482− let isHttpError (Left (ConnectionError e)) = isJust $ fromException @C.HttpException e
483− isHttpError _ = False
484− (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True
485−
486−-- * utils
487−
488−startWaiApp :: Application -> IO (ThreadId, BaseUrl)
489−startWaiApp app = do
490− (port, socket) <- openTestSocket
491− let settings = setPort port $ defaultSettings
492− thread <- forkIO $ runSettingsSocket settings socket app
493− return (thread, BaseUrl Http "localhost" port "")
494−
495−
496−endWaiApp :: (ThreadId, BaseUrl) -> IO ()
497−endWaiApp (thread, _) = killThread thread
498−
499−openTestSocket :: IO (Port, Socket)
500−openTestSocket = do
501− s <- socket AF_INET Stream defaultProtocol
502− let localhost = tupleToHostAddress (127, 0, 0, 1)
503− bind s (SockAddrInet defaultPort localhost)
504− listen s 1
505− port <- socketPort s
506− return (fromIntegral port, s)
507−
508−pathGen :: Gen (NonEmptyList Char)
509−pathGen = fmap NonEmpty path
510− where
511− path = listOf1 $ elements $
512− filter (not . (`elem` ("?%[]/#;" :: String))) $
513− filter isPrint $
514− map chr [0..127]