From 5329aa015efc78bbce4ded2b08d0bed0083193f4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Mon, 4 Jan 2016 19:04:10 +0100 Subject: [PATCH] use TestServer better --- .../test/Servant/Client/TestServer.hs | 5 +++- .../test/Servant/Client/TestServer/GHC.hs | 4 +-- .../test/Servant/Client/TestServer/GHCJS.hs | 4 +-- servant-client/test/Servant/ClientSpec.hs | 29 +++++++++++++++---- servant-client/test/ghcjs/testServer.hs | 10 ++----- 5 files changed, 34 insertions(+), 18 deletions(-) diff --git a/servant-client/test/Servant/Client/TestServer.hs b/servant-client/test/Servant/Client/TestServer.hs index 92747f75..1a9b1ea6 100644 --- a/servant-client/test/Servant/Client/TestServer.hs +++ b/servant-client/test/Servant/Client/TestServer.hs @@ -1,9 +1,12 @@ {-# LANGUAGE CPP #-} +-- | Testing works very differently under ghc and ghcjs. This module acts as a +-- CPP switch and import different modules depending on the used compiler (ghc +-- or ghcjs). Both imported modules provide the same API. module Servant.Client.TestServer ( buildTestServer, TestServer(..), - withTestServer, + withServer, )where #ifdef __GHCJS__ diff --git a/servant-client/test/Servant/Client/TestServer/GHC.hs b/servant-client/test/Servant/Client/TestServer/GHC.hs index d5da8465..fb706e97 100644 --- a/servant-client/test/Servant/Client/TestServer/GHC.hs +++ b/servant-client/test/Servant/Client/TestServer/GHC.hs @@ -14,8 +14,8 @@ import Servant.Client.TestServer.Types buildTestServer :: IO () buildTestServer = return () -withTestServer :: TestServer -> (BaseUrl -> IO a) -> IO a -withTestServer (TestServer _ app) action = +withServer :: TestServer -> (BaseUrl -> IO a) -> IO a +withServer (TestServer _ app) action = bracket (startWaiApp app) endWaiApp $ \ (_, url) -> action url diff --git a/servant-client/test/Servant/Client/TestServer/GHCJS.hs b/servant-client/test/Servant/Client/TestServer/GHCJS.hs index d0d707df..a303e0de 100644 --- a/servant-client/test/Servant/Client/TestServer/GHCJS.hs +++ b/servant-client/test/Servant/Client/TestServer/GHCJS.hs @@ -16,8 +16,8 @@ buildTestServer = do ExitSuccess <- waitForProcess process return () -withTestServer :: TestServer -> (BaseUrl -> IO a) -> IO a -withTestServer (TestServer testServerName _) action = do +withServer :: TestServer -> (BaseUrl -> IO a) -> IO a +withServer (TestServer testServerName _) action = do bracket start stop $ \ (port, _) -> action (BaseUrl Http "localhost" port ("/" ++ testServerName)) where start :: IO (Int, ProcessHandle) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index c48a748a..df726c2f 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -12,13 +12,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fcontext-stack=100 #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.ClientSpec where @@ -41,9 +41,9 @@ import Network.HTTP.Types (Status (..), badRequest400, methodGet, ok200, status400) import Network.Wai (responseLBS) import System.IO.Unsafe (unsafePerformIO) +import Test.HUnit import Test.Hspec import Test.Hspec.QuickCheck -import Test.HUnit import Test.QuickCheck import Servant.API @@ -59,6 +59,23 @@ spec = do failSpec errorSpec +lookupTestServer :: String -> TestServer +lookupTestServer name = case lookup name mapping of + Nothing -> error ("test server not found: " ++ name) + Just testServer -> testServer + where + mapping :: [(String, TestServer)] + mapping = map (\ server -> (testServerName server, server)) allTestServers + + allTestServers = + server : + errorServer : + failServer : + [] + +withTestServer :: String -> (BaseUrl -> IO a) -> IO a +withTestServer = withServer . lookupTestServer + -- * test data types data Person = Person { @@ -149,7 +166,7 @@ manager :: C.Manager manager = unsafePerformIO $ C.newManager C.defaultManagerSettings sucessSpec :: Spec -sucessSpec = around (withTestServer server) $ do +sucessSpec = around (withTestServer "server") $ do it "Servant.API.Get" $ \baseUrl -> do let getGet = getNth (Proxy :: Proxy 0) $ client api baseUrl manager @@ -242,7 +259,7 @@ errorServer = TestServer "errorServer" $ serve errorApi $ errorSpec :: Spec errorSpec = - around (withTestServer errorServer) $ do + around (withTestServer "errorServer") $ do describe "error status codes" $ it "reports error statuses correctly" $ \baseUrl -> do let delete :<|> get :<|> post :<|> put = @@ -253,7 +270,7 @@ errorSpec = responseStatus `shouldBe` Status 500 "error message" failSpec :: Spec -failSpec = around (withTestServer failServer) $ do +failSpec = around (withTestServer "failServer") $ do context "client returns errors appropriately" $ do it "reports FailureResponse" $ \baseUrl -> do diff --git a/servant-client/test/ghcjs/testServer.hs b/servant-client/test/ghcjs/testServer.hs index 48996e8f..c5fbe5f1 100644 --- a/servant-client/test/ghcjs/testServer.hs +++ b/servant-client/test/ghcjs/testServer.hs @@ -17,15 +17,11 @@ main = do setBeforeMainLoop (print port >> hFlush stdout) $ defaultSettings runSettingsSocket settings socket $ - serve testServerApi $ - testServerApp server :<|> - testServerApp errorServer :<|> - testServerApp failServer + serve testServerApi $ \ testServerName -> + testServerApp $ lookupTestServer testServerName type TestServerApi = - "server" :> Raw :<|> - "errorServer" :> Raw :<|> - "failServer" :> Raw + Capture "testServerName" String :> Raw testServerApi :: Proxy TestServerApi testServerApi = Proxy