use TestServer better

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__

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
 

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)

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

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