From 243439984581eb5bae398b6f8d3210201fea06f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Wed, 6 Apr 2016 16:58:44 +0800 Subject: [PATCH] wip --- servant-client/servant-client.cabal | 2 ++ servant-client/src/Servant/Common/Req.hs | 3 --- .../test/Servant/Client/TestServer/GHCJS.hs | 2 +- servant-client/test/Servant/ClientSpec.hs | 25 ++++++++++++------- servant-client/test/ghcjs/package.yaml | 1 + servant-client/test/ghcjs/stack-ghc.yaml | 5 +--- servant-client/test/ghcjs/testServer.cabal | 3 ++- servant-client/test/ghcjs/testServer.hs | 5 ++-- 8 files changed, 26 insertions(+), 20 deletions(-) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index d5aa1a4b..820886c9 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -80,6 +80,8 @@ test-suite spec Servant.ClientSpec , Servant.Client.PerformRequest.GHCJSSpec , Servant.Client.TestServer + , Servant.Client.TestServer.Types + , Servant.Common.BaseUrl , Servant.Common.BaseUrlSpec , Spec if impl(ghcjs) diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index e756075e..87795831 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -18,7 +18,6 @@ import Data.String.Conversions import Data.Proxy import Data.Text (Text) import Data.Text.Encoding -import Data.Typeable import Network.HTTP.Client hiding (Proxy, path) import Network.HTTP.Media import Network.HTTP.Types @@ -31,8 +30,6 @@ import Web.HttpApiData import qualified Network.HTTP.Client as Client -import Web.HttpApiData - data Req = Req { reqPath :: String , qs :: QueryText diff --git a/servant-client/test/Servant/Client/TestServer/GHCJS.hs b/servant-client/test/Servant/Client/TestServer/GHCJS.hs index a303e0de..268bfb9e 100644 --- a/servant-client/test/Servant/Client/TestServer/GHCJS.hs +++ b/servant-client/test/Servant/Client/TestServer/GHCJS.hs @@ -27,7 +27,7 @@ withServer (TestServer testServerName _) action = do } line <- hGetLine stdout case readMay line :: Maybe Int of - Nothing -> error ("unparseable port: " ++ show line) + Nothing -> die ("unparseable port: " ++ show line) Just port -> return (port, process) stop (_, process) = do terminateProcess process diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 3999be3c..6a0ac69f 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -34,8 +34,9 @@ import GHC.Generics (Generic) import qualified Network.HTTP.Client as C import Network.HTTP.Media import qualified Network.HTTP.Types as HTTP -import Network.Wai (Application, responseLBS) +import Network.Wai (responseLBS) import qualified Network.Wai as Wai +import System.Exit import System.IO.Unsafe (unsafePerformIO) import Test.HUnit import Test.Hspec @@ -77,12 +78,14 @@ spec = describe "Servant.Client" $ do -- This rather cumbersome approach is taken because it's not easy to run a wai -- Application as a http server when using ghcjs. withTestServer :: String -> (BaseUrl -> IO a) -> IO a -withTestServer = withServer . lookupTestServer +withTestServer name action = do + server <- lookupTestServer name + withServer server action -lookupTestServer :: String -> TestServer +lookupTestServer :: String -> IO TestServer lookupTestServer name = case lookup name mapping of - Nothing -> error ("test server not found: " ++ name) - Just testServer -> testServer + Nothing -> die ("test server not found: " ++ name) + Just testServer -> return testServer where mapping :: [(String, TestServer)] mapping = map (\ server -> (testServerName server, server)) allTestServers @@ -93,6 +96,8 @@ allTestServers = server : errorServer : failServer : + basicAuthServer : + genAuthServer : [] -- * test data types @@ -227,8 +232,9 @@ basicAuthHandler = basicServerContext :: Context '[ BasicAuthCheck () ] basicServerContext = basicAuthHandler :. EmptyContext -basicAuthServer :: Application -basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice)) +basicAuthServer :: TestServer +basicAuthServer = TestServer "basicAuthServer" $ + serveWithContext basicAuthAPI basicServerContext (const (return alice)) -- * general auth stuff @@ -251,8 +257,9 @@ genAuthHandler = genAuthServerContext :: Context '[ AuthHandler Wai.Request () ] genAuthServerContext = genAuthHandler :. EmptyContext -genAuthServer :: Application -genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice)) +genAuthServer :: TestServer +genAuthServer = TestServer "genAuthServer" $ + serveWithContext genAuthAPI genAuthServerContext (const (return alice)) {-# NOINLINE manager #-} manager :: C.Manager diff --git a/servant-client/test/ghcjs/package.yaml b/servant-client/test/ghcjs/package.yaml index 35a8cc92..9cc2b411 100644 --- a/servant-client/test/ghcjs/package.yaml +++ b/servant-client/test/ghcjs/package.yaml @@ -20,6 +20,7 @@ executables: - wai - transformers - network + - bytestring source-dirs: - ./ - ../ diff --git a/servant-client/test/ghcjs/stack-ghc.yaml b/servant-client/test/ghcjs/stack-ghc.yaml index e49df0d3..20d02166 100644 --- a/servant-client/test/ghcjs/stack-ghc.yaml +++ b/servant-client/test/ghcjs/stack-ghc.yaml @@ -9,7 +9,4 @@ packages: - servant-server extra-dep: true -resolver: nightly-2015-10-08 - -extra-deps: - - http-api-data-0.1.1.1 +resolver: nightly-2016-04-01 diff --git a/servant-client/test/ghcjs/testServer.cabal b/servant-client/test/ghcjs/testServer.cabal index 1f2b5af2..3b7d0524 100644 --- a/servant-client/test/ghcjs/testServer.cabal +++ b/servant-client/test/ghcjs/testServer.cabal @@ -1,4 +1,4 @@ --- This file has been generated from package.yaml by hpack version 0.8.0. +-- This file has been generated from package.yaml by hpack version 0.10.0. -- -- see: https://github.com/sol/hpack @@ -29,6 +29,7 @@ executable testServer , wai , transformers , network + , bytestring other-modules: Servant.Client.PerformRequest.GHCJSSpec Servant.Client.TestServer diff --git a/servant-client/test/ghcjs/testServer.hs b/servant-client/test/ghcjs/testServer.hs index c5fbe5f1..29118094 100644 --- a/servant-client/test/ghcjs/testServer.hs +++ b/servant-client/test/ghcjs/testServer.hs @@ -17,8 +17,9 @@ main = do setBeforeMainLoop (print port >> hFlush stdout) $ defaultSettings runSettingsSocket settings socket $ - serve testServerApi $ \ testServerName -> - testServerApp $ lookupTestServer testServerName + serve testServerApi $ \ testServerName request respond -> do + app <- testServerApp <$> lookupTestServer testServerName + app request respond type TestServerApi = Capture "testServerName" String :> Raw