From 82887d7d3bd23de04fb521e92fd7c11274880f6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Mon, 4 Jan 2016 17:59:28 +0100 Subject: [PATCH] servant-client: add TestServer --- servant-client/servant-client.cabal | 2 +- .../test/Servant/Client/TestServer.hs | 3 +++ .../test/Servant/Client/TestServer/GHC.hs | 5 +++-- .../test/Servant/Client/TestServer/GHCJS.hs | 6 +++--- servant-client/test/Servant/ClientSpec.hs | 20 +++++++++---------- servant-client/test/ghcjs/testServer.hs | 6 +++++- 6 files changed, 25 insertions(+), 17 deletions(-) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 15bed2c0..1b5cb9f3 100644 --- a/servant-client/servant-client.cabal +++ b/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 diff --git a/servant-client/test/Servant/Client/TestServer.hs b/servant-client/test/Servant/Client/TestServer.hs index e6aae5e0..92747f75 100644 --- a/servant-client/test/Servant/Client/TestServer.hs +++ b/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 diff --git a/servant-client/test/Servant/Client/TestServer/GHC.hs b/servant-client/test/Servant/Client/TestServer/GHC.hs index 0a4dce20..d5da8465 100644 --- a/servant-client/test/Servant/Client/TestServer/GHC.hs +++ b/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 diff --git a/servant-client/test/Servant/Client/TestServer/GHCJS.hs b/servant-client/test/Servant/Client/TestServer/GHCJS.hs index 7deae806..d0d707df 100644 --- a/servant-client/test/Servant/Client/TestServer/GHCJS.hs +++ b/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) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index c6e363aa..c48a748a 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/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 diff --git a/servant-client/test/ghcjs/testServer.hs b/servant-client/test/ghcjs/testServer.hs index 8510272c..48996e8f 100644 --- a/servant-client/test/ghcjs/testServer.hs +++ b/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 :<|>