@@ -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,18 +19,14 @@
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)
35−import Control.Monad.Trans.Except (throwE, runExceptT)
29+import Control.Monad.Trans.Except (runExceptT, throwE)
3630import Data.Aeson
3731import qualified Data.ByteString.Lazy as BS
3832import Data.Char (chr, isPrint)
@@ -43,33 +37,74 @@ import qualified Data.Text as T
4337import GHC.Generics (Generic)
4438import qualified Network.HTTP.Client as C
4539import Network.HTTP.Media
46−import qualified Network.HTTP.Types as HTTP
47−import Network.Socket
48−import Network.Wai (Request, requestHeaders, responseLBS)
49−import Network.Wai.Handler.Warp
40+import qualified Network.HTTP.Types as HTTP
41+import Network.Wai (responseLBS)
42+import qualified Network.Wai as Wai
43+import System.Exit.Compat
5044import System.IO.Unsafe (unsafePerformIO)
45+import Test.HUnit
5146import Test.Hspec
5247import Test.Hspec.QuickCheck
53−import Test.HUnit
5448import Test.QuickCheck
5549
5650import Servant.API
57−import Servant.API.Internal.Test.ComprehensiveAPI
5851import Servant.Client
52+import Servant.Client.TestServer
53+import qualified Servant.Common.Req as SCR
5954import Servant.Server
6055import 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
6556
6657spec :: Spec
67−spec = describe "Servant.Client" $ do
58+spec = do
59+ runIO buildTestServer
60+ describe "Servant.Client" $ do
6861 sucessSpec
6962 failSpec
70− wrappedApiSpec
7163 basicAuthSpec
7264 genAuthSpec
65+ errorSpec
66+
67+-- | Run a test-server (identified by name) while performing the given action.
68+-- The provided 'BaseUrl' points to the running server.
69+--
70+-- Running the test-servers is done differently depending on the compiler
71+-- (ghc or ghcjs).
72+--
73+-- With ghc it's somewhat straight-forward: a wai 'Application' is being started
74+-- on a free port inside the same process using 'warp'.
75+--
76+-- When running the test-suite with ghcjs all the test-servers are compiled into
77+-- a single external executable (with ghc and warp). This is done through
78+-- 'buildTestServer' once at the start of the test-suite. This built executable
79+-- will provide all the test-servers on a free port under a path that
80+-- corresponds to the test-servers name, for example under
81+-- 'http://localhost:82923/failServer'. 'withTestServer' will then
82+-- start this executable as an external process while the given action is being
83+-- executed and provide it with the correct BaseUrl.
84+-- This rather cumbersome approach is taken because it's not easy to run a wai
85+-- Application as a http server when using ghcjs.
86+withTestServer :: String -> (BaseUrl -> IO a) -> IO a
87+withTestServer name action = do
88+ server <- lookupTestServer name
89+ withServer server action
90+
91+lookupTestServer :: String -> IO TestServer
92+lookupTestServer name = case lookup name mapping of
93+ Nothing -> die ("test server not found: " ++ name)
94+ Just testServer -> return testServer
95+ where
96+ mapping :: [(String, TestServer)]
97+ mapping = map (\ server -> (testServerName server, server)) allTestServers
98+
99+-- | All test-servers must be registered here.
100+allTestServers :: [TestServer]
101+allTestServers =
102+ server :
103+ errorServer :
104+ failServer :
105+ basicAuthServer :
106+ genAuthServer :
107+ []
73108
74109-- * test data types
75110
@@ -150,8 +185,8 @@ getGet
150185 :<|> getRespHeaders
151186 :<|> getDeleteContentType = client api
152187
153−server :: Application
154−server = serve api (
188+server :: TestServer
189+server = TestServer "server" $ serve api (
155190 return alice
156191 :<|> return NoContent
157192 :<|> (\ name -> return $ Person name 0)
@@ -169,19 +204,19 @@ server = serve api (
169204 :<|> return NoContent
170205 )
171206
172−
173207type FailApi =
174208 "get" :> Raw
175209 :<|> "capture" :> Capture "name" String :> Raw
176210 :<|> "body" :> Raw
211+
177212failApi :: Proxy FailApi
178213failApi = Proxy
179214
180−failServer :: Application
181−failServer = serve failApi (
215+failServer :: TestServer
216+failServer = TestServer "failServer" $ serve failApi (
182217 (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
183218 :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
184− :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
219+ :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
185220 )
186221
187222-- * basic auth stuff
@@ -203,8 +238,9 @@ basicAuthHandler =
203238basicServerContext :: Context '[ BasicAuthCheck () ]
204239basicServerContext = basicAuthHandler :. EmptyContext
205240
206−basicAuthServer :: Application
207−basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
241+basicAuthServer :: TestServer
242+basicAuthServer = TestServer "basicAuthServer" $
243+ serveWithContext basicAuthAPI basicServerContext (const (return alice))
208244
209245-- * general auth stuff
210246
@@ -217,58 +253,59 @@ genAuthAPI = Proxy
217253type instance AuthServerData (AuthProtect "auth-tag") = ()
218254type instance AuthClientData (AuthProtect "auth-tag") = ()
219255
220−genAuthHandler :: AuthHandler Request ()
256+genAuthHandler :: AuthHandler Wai.Request ()
221257genAuthHandler =
222− let handler req = case lookup "AuthHeader" (requestHeaders req) of
258+ let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
223259 Nothing -> throwE (err401 { errBody = "Missing auth header" })
224260 Just _ -> return ()
225261 in mkAuthHandler handler
226262
227−genAuthServerContext :: Context '[ AuthHandler Request () ]
263+genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
228264genAuthServerContext = genAuthHandler :. EmptyContext
229265
230−genAuthServer :: Application
231−genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
266+genAuthServer :: TestServer
267+genAuthServer = TestServer "genAuthServer" $
268+ serveWithContext genAuthAPI genAuthServerContext (const (return alice))
232269
233270{-# NOINLINE manager #-}
234271manager :: C.Manager
235272manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
236273
237274sucessSpec :: Spec
238−sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
275+sucessSpec = around (withTestServer "server") $ do
239276
240− it "Servant.API.Get" $ \(_, baseUrl) -> do
277+ it "Servant.API.Get" $ \baseUrl -> do
241278 (left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice
242279
243280 describe "Servant.API.Delete" $ do
244− it "allows empty content type" $ \(_, baseUrl) -> do
281+ it "allows empty content type" $ \baseUrl -> do
245282 (left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent
246283
247− it "allows content type" $ \(_, baseUrl) -> do
284+ it "allows content type" $ \baseUrl -> do
248285 (left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent
249286
250− it "Servant.API.Capture" $ \(_, baseUrl) -> do
287+ it "Servant.API.Capture" $ \baseUrl -> do
251288 (left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0)
252289
253− it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
290+ it "Servant.API.ReqBody" $ \baseUrl -> do
254291 let p = Person "Clara" 42
255292 (left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p
256293
257− it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
294+ it "Servant.API.QueryParam" $ \baseUrl -> do
258295 left show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice
259296 Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl)
260297 responseStatus `shouldBe` HTTP.Status 400 "bob not found"
261298
262− it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
299+ it "Servant.API.QueryParam.QueryParams" $ \baseUrl -> do
263300 (left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right []
264301 (left show <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl))
265302 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
266303
267304 context "Servant.API.QueryParam.QueryFlag" $
268− forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
305+ forM_ [False, True] $ \ flag -> it (show flag) $ \baseUrl -> do
269306 (left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag
270307
271− it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
308+ it "Servant.API.Raw on success" $ \baseUrl -> do
272309 res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl)
273310 case res of
274311 Left e -> assertFailure $ show e
@@ -277,7 +314,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
277314 C.responseBody response `shouldBe` body
278315 C.responseStatus response `shouldBe` HTTP.ok200
279316
280− it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
317+ it "Servant.API.Raw should return a Left in case of failure" $ \baseUrl -> do
281318 res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl)
282319 case res of
283320 Right _ -> assertFailure "expected Left, but got Right"
@@ -285,51 +322,93 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
285322 Servant.Client.responseStatus e `shouldBe` HTTP.status400
286323 Servant.Client.responseBody e `shouldBe` "rawFailure"
287324
288− it "Returns headers appropriately" $ \(_, baseUrl) -> do
325+ it "Returns headers appropriately" $ \baseUrl -> do
289326 res <- runExceptT (getRespHeaders manager baseUrl)
290327 case res of
291328 Left e -> assertFailure $ show e
292329 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
293330
294331 modifyMaxSuccess (const 20) $ do
295− it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
332+ it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \baseUrl ->
296333 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
297334 ioProperty $ do
298335 result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl)
299336 return $
300337 result === Right (cap, num, flag, body)
301338
339+type ErrorApi =
340+ Delete '[JSON] () :<|>
341+ Get '[JSON] () :<|>
342+ Post '[JSON] () :<|>
343+ Put '[JSON] ()
344+
345+errorApi :: Proxy ErrorApi
346+errorApi = Proxy
347+
348+errorServer :: TestServer
349+errorServer = TestServer "errorServer" $ serve errorApi $
350+ err :<|> err :<|> err :<|> err
351+ where
352+ err = throwE $ ServantErr 500 "error message" "" []
353+
354+errorSpec :: Spec
355+errorSpec =
356+ around (withTestServer "errorServer") $ do
357+ describe "error status codes" $
358+ it "reports error statuses correctly" $ \baseUrl -> do
359+ let delete :<|> get :<|> post :<|> put =
360+ client errorApi
361+ actions = map (\ f -> f manager baseUrl) [delete, get, post, put]
362+ forM_ actions $ \ clientAction -> do
363+ Left FailureResponse{..} <- runExceptT clientAction
364+ responseStatus `shouldBe` HTTP.Status 500 "error message"
365+
366+basicAuthSpec :: Spec
367+basicAuthSpec = around (withTestServer "basicAuthServer") $ do
368+ context "Authentication works when requests are properly authenticated" $ do
369+
370+ it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
371+ let getBasic = client basicAuthAPI
372+ let basicAuthData = BasicAuthData "servant" "server"
373+ (left show <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice
374+
375+ context "Authentication is rejected when requests are not authenticated properly" $ do
376+
377+ it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
378+ let getBasic = client basicAuthAPI
379+ let basicAuthData = BasicAuthData "not" "password"
380+ Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl)
381+ responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
382+
383+genAuthSpec :: Spec
384+genAuthSpec = around (withTestServer "genAuthServer") $ do
385+ context "Authentication works when requests are properly authenticated" $ do
386+
387+ it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
388+ let getProtected = client genAuthAPI
389+ let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
390+ (left show <$> runExceptT (getProtected authRequest manager baseUrl)) `shouldReturn` Right alice
391+
392+ context "Authentication is rejected when requests are not authenticated properly" $ do
302393
303−wrappedApiSpec :: Spec
304−wrappedApiSpec = describe "error status codes" $ do
305− let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
306− context "are correctly handled by the client" $
307− let test :: (WrappedApi, String) -> Spec
308− test (WrappedApi api, desc) =
309− it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
310− let getResponse :: C.Manager -> BaseUrl -> SCR.ClientM ()
311− getResponse = client api
312− Left FailureResponse{..} <- runExceptT (getResponse manager baseUrl)
313− responseStatus `shouldBe` (HTTP.Status 500 "error message")
314− in mapM_ test $
315− (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
316− (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
317− (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
318− (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
319− []
394+ it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
395+ let getProtected = client genAuthAPI
396+ let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
397+ Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl)
398+ responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
320399
321400failSpec :: Spec
322−failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
401+failSpec = around (withTestServer "failServer") $ do
323402
324403 context "client returns errors appropriately" $ do
325− it "reports FailureResponse" $ \(_, baseUrl) -> do
404+ it "reports FailureResponse" $ \baseUrl -> do
326405 let (_ :<|> getDeleteEmpty :<|> _) = client api
327406 Left res <- runExceptT (getDeleteEmpty manager baseUrl)
328407 case res of
329408 FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
330409 _ -> fail $ "expected 404 response, but got " <> show res
331410
332− it "reports DecodeFailure" $ \(_, baseUrl) -> do
411+ it "reports DecodeFailure" $ \baseUrl -> do
333412 let (_ :<|> _ :<|> getCapture :<|> _) = client api
334413 Left res <- runExceptT (getCapture "foo" manager baseUrl)
335414 case res of
@@ -343,81 +422,22 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
343422 ConnectionError _ -> return ()
344423 _ -> fail $ "expected ConnectionError, but got " <> show res
345424
346− it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
425+ it "reports UnsupportedContentType" $ \baseUrl -> do
347426 let (getGet :<|> _ ) = client api
348427 Left res <- runExceptT (getGet manager baseUrl)
349428 case res of
350429 UnsupportedContentType ("application/octet-stream") _ -> return ()
351430 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
352431
353− it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
432+ it "reports InvalidContentTypeHeader" $ \baseUrl -> do
354433 let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
355434 Left res <- runExceptT (getBody alice manager baseUrl)
356435 case res of
357436 InvalidContentTypeHeader "fooooo" _ -> return ()
358437 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
359438
360−data WrappedApi where
361− WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
362− HasClient api, Client api ~ (C.Manager -> BaseUrl -> SCR.ClientM ())) =>
363− Proxy api -> WrappedApi
364−
365−basicAuthSpec :: Spec
366−basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
367− context "Authentication works when requests are properly authenticated" $ do
368−
369− it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
370− let getBasic = client basicAuthAPI
371− let basicAuthData = BasicAuthData "servant" "server"
372− (left show <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice
373−
374− context "Authentication is rejected when requests are not authenticated properly" $ do
375−
376− it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
377− let getBasic = client basicAuthAPI
378− let basicAuthData = BasicAuthData "not" "password"
379− Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl)
380− responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
381−
382−genAuthSpec :: Spec
383−genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
384− context "Authentication works when requests are properly authenticated" $ do
385−
386− it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
387− let getProtected = client genAuthAPI
388− let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
389− (left show <$> runExceptT (getProtected authRequest manager baseUrl)) `shouldReturn` Right alice
390−
391− context "Authentication is rejected when requests are not authenticated properly" $ do
392−
393− it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
394− let getProtected = client genAuthAPI
395− let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
396− Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl)
397− responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
398−
399439-- * utils
400440
401−startWaiApp :: Application -> IO (ThreadId, BaseUrl)
402−startWaiApp app = do
403− (port, socket) <- openTestSocket
404− let settings = setPort port $ defaultSettings
405− thread <- forkIO $ runSettingsSocket settings socket app
406− return (thread, BaseUrl Http "localhost" port "")
407−
408−
409−endWaiApp :: (ThreadId, BaseUrl) -> IO ()
410−endWaiApp (thread, _) = killThread thread
411−
412−openTestSocket :: IO (Port, Socket)
413−openTestSocket = do
414− s <- socket AF_INET Stream defaultProtocol
415− localhost <- inet_addr "127.0.0.1"
416− bind s (SockAddrInet aNY_PORT localhost)
417− listen s 1
418− port <- socketPort s
419− return (fromIntegral port, s)
420−
421441pathGen :: Gen (NonEmptyList Char)
422442pathGen = fmap NonEmpty path
423443 where