@@ -1,5 +1,4 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
32{-# LANGUAGE DataKinds #-}
43{-# LANGUAGE DeriveGeneric #-}
54{-# LANGUAGE FlexibleContexts #-}
@@ -11,7 +10,6 @@
1110{-# LANGUAGE PolyKinds #-}
1211{-# LANGUAGE RecordWildCards #-}
1312{-# LANGUAGE StandaloneDeriving #-}
14−{-# LANGUAGE ScopedTypeVariables #-}
1513{-# LANGUAGE TypeFamilies #-}
1614{-# LANGUAGE TypeOperators #-}
1715{-# LANGUAGE UndecidableInstances #-}
@@ -21,17 +19,13 @@
2119{-# OPTIONS_GHC -fcontext-stack=100 #-}
2220#endif
2321{-# OPTIONS_GHC -fno-warn-orphans #-}
24−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2522
26−#include "overlapping-compat.h"
2723module Servant.ClientSpec where
2824
29−#if !MIN_VERSION_base(4,8,0)
30−import Control.Applicative ((<$>))
31−#endif
25+import Prelude ()
26+import Prelude.Compat
27+
3228import Control.Arrow (left)
33−import Control.Concurrent (forkIO, killThread, ThreadId)
34−import Control.Exception (bracket)
3529import Control.Monad.Trans.Except (throwE )
3630import Data.Aeson
3731import qualified Data.ByteString.Lazy as BS
@@ -42,34 +36,76 @@ import Data.Proxy
4236import GHC.Generics (Generic)
4337import qualified Network.HTTP.Client as C
4438import Network.HTTP.Media
45−import qualified Network.HTTP.Types as HTTP
46−import Network.Socket
47−import Network.Wai (Request, requestHeaders, responseLBS)
48−import Network.Wai.Handler.Warp
39+import qualified Network.HTTP.Types as HTTP
40+import Network.Wai (responseLBS)
41+import qualified Network.Wai as Wai
42+import System.Exit.Compat
4943import System.IO.Unsafe (unsafePerformIO)
44+import Test.HUnit
5045import Test.Hspec
5146import Test.Hspec.QuickCheck
52−import Test.HUnit
5347import Test.QuickCheck
5448import Web.FormUrlEncoded (FromForm, ToForm)
5549
5650import Servant.API
57−import Servant.API.Internal.Test.ComprehensiveAPI
5851import Servant.Client
52+import Servant.Client.TestServer
53+import Servant.Client.TestServer.GHC
54+import qualified Servant.Common.Req as SCR
5955import Servant.Server
6056import Servant.Server.Experimental.Auth
61−import qualified Servant.Common.Req as SCR
62−
63−-- This declaration simply checks that all instances are in place.
64−_ = client comprehensiveAPI
6557
6658spec :: Spec
67−spec = describe "Servant.Client" $ do
59+spec = do
60+ runIO buildTestServer
61+ describe "Servant.Client" $ do
6862 sucessSpec
6963 failSpec
70− wrappedApiSpec
7164 basicAuthSpec
7265 genAuthSpec
66+ errorSpec
67+
68+-- | Run a test-server (identified by name) while performing the given action.
69+-- The provided 'BaseUrl' points to the running server.
70+--
71+-- Running the test-servers is done differently depending on the compiler
72+-- (ghc or ghcjs).
73+--
74+-- With ghc it's somewhat straight-forward: a wai 'Application' is being started
75+-- on a free port inside the same process using 'warp'.
76+--
77+-- When running the test-suite with ghcjs all the test-servers are compiled into
78+-- a single external executable (with ghc and warp). This is done through
79+-- 'buildTestServer' once at the start of the test-suite. This built executable
80+-- will provide all the test-servers on a free port under a path that
81+-- corresponds to the test-servers name, for example under
82+-- 'http://localhost:82923/failServer'. 'withTestServer' will then
83+-- start this executable as an external process while the given action is being
84+-- executed and provide it with the correct BaseUrl.
85+-- This rather cumbersome approach is taken because it's not easy to run a wai
86+-- Application as a http server when using ghcjs.
87+withTestServer :: String -> (BaseUrl -> IO a) -> IO a
88+withTestServer name action = do
89+ server <- lookupTestServer name
90+ withServer server action
91+
92+lookupTestServer :: String -> IO TestServer
93+lookupTestServer name = case lookup name mapping of
94+ Nothing -> die ("test server not found: " ++ name)
95+ Just testServer -> return testServer
96+ where
97+ mapping :: [(String, TestServer)]
98+ mapping = map (\ server -> (testServerName server, server)) allTestServers
99+
100+-- | All test-servers must be registered here.
101+allTestServers :: [TestServer]
102+allTestServers =
103+ server :
104+ errorServer :
105+ failServer :
106+ basicAuthServer :
107+ genAuthServer :
108+ []
73109
74110-- * test data types
75111
@@ -120,9 +156,9 @@ getBody :: Person -> SCR.ClientM Person
120156getQueryParam :: Maybe String -> SCR.ClientM Person
121157getQueryParams :: [String] -> SCR.ClientM [Person]
122158getQueryFlag :: Bool -> SCR.ClientM Bool
123−getRawSuccess :: HTTP.Method
159+getRawSuccess :: HTTP.Method
124160 -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
125−getRawFailure :: HTTP.Method
161+getRawFailure :: HTTP.Method
126162 -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
127163getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
128164 -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])])
@@ -142,8 +178,8 @@ getGet
142178 :<|> getRespHeaders
143179 :<|> getDeleteContentType = client api
144180
145−server :: Application
146−server = serve api (
181+server :: TestServer
182+server = TestServer "server" $ serve api (
147183 return alice
148184 :<|> return NoContent
149185 :<|> (\ name -> return $ Person name 0)
@@ -162,19 +198,19 @@ server = serve api (
162198 :<|> return NoContent
163199 )
164200
165−
166201type FailApi =
167202 "get" :> Raw
168203 :<|> "capture" :> Capture "name" String :> Raw
169204 :<|> "body" :> Raw
205+
170206failApi :: Proxy FailApi
171207failApi = Proxy
172208
173−failServer :: Application
174−failServer = serve failApi (
209+failServer :: TestServer
210+failServer = TestServer "failServer" $ serve failApi (
175211 (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
176212 :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
177− :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
213+ :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
178214 )
179215
180216-- * basic auth stuff
@@ -196,8 +232,9 @@ basicAuthHandler =
196232basicServerContext :: Context '[ BasicAuthCheck () ]
197233basicServerContext = basicAuthHandler :. EmptyContext
198234
199−basicAuthServer :: Application
200−basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
235+basicAuthServer :: TestServer
236+basicAuthServer = TestServer "basicAuthServer" $
237+ serveWithContext basicAuthAPI basicServerContext (const (return alice))
201238
202239-- * general auth stuff
203240
@@ -210,62 +247,63 @@ genAuthAPI = Proxy
210247type instance AuthServerData (AuthProtect "auth-tag") = ()
211248type instance AuthClientData (AuthProtect "auth-tag") = ()
212249
213−genAuthHandler :: AuthHandler Request ()
250+genAuthHandler :: AuthHandler Wai.Request ()
214251genAuthHandler =
215− let handler req = case lookup "AuthHeader" (requestHeaders req) of
252+ let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
216253 Nothing -> throwE (err401 { errBody = "Missing auth header" })
217254 Just _ -> return ()
218255 in mkAuthHandler handler
219256
220−genAuthServerContext :: Context '[ AuthHandler Request () ]
257+genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
221258genAuthServerContext = genAuthHandler :. EmptyContext
222259
223−genAuthServer :: Application
224−genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
260+genAuthServer :: TestServer
261+genAuthServer = TestServer "genAuthServer" $
262+ serveWithContext genAuthAPI genAuthServerContext (const (return alice))
225263
226264{-# NOINLINE manager #-}
227265manager :: C.Manager
228266manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
229267
230268sucessSpec :: Spec
231−sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
269+sucessSpec = around (withTestServer "server") $ do
232270
233− it "Servant.API.Get" $ \(_, baseUrl) -> do
271+ it "Servant.API.Get" $ \baseUrl -> do
234272 (left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice
235273
236274 describe "Servant.API.Delete" $ do
237− it "allows empty content type" $ \(_, baseUrl) -> do
275+ it "allows empty content type" $ \baseUrl -> do
238276 (left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
239277
240− it "allows content type" $ \(_, baseUrl) -> do
278+ it "allows content type" $ \baseUrl -> do
241279 (left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
242280
243− it "Servant.API.Capture" $ \(_, baseUrl) -> do
281+ it "Servant.API.Capture" $ \baseUrl -> do
244282 (left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0)
245283
246− it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
284+ it "Servant.API.CaptureAll" $ \baseUrl -> do
247285 let expected = [(Person "Paula" 0), (Person "Peta" 1)]
248286 (left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected
249287
250− it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
288+ it "Servant.API.ReqBody" $ \baseUrl -> do
251289 let p = Person "Clara" 42
252290 (left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p
253291
254− it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
292+ it "Servant.API.QueryParam" $ \baseUrl -> do
255293 left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice
256294 Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl)
257295 responseStatus `shouldBe` HTTP.Status 400 "bob not found"
258296
259− it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
297+ it "Servant.API.QueryParam.QueryParams" $ \baseUrl -> do
260298 (left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right []
261299 (left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl))
262300 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
263301
264302 context "Servant.API.QueryParam.QueryFlag" $
265− forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
303+ forM_ [False, True] $ \ flag -> it (show flag) $ \baseUrl -> do
266304 (left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag
267305
268− it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
306+ it "Servant.API.Raw on success" $ \baseUrl -> do
269307 res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl)
270308 case res of
271309 Left e -> assertFailure $ show e
@@ -274,7 +312,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
274312 C.responseBody response `shouldBe` body
275313 C.responseStatus response `shouldBe` HTTP.ok200
276314
277− it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
315+ it "Servant.API.Raw should return a Left in case of failure" $ \baseUrl -> do
278316 res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl)
279317 case res of
280318 Right _ -> assertFailure "expected Left, but got Right"
@@ -282,51 +320,93 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
282320 Servant.Client.responseStatus e `shouldBe` HTTP.status400
283321 Servant.Client.responseBody e `shouldBe` "rawFailure"
284322
285− it "Returns headers appropriately" $ \(_, baseUrl) -> do
323+ it "Returns headers appropriately" $ \baseUrl -> do
286324 res <- runClientM getRespHeaders (ClientEnv manager baseUrl)
287325 case res of
288326 Left e -> assertFailure $ show e
289327 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
290328
291329 modifyMaxSuccess (const 20) $ do
292− it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
330+ it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \baseUrl ->
293331 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
294332 ioProperty $ do
295333 result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl)
296334 return $
297335 result === Right (cap, num, flag, body)
298336
337+type ErrorApi =
338+ Delete '[JSON] () :<|>
339+ Get '[JSON] () :<|>
340+ Post '[JSON] () :<|>
341+ Put '[JSON] ()
342+
343+errorApi :: Proxy ErrorApi
344+errorApi = Proxy
345+
346+errorServer :: TestServer
347+errorServer = TestServer "errorServer" $ serve errorApi $
348+ err :<|> err :<|> err :<|> err
349+ where
350+ err = throwE $ ServantErr 500 "error message" "" []
351+
352+errorSpec :: Spec
353+errorSpec =
354+ around (withTestServer "errorServer") $ do
355+ describe "error status codes" $
356+ it "reports error statuses correctly" $ \baseUrl -> do
357+ let delete :<|> get :<|> post :<|> put =
358+ client errorApi
359+ actions = [delete, get, post, put]
360+ forM_ actions $ \ clientAction -> do
361+ Left FailureResponse{..} <- runClientM clientAction (ClientEnv manager baseUrl)
362+ responseStatus `shouldBe` HTTP.Status 500 "error message"
363+
364+basicAuthSpec :: Spec
365+basicAuthSpec = around (withTestServer "basicAuthServer") $ do
366+ context "Authentication works when requests are properly authenticated" $ do
367+
368+ it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
369+ let getBasic = client basicAuthAPI
370+ let basicAuthData = BasicAuthData "servant" "server"
371+ (left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
372+
373+ context "Authentication is rejected when requests are not authenticated properly" $ do
374+
375+ it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
376+ let getBasic = client basicAuthAPI
377+ let basicAuthData = BasicAuthData "not" "password"
378+ Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)
379+ responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
380+
381+genAuthSpec :: Spec
382+genAuthSpec = around (withTestServer "genAuthServer") $ do
383+ context "Authentication works when requests are properly authenticated" $ do
384+
385+ it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
386+ let getProtected = client genAuthAPI
387+ let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
388+ (left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
299389
300−wrappedApiSpec :: Spec
301−wrappedApiSpec = describe "error status codes" $ do
302− let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
303− context "are correctly handled by the client" $
304− let test :: (WrappedApi, String) -> Spec
305− test (WrappedApi api, desc) =
306− it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
307− let getResponse :: SCR.ClientM ()
308− getResponse = client api
309− Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl)
310− responseStatus `shouldBe` (HTTP.Status 500 "error message")
311− in mapM_ test $
312− (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
313− (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
314− (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
315− (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
316− []
390+ context "Authentication is rejected when requests are not authenticated properly" $ do
391+
392+ it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
393+ let getProtected = client genAuthAPI
394+ let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
395+ Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl)
396+ responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
317397
318398failSpec :: Spec
319−failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
399+failSpec = around (withTestServer "failServer") $ do
320400
321401 context "client returns errors appropriately" $ do
322− it "reports FailureResponse" $ \(_, baseUrl) -> do
402+ it "reports FailureResponse" $ \baseUrl -> do
323403 let (_ :<|> getDeleteEmpty :<|> _) = client api
324404 Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl)
325405 case res of
326406 FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
327407 _ -> fail $ "expected 404 response, but got " <> show res
328408
329− it "reports DecodeFailure" $ \(_, baseUrl) -> do
409+ it "reports DecodeFailure" $ \baseUrl -> do
330410 let (_ :<|> _ :<|> getCapture :<|> _) = client api
331411 Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl)
332412 case res of
@@ -340,81 +420,23 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
340420 ConnectionError _ -> return ()
341421 _ -> fail $ "expected ConnectionError, but got " <> show res
342422
343− it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
423+ it "reports UnsupportedContentType" $ \baseUrl -> do
344424 let (getGet :<|> _ ) = client api
345425 Left res <- runClientM getGet (ClientEnv manager baseUrl)
346426 case res of
347427 UnsupportedContentType ("application/octet-stream") _ -> return ()
348428 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
349429
350− it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
430+ it "reports InvalidContentTypeHeader" $ \baseUrl -> do
351431 let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
352432 Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl)
433+
353434 case res of
354435 InvalidContentTypeHeader "fooooo" _ -> return ()
355436 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
356437
357−data WrappedApi where
358− WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
359− HasClient api, Client api ~ SCR.ClientM ()) =>
360− Proxy api -> WrappedApi
361−
362−basicAuthSpec :: Spec
363−basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
364− context "Authentication works when requests are properly authenticated" $ do
365−
366− it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
367− let getBasic = client basicAuthAPI
368− let basicAuthData = BasicAuthData "servant" "server"
369− (left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
370−
371− context "Authentication is rejected when requests are not authenticated properly" $ do
372−
373− it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
374− let getBasic = client basicAuthAPI
375− let basicAuthData = BasicAuthData "not" "password"
376− Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)
377− responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
378−
379−genAuthSpec :: Spec
380−genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
381− context "Authentication works when requests are properly authenticated" $ do
382−
383− it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
384− let getProtected = client genAuthAPI
385− let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
386− (left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
387−
388− context "Authentication is rejected when requests are not authenticated properly" $ do
389−
390− it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
391− let getProtected = client genAuthAPI
392− let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
393− Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl)
394− responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
395−
396438-- * utils
397439
398−startWaiApp :: Application -> IO (ThreadId, BaseUrl)
399−startWaiApp app = do
400− (port, socket) <- openTestSocket
401− let settings = setPort port $ defaultSettings
402− thread <- forkIO $ runSettingsSocket settings socket app
403− return (thread, BaseUrl Http "localhost" port "")
404−
405−
406−endWaiApp :: (ThreadId, BaseUrl) -> IO ()
407−endWaiApp (thread, _) = killThread thread
408−
409−openTestSocket :: IO (Port, Socket)
410−openTestSocket = do
411− s <- socket AF_INET Stream defaultProtocol
412− localhost <- inet_addr "127.0.0.1"
413− bind s (SockAddrInet aNY_PORT localhost)
414− listen s 1
415− port <- socketPort s
416− return (fromIntegral port, s)
417−
418440pathGen :: Gen (NonEmptyList Char)
419441pathGen = fmap NonEmpty path
420442 where