servant-client: add TestServer

servant-client/servant-client.cabal

@@ -63,7 +63,7 @@ library
       , ghcjs-prim
   hs-source-dirs: src
   default-language: Haskell2010
-  ghc-options: -Wall -Werror
+  ghc-options: -Wall
 
 test-suite spec
   type: exitcode-stdio-1.0

servant-client/test/Servant/Client/TestServer.hs

@@ -2,6 +2,7 @@
 
 module Servant.Client.TestServer (
   buildTestServer,
+  TestServer(..),
   withTestServer,
 )where
 
@@ -10,3 +11,5 @@ import           Servant.Client.TestServer.GHCJS
 #else
 import           Servant.Client.TestServer.GHC
 #endif
+
+import           Servant.Client.TestServer.Types

servant-client/test/Servant/Client/TestServer/GHC.hs

@@ -9,12 +9,13 @@ import           Network.Wai
 import           Network.Wai.Handler.Warp
 
 import           Servant.Common.BaseUrl
+import           Servant.Client.TestServer.Types
 
 buildTestServer :: IO ()
 buildTestServer = return ()
 
-withTestServer :: Application -> String -> (BaseUrl -> IO a) -> IO a
-withTestServer app _ action =
+withTestServer :: TestServer -> (BaseUrl -> IO a) -> IO a
+withTestServer (TestServer _ app) action =
   bracket (startWaiApp app) endWaiApp $ \ (_, url) ->
     action url
 

servant-client/test/Servant/Client/TestServer/GHCJS.hs

@@ -2,12 +2,12 @@
 module Servant.Client.TestServer.GHCJS where
 
 import           Control.Exception
-import           Network.Wai
 import           Safe
 import           System.Exit
 import           System.IO
 import           System.Process
 
+import           Servant.Client.TestServer.Types
 import           Servant.Common.BaseUrl
 
 buildTestServer :: IO ()
@@ -16,8 +16,8 @@ buildTestServer = do
   ExitSuccess <- waitForProcess process
   return ()
 
-withTestServer :: Application -> String -> (BaseUrl -> IO a) -> IO a
-withTestServer _ testServerName action = do
+withTestServer :: TestServer -> (BaseUrl -> IO a) -> IO a
+withTestServer (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

@@ -39,7 +39,7 @@ import qualified Network.HTTP.Client        as C
 import           Network.HTTP.Media
 import           Network.HTTP.Types         (Status (..), badRequest400,
                                              methodGet, ok200, status400)
-import           Network.Wai                (Application, responseLBS)
+import           Network.Wai                (responseLBS)
 import           System.IO.Unsafe           (unsafePerformIO)
 import           Test.Hspec
 import           Test.Hspec.QuickCheck
@@ -110,8 +110,8 @@ type Api =
 api :: Proxy Api
 api = Proxy
 
-server :: Application
-server = serve api (
+server :: TestServer
+server = TestServer "server" $ serve api (
        return alice
   :<|> return ()
   :<|> (\ name -> return $ Person name 0)
@@ -137,8 +137,8 @@ type FailApi =
 failApi :: Proxy FailApi
 failApi = Proxy
 
-failServer :: Application
-failServer = serve failApi (
+failServer :: TestServer
+failServer = TestServer "failServer" $ serve failApi (
        (\ _request respond -> respond $ responseLBS ok200 [] "")
   :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")
   :<|> (\ _request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
@@ -149,7 +149,7 @@ manager :: C.Manager
 manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
 
 sucessSpec :: Spec
-sucessSpec = around (withTestServer server "server") $ do
+sucessSpec = around (withTestServer server) $ do
 
     it "Servant.API.Get" $ \baseUrl -> do
       let getGet = getNth (Proxy :: Proxy 0) $ client api baseUrl manager
@@ -234,15 +234,15 @@ type ErrorApi =
 errorApi :: Proxy ErrorApi
 errorApi = Proxy
 
-errorServer :: Application
-errorServer = serve errorApi $
+errorServer :: TestServer
+errorServer = TestServer "errorServer" $ serve errorApi $
   err :<|> err :<|> err :<|> err
   where
     err = throwE $ ServantErr 500 "error message" "" []
 
 errorSpec :: Spec
 errorSpec =
-  around (withTestServer errorServer "errorServer") $ do
+  around (withTestServer errorServer) $ do
     describe "error status codes" $
       it "reports error statuses correctly" $ \baseUrl -> do
         let delete :<|> get :<|> post :<|> put =
@@ -253,7 +253,7 @@ errorSpec =
           responseStatus `shouldBe` Status 500 "error message"
 
 failSpec :: Spec
-failSpec = around (withTestServer failServer "failServer") $ do
+failSpec = around (withTestServer failServer) $ do
 
     context "client returns errors appropriately" $ do
       it "reports FailureResponse" $ \baseUrl -> do

servant-client/test/ghcjs/testServer.hs

@@ -6,6 +6,7 @@ import           Servant
 import           System.IO
 
 import           Servant.Client.TestServer.GHC
+import           Servant.Client.TestServer.Types
 import           Servant.ClientSpec
 
 main :: IO ()
@@ -16,7 +17,10 @@ main = do
         setBeforeMainLoop (print port >> hFlush stdout) $
         defaultSettings
   runSettingsSocket settings socket $
-    serve testServerApi (server :<|> errorServer :<|> failServer)
+    serve testServerApi $
+      testServerApp server :<|>
+      testServerApp errorServer :<|>
+      testServerApp failServer
 
 type TestServerApi =
   "server" :> Raw :<|>