@@ -1,5 +1,4 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
32{-# LANGUAGE DataKinds #-}
43{-# LANGUAGE DeriveGeneric #-}
54{-# LANGUAGE FlexibleContexts #-}
@@ -11,24 +10,19 @@
1110{-# LANGUAGE PolyKinds #-}
1211{-# LANGUAGE RecordWildCards #-}
1312{-# LANGUAGE StandaloneDeriving #-}
14−{-# LANGUAGE ScopedTypeVariables #-}
1513{-# LANGUAGE TypeFamilies #-}
1614{-# LANGUAGE TypeOperators #-}
1715{-# LANGUAGE UndecidableInstances #-}
1816{-# OPTIONS_GHC -fcontext-stack=100 #-}
1917{-# OPTIONS_GHC -fno-warn-orphans #-}
20−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2118
22−#include "overlapping-compat.h"
2319module Servant.ClientSpec where
2420
2521#if !MIN_VERSION_base(4,8,0)
2622import Control.Applicative ((<$>))
2723#endif
2824import Control.Arrow (left)
29−import Control.Concurrent (forkIO, killThread, ThreadId)
30−import Control.Exception (bracket)
31−import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)
25+import Control.Monad.Trans.Except (runExceptT, throwE)
3226import Data.Aeson
3327import qualified Data.ByteString.Lazy as BS
3428import Data.Char (chr, isPrint)
@@ -39,34 +33,74 @@ import qualified Data.Text as T
3933import GHC.Generics (Generic)
4034import qualified Network.HTTP.Client as C
4135import Network.HTTP.Media
42−import qualified Network.HTTP.Types as HTTP
43−import Network.Socket
44−import Network.Wai (Application, Request,
45− requestHeaders, responseLBS)
46−import Network.Wai.Handler.Warp
36+import qualified Network.HTTP.Types as HTTP
37+import Network.Wai (responseLBS)
38+import qualified Network.Wai as Wai
39+import System.Exit
4740import System.IO.Unsafe (unsafePerformIO)
41+import Test.HUnit
4842import Test.Hspec
4943import Test.Hspec.QuickCheck
50−import Test.HUnit
5144import Test.QuickCheck
5245
5346import Servant.API
54−import Servant.API.Internal.Test.ComprehensiveAPI
5547import Servant.Client
48+import Servant.Client.TestServer
49+import qualified Servant.Common.Req as SCR
5650import Servant.Server
5751import Servant.Server.Experimental.Auth
58−import qualified Servant.Common.Req as SCR
59−
60−-- This declaration simply checks that all instances are in place.
61−_ = client comprehensiveAPI
6252
6353spec :: Spec
64−spec = describe "Servant.Client" $ do
54+spec = do
55+ runIO buildTestServer
56+ describe "Servant.Client" $ do
6557 sucessSpec
6658 failSpec
67− wrappedApiSpec
6859 basicAuthSpec
6960 genAuthSpec
61+ errorSpec
62+
63+-- | Run a test-server (identified by name) while performing the given action.
64+-- The provided 'BaseUrl' points to the running server.
65+--
66+-- Running the test-servers is done differently depending on the compiler
67+-- (ghc or ghcjs).
68+--
69+-- With ghc it's somewhat straight-forward: a wai 'Application' is being started
70+-- on a free port inside the same process using 'warp'.
71+--
72+-- When running the test-suite with ghcjs all the test-servers are compiled into
73+-- a single external executable (with ghc and warp). This is done through
74+-- 'buildTestServer' once at the start of the test-suite. This built executable
75+-- will provide all the test-servers on a free port under a path that
76+-- corresponds to the test-servers name, for example under
77+-- 'http://localhost:82923/failServer'. 'withTestServer' will then
78+-- start this executable as an external process while the given action is being
79+-- executed and provide it with the correct BaseUrl.
80+-- This rather cumbersome approach is taken because it's not easy to run a wai
81+-- Application as a http server when using ghcjs.
82+withTestServer :: String -> (BaseUrl -> IO a) -> IO a
83+withTestServer name action = do
84+ server <- lookupTestServer name
85+ withServer server action
86+
87+lookupTestServer :: String -> IO TestServer
88+lookupTestServer name = case lookup name mapping of
89+ Nothing -> die ("test server not found: " ++ name)
90+ Just testServer -> return testServer
91+ where
92+ mapping :: [(String, TestServer)]
93+ mapping = map (\ server -> (testServerName server, server)) allTestServers
94+
95+-- | All test-servers must be registered here.
96+allTestServers :: [TestServer]
97+allTestServers =
98+ server :
99+ errorServer :
100+ failServer :
101+ basicAuthServer :
102+ genAuthServer :
103+ []
70104
71105-- * test data types
72106
@@ -147,8 +181,8 @@ getGet
147181 :<|> getRespHeaders
148182 :<|> getDeleteContentType = client api
149183
150−server :: Application
151−server = serve api (
184+server :: TestServer
185+server = TestServer "server" $ serve api (
152186 return alice
153187 :<|> return NoContent
154188 :<|> (\ name -> return $ Person name 0)
@@ -166,19 +200,19 @@ server = serve api (
166200 :<|> return NoContent
167201 )
168202
169−
170203type FailApi =
171204 "get" :> Raw
172205 :<|> "capture" :> Capture "name" String :> Raw
173206 :<|> "body" :> Raw
207+
174208failApi :: Proxy FailApi
175209failApi = Proxy
176210
177−failServer :: Application
178−failServer = serve failApi (
211+failServer :: TestServer
212+failServer = TestServer "failServer" $ serve failApi (
179213 (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
180214 :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
181− :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
215+ :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
182216 )
183217
184218-- * basic auth stuff
@@ -200,8 +234,9 @@ basicAuthHandler =
200234basicServerContext :: Context '[ BasicAuthCheck () ]
201235basicServerContext = basicAuthHandler :. EmptyContext
202236
203−basicAuthServer :: Application
204−basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
237+basicAuthServer :: TestServer
238+basicAuthServer = TestServer "basicAuthServer" $
239+ serveWithContext basicAuthAPI basicServerContext (const (return alice))
205240
206241-- * general auth stuff
207242
@@ -214,58 +249,59 @@ genAuthAPI = Proxy
214249type instance AuthServerData (AuthProtect "auth-tag") = ()
215250type instance AuthClientData (AuthProtect "auth-tag") = ()
216251
217−genAuthHandler :: AuthHandler Request ()
252+genAuthHandler :: AuthHandler Wai.Request ()
218253genAuthHandler =
219− let handler req = case lookup "AuthHeader" (requestHeaders req) of
254+ let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
220255 Nothing -> throwE (err401 { errBody = "Missing auth header" })
221256 Just _ -> return ()
222257 in mkAuthHandler handler
223258
224−genAuthServerContext :: Context '[ AuthHandler Request () ]
259+genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
225260genAuthServerContext = genAuthHandler :. EmptyContext
226261
227−genAuthServer :: Application
228−genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
262+genAuthServer :: TestServer
263+genAuthServer = TestServer "genAuthServer" $
264+ serveWithContext genAuthAPI genAuthServerContext (const (return alice))
229265
230266{-# NOINLINE manager #-}
231267manager :: C.Manager
232268manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
233269
234270sucessSpec :: Spec
235−sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
271+sucessSpec = around (withTestServer "server") $ do
236272
237− it "Servant.API.Get" $ \(_, baseUrl) -> do
273+ it "Servant.API.Get" $ \baseUrl -> do
238274 (left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice
239275
240276 describe "Servant.API.Delete" $ do
241− it "allows empty content type" $ \(_, baseUrl) -> do
277+ it "allows empty content type" $ \baseUrl -> do
242278 (left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent
243279
244− it "allows content type" $ \(_, baseUrl) -> do
280+ it "allows content type" $ \baseUrl -> do
245281 (left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent
246282
247− it "Servant.API.Capture" $ \(_, baseUrl) -> do
283+ it "Servant.API.Capture" $ \baseUrl -> do
248284 (left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0)
249285
250− it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
286+ it "Servant.API.ReqBody" $ \baseUrl -> do
251287 let p = Person "Clara" 42
252288 (left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p
253289
254− it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
290+ it "Servant.API.QueryParam" $ \baseUrl -> do
255291 left show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice
256292 Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl)
257293 responseStatus `shouldBe` HTTP.Status 400 "bob not found"
258294
259− it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
295+ it "Servant.API.QueryParam.QueryParams" $ \baseUrl -> do
260296 (left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right []
261297 (left show <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl))
262298 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
263299
264300 context "Servant.API.QueryParam.QueryFlag" $
265− forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
301+ forM_ [False, True] $ \ flag -> it (show flag) $ \baseUrl -> do
266302 (left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag
267303
268− it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
304+ it "Servant.API.Raw on success" $ \baseUrl -> do
269305 res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl)
270306 case res of
271307 Left e -> assertFailure $ show e
@@ -274,7 +310,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
274310 C.responseBody response `shouldBe` body
275311 C.responseStatus response `shouldBe` HTTP.ok200
276312
277− it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
313+ it "Servant.API.Raw should return a Left in case of failure" $ \baseUrl -> do
278314 res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl)
279315 case res of
280316 Right _ -> assertFailure "expected Left, but got Right"
@@ -282,51 +318,93 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
282318 Servant.Client.responseStatus e `shouldBe` HTTP.status400
283319 Servant.Client.responseBody e `shouldBe` "rawFailure"
284320
285− it "Returns headers appropriately" $ \(_, baseUrl) -> do
321+ it "Returns headers appropriately" $ \baseUrl -> do
286322 res <- runExceptT (getRespHeaders manager baseUrl)
287323 case res of
288324 Left e -> assertFailure $ show e
289325 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
290326
291327 modifyMaxSuccess (const 20) $ do
292− it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
328+ it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \baseUrl ->
293329 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
294330 ioProperty $ do
295331 result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl)
296332 return $
297333 result === Right (cap, num, flag, body)
298334
335+type ErrorApi =
336+ Delete '[JSON] () :<|>
337+ Get '[JSON] () :<|>
338+ Post '[JSON] () :<|>
339+ Put '[JSON] ()
340+
341+errorApi :: Proxy ErrorApi
342+errorApi = Proxy
343+
344+errorServer :: TestServer
345+errorServer = TestServer "errorServer" $ serve errorApi $
346+ err :<|> err :<|> err :<|> err
347+ where
348+ err = throwE $ ServantErr 500 "error message" "" []
349+
350+errorSpec :: Spec
351+errorSpec =
352+ around (withTestServer "errorServer") $ do
353+ describe "error status codes" $
354+ it "reports error statuses correctly" $ \baseUrl -> do
355+ let delete :<|> get :<|> post :<|> put =
356+ client errorApi
357+ actions = map (\ f -> f manager baseUrl) [delete, get, post, put]
358+ forM_ actions $ \ clientAction -> do
359+ Left FailureResponse{..} <- runExceptT clientAction
360+ responseStatus `shouldBe` HTTP.Status 500 "error message"
361+
362+basicAuthSpec :: Spec
363+basicAuthSpec = around (withTestServer "basicAuthServer") $ 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 <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice
299370
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 :: C.Manager -> BaseUrl -> SCR.ClientM ()
308− getResponse = client api
309− Left FailureResponse{..} <- runExceptT (getResponse 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− []
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{..} <- runExceptT (getBasic basicAuthData manager baseUrl)
377+ responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
378+
379+genAuthSpec :: Spec
380+genAuthSpec = around (withTestServer "genAuthServer") $ 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 <$> runExceptT (getProtected authRequest 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{..} <- runExceptT (getProtected authRequest manager baseUrl)
394+ responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
317395
318396failSpec :: Spec
319−failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
397+failSpec = around (withTestServer "failServer") $ do
320398
321399 context "client returns errors appropriately" $ do
322− it "reports FailureResponse" $ \(_, baseUrl) -> do
400+ it "reports FailureResponse" $ \baseUrl -> do
323401 let (_ :<|> getDeleteEmpty :<|> _) = client api
324402 Left res <- runExceptT (getDeleteEmpty manager baseUrl)
325403 case res of
326404 FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
327405 _ -> fail $ "expected 404 response, but got " <> show res
328406
329− it "reports DecodeFailure" $ \(_, baseUrl) -> do
407+ it "reports DecodeFailure" $ \baseUrl -> do
330408 let (_ :<|> _ :<|> getCapture :<|> _) = client api
331409 Left res <- runExceptT (getCapture "foo" manager baseUrl)
332410 case res of
@@ -340,81 +418,23 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
340418 ConnectionError _ -> return ()
341419 _ -> fail $ "expected ConnectionError, but got " <> show res
342420
343− it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
421+ it "reports UnsupportedContentType" $ \baseUrl -> do
344422 let (getGet :<|> _ ) = client api
345423 Left res <- runExceptT (getGet manager baseUrl)
346424 case res of
347425 UnsupportedContentType ("application/octet-stream") _ -> return ()
348426 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
349427
350− it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
428+ it "reports InvalidContentTypeHeader" $ \baseUrl -> do
351429 let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
352430 Left res <- runExceptT (getBody alice manager baseUrl)
353431 case res of
354432 InvalidContentTypeHeader "fooooo" _ -> return ()
355433 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
356434
357−data WrappedApi where
358− WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a,
359− HasClient api, Client api ~ (C.Manager -> BaseUrl -> 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 <$> runExceptT (getBasic basicAuthData 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{..} <- runExceptT (getBasic basicAuthData 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 <$> runExceptT (getProtected authRequest 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{..} <- runExceptT (getProtected authRequest manager baseUrl)
394− responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
395435
396436-- * utils
397437
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−
418438pathGen :: Gen (NonEmptyList Char)
419439pathGen = fmap NonEmpty path
420440 where