servant-client: support for ghcjs

.gitignore

@@ -29,3 +29,5 @@ doc/_build
 doc/venv
 doc/tutorial/static/api.js
 doc/tutorial/static/jq.js
+servant-client/node_modules/
+servant-client/test/ghcjs/testServer/testServer

servant-client/servant-client.cabal

@@ -31,12 +31,22 @@ library
     Servant.Common.BaseUrl
     Servant.Common.BasicAuth
     Servant.Common.Req
+  other-modules:
+    Servant.Client.PerformRequest
+    Servant.Client.PerformRequest.Base
+  if impl(ghcjs)
+    other-modules:
+      Servant.Client.PerformRequest.GHCJS
+  else
+    other-modules:
+      Servant.Client.PerformRequest.GHC
   build-depends:
       base >=4.7 && <5
     , aeson
     , attoparsec
     , base64-bytestring
     , bytestring
+    , case-insensitive
     , exceptions
     , http-api-data >= 0.1  && < 0.3
     , http-client
@@ -50,6 +60,10 @@ library
     , text
     , transformers
     , transformers-compat
+  if impl(ghcjs)
+    build-depends:
+        ghcjs-base
+      , ghcjs-prim
   hs-source-dirs: src
   default-language: Haskell2010
   ghc-options: -Wall
@@ -60,19 +74,31 @@ test-suite spec
   ghc-options:
     -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
   default-language: Haskell2010
-  hs-source-dirs: test
+  hs-source-dirs: test, src
   main-is: Spec.hs
   other-modules:
       Servant.ClientSpec
+    , Servant.Client.PerformRequest.GHCJSSpec
+    , Servant.Client.TestServer
+    , Servant.Client.TestServer.Types
+    , Servant.Common.BaseUrl
     , Servant.Common.BaseUrlSpec
+    , Spec
+  if impl(ghcjs)
+    other-modules:
+      Servant.Client.TestServer.GHCJS
+  else
+    other-modules:
+      Servant.Client.TestServer.GHC
   build-depends:
       base == 4.*
     , transformers
     , transformers-compat
     , aeson
+    , base64-bytestring
     , bytestring
     , deepseq
-    , hspec == 2.*
+    , hspec >= 2.2.1 && < 2.3
     , http-client
     , http-media
     , http-types
@@ -80,8 +106,20 @@ test-suite spec
     , network >= 2.6
     , QuickCheck >= 2.7
     , servant == 0.6.*
-    , servant-client
     , servant-server == 0.6.*
     , text
     , wai
     , warp
+    , mockery
+    , safe
+    , process
+    , http-api-data
+    , network-uri
+    , exceptions
+    , string-conversions
+  if impl(ghcjs)
+    build-depends:
+        ghcjs-base
+      , ghcjs-prim
+      , case-insensitive
+  include-dirs: include

servant-client/src/Servant/Client.hs

@@ -42,6 +42,7 @@ import           Servant.Client.Experimental.Auth
 import           Servant.Common.BaseUrl
 import           Servant.Common.BasicAuth
 import           Servant.Common.Req
+import           Servant.Client.PerformRequest (ServantError(..))
 
 -- * Accessing APIs as a Client
 

servant-client/src/Servant/Client/PerformRequest.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE CPP #-}
+
+module Servant.Client.PerformRequest (
+  ServantError(..),
+  performHttpRequest,
+) where
+
+import           Servant.Client.PerformRequest.Base
+#ifdef __GHCJS__
+import           Servant.Client.PerformRequest.GHCJS
+#else
+import           Servant.Client.PerformRequest.GHC
+#endif

servant-client/src/Servant/Client/PerformRequest/Base.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Servant.Client.PerformRequest.Base where
+
+import           Control.Exception
+import           Data.ByteString.Lazy
+import           Data.Typeable
+import           Network.HTTP.Media
+import           Network.HTTP.Types
+
+data ServantError
+  = FailureResponse
+    { responseStatus            :: Status
+    , responseContentType       :: MediaType
+    , responseBody              :: ByteString
+    }
+  | DecodeFailure
+    { decodeError               :: String
+    , responseContentType       :: MediaType
+    , responseBody              :: ByteString
+    }
+  | UnsupportedContentType
+    { responseContentType       :: MediaType
+    , responseBody              :: ByteString
+    }
+  | InvalidContentTypeHeader
+    { responseContentTypeHeader :: ByteString
+    , responseBody              :: ByteString
+    }
+  | ConnectionError
+    { connectionError           :: SomeException
+    }
+  deriving (Show, Typeable)
+
+instance Exception ServantError

servant-client/src/Servant/Client/PerformRequest/GHC.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Servant.Client.PerformRequest.GHC (
+  ServantError(..),
+  performHttpRequest,
+  ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import           Control.Applicative
+#endif
+import           Control.Exception
+import qualified Data.ByteString.Lazy as LBS
+import           Network.HTTP.Client
+
+import           Servant.Client.PerformRequest.Base
+
+performHttpRequest :: Manager -> Request
+  -> IO (Either ServantError (Response LBS.ByteString))
+performHttpRequest manager request =
+  catchConnectionError $ httpLbs request manager
+
+catchConnectionError :: IO a -> IO (Either ServantError a)
+catchConnectionError action =
+  catch (Right <$> action) $ \e ->
+    pure . Left . ConnectionError $ SomeException (e :: HttpException)

servant-client/src/Servant/Client/PerformRequest/GHCJS.hs

@@ -0,0 +1,178 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Servant.Client.PerformRequest.GHCJS (
+  ServantError(..),
+  performHttpRequest,
+
+  -- exported for testing
+  parseHeaders,
+  ) where
+
+import           Control.Arrow
+import           Control.Concurrent
+import           Control.Exception
+import           Control.Monad
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy as LBS
+import           Data.CaseInsensitive
+import           Data.Char
+import           Data.String.Conversions
+import           GHCJS.Foreign.Callback
+import           GHCJS.Prim
+import           Network.HTTP.Client
+import           Network.HTTP.Client.Internal as HttpClient
+import           Network.HTTP.Types
+
+import           Servant.Client.PerformRequest.Base
+
+newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
+
+newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
+
+performHttpRequest :: Manager -> Request -> IO (Either ServantError (Response LBS.ByteString))
+performHttpRequest _ request = do
+  xhr <- initXhr
+  performXhr xhr request
+  toResponse xhr
+
+-- * initialization
+
+initXhr :: IO JSXMLHttpRequest
+initXhr = do
+  lib <- requireXMLHttpRequestClass
+  newXMLHttpRequest lib
+
+foreign import javascript unsafe
+  -- branching between node (for testing) and browsers
+  "(function () {if (typeof require !== 'undefined') { return require('xhr2'); } else { return XMLHttpRequest; };})()"
+  requireXMLHttpRequestClass :: IO JSXMLHttpRequestClass
+
+foreign import javascript unsafe "new $1()"
+  newXMLHttpRequest :: JSXMLHttpRequestClass -> IO JSXMLHttpRequest
+
+-- * performing requests
+
+-- Performs the xhr and blocks until the response was received
+performXhr :: JSXMLHttpRequest -> Request -> IO ()
+performXhr xhr request = do
+  waiter <- newEmptyMVar
+  callback <- onReadyStateChange xhr $ do
+    state <- readyState xhr
+    case state of
+      4 -> putMVar waiter ()
+      _ -> return ()
+  openXhr xhr (cs $ method request) (toUrl request) True
+  setHeaders xhr (requestHeaders request)
+  sendXhr xhr (toBody request)
+  takeMVar waiter
+  releaseCallback callback
+
+onReadyStateChange :: JSXMLHttpRequest -> IO () -> IO (Callback (IO ()))
+onReadyStateChange xhr action = do
+  callback <- asyncCallback action
+  js_onReadyStateChange xhr callback
+  return callback
+foreign import javascript safe "$1.onreadystatechange = $2;"
+  js_onReadyStateChange :: JSXMLHttpRequest -> Callback (IO ()) -> IO ()
+
+foreign import javascript unsafe "$1.readyState"
+  readyState :: JSXMLHttpRequest -> IO Int
+
+openXhr :: JSXMLHttpRequest -> String -> String -> Bool -> IO ()
+openXhr xhr method url async =
+  js_openXhr xhr (toJSString method) (toJSString url) async
+foreign import javascript unsafe "$1.open($2, $3, $4)"
+  js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
+
+toUrl :: Request -> String
+toUrl request =
+  let protocol = if secure request then "https" else "http"
+      hostS = cs $ host request
+      portS = show $ port request
+      pathS = cs $ path request
+      queryS = cs $ queryString request
+  in protocol ++ "://" ++ hostS ++ ":" ++ portS ++ pathS ++ queryS
+
+setHeaders :: JSXMLHttpRequest -> RequestHeaders -> IO ()
+setHeaders xhr headers = forM_ headers $ \ (key, value) ->
+  js_setRequestHeader xhr (toJSString $ cs $ original key) (toJSString $ cs value)
+foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
+  js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
+
+sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()
+sendXhr xhr Nothing = js_sendXhr xhr
+sendXhr xhr (Just body) =
+  js_sendXhrWithBody xhr (toJSString body)
+foreign import javascript unsafe "$1.send()"
+  js_sendXhr :: JSXMLHttpRequest -> IO ()
+foreign import javascript unsafe "$1.send($2)"
+  js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
+
+toBody :: Request -> Maybe String
+toBody request = case requestBody request of
+  RequestBodyLBS "" -> Nothing
+  RequestBodyLBS x -> Just $ cs x
+  _ -> error "servant-client only uses RequestBodyLBS"
+
+-- * inspecting the xhr response
+
+-- This function is only supposed to handle 'ConnectionError's. Other
+-- 'ServantError's are created in Servant.Client.Req.
+toResponse :: JSXMLHttpRequest -> IO (Either ServantError (Response LBS.ByteString))
+toResponse xhr = do
+  status <- getStatus xhr
+  case status of
+    0 -> return $ Left $ ConnectionError $ SomeException $ ErrorCall "connection error"
+    _ -> do
+      statusText <- cs <$> getStatusText xhr
+      headers <- parseHeaders <$> getAllResponseHeaders xhr
+      responseText <- cs <$> getResponseText xhr
+      return $ Right $ Response {
+        HttpClient.responseStatus = mkStatus status statusText,
+        responseVersion = http11, -- this is made up
+        responseHeaders = headers,
+        HttpClient.responseBody = responseText,
+        responseCookieJar = mempty,
+        responseClose' = ResponseClose (return ())
+      }
+
+foreign import javascript unsafe "$1.status"
+  getStatus :: JSXMLHttpRequest -> IO Int
+
+getStatusText :: JSXMLHttpRequest -> IO String
+getStatusText = fmap fromJSString . js_statusText
+foreign import javascript unsafe "$1.statusText"
+  js_statusText :: JSXMLHttpRequest -> IO JSVal
+
+getAllResponseHeaders :: JSXMLHttpRequest -> IO String
+getAllResponseHeaders xhr =
+  fromJSString <$> js_getAllResponseHeaders xhr
+foreign import javascript unsafe "$1.getAllResponseHeaders()"
+  js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
+
+getResponseText :: JSXMLHttpRequest -> IO String
+getResponseText xhr = fromJSString <$> js_responseText xhr
+foreign import javascript unsafe "$1.responseText"
+  js_responseText :: JSXMLHttpRequest -> IO JSVal
+
+parseHeaders :: String -> ResponseHeaders
+parseHeaders s =
+  fmap (first mk) $
+  fmap (first strip . second strip) $
+  fmap parseHeader $
+  splitOn "\r\n" (cs s)
+  where
+    parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)
+    parseHeader h = case BS.breakSubstring ":" (cs h) of
+      (key, (BS.drop 1 -> value)) -> (key, value)
+
+    splitOn :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
+    splitOn separator input = case BS.breakSubstring separator input of
+      (prefix, "") -> [prefix]
+      (prefix, rest) -> prefix : splitOn separator (BS.drop (BS.length separator) rest)
+
+    strip :: BS.ByteString -> BS.ByteString
+    strip = BS.dropWhile isSpace . BS.reverse . BS.dropWhile isSpace . BS.reverse

servant-client/src/Servant/Common/Req.hs

@@ -18,44 +18,17 @@ 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
 import qualified Network.HTTP.Types.Header as HTTP
 import Network.URI hiding (path)
 import Servant.API.ContentTypes
+import Servant.Client.PerformRequest
 import Servant.Common.BaseUrl
-
-import qualified Network.HTTP.Client as Client
-
 import Web.HttpApiData
 
-data ServantError
+import qualified Network.HTTP.Client as Client
-  = FailureResponse
-    { responseStatus            :: Status
-    , responseContentType       :: MediaType
-    , responseBody              :: ByteString
-    }
-  | DecodeFailure
-    { decodeError               :: String
-    , responseContentType       :: MediaType
-    , responseBody              :: ByteString
-    }
-  | UnsupportedContentType
-    { responseContentType       :: MediaType
-    , responseBody              :: ByteString
-    }
-  | InvalidContentTypeHeader
-    { responseContentTypeHeader :: ByteString
-    , responseBody              :: ByteString
-    }
-  | ConnectionError
-    { connectionError           :: SomeException
-    }
-  deriving (Show, Typeable)
-
-instance Exception ServantError
 
 data Req = Req
   { reqPath   :: String
@@ -135,7 +108,7 @@ performRequest reqMethod req manager reqHost = do
                                , checkStatus = \ _status _headers _cookies -> Nothing
                                }
 
-  eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
+  eResponse <- liftIO $ performHttpRequest manager request
   case eResponse of
     Left err ->
       throwE . ConnectionError $ SomeException err
@@ -172,8 +145,3 @@ performRequestNoBody :: Method -> Req -> Manager -> BaseUrl
 performRequestNoBody reqMethod req manager reqHost = do
   (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost
   return hdrs
-
-catchConnectionError :: IO a -> IO (Either ServantError a)
-catchConnectionError action =
-  catch (Right <$> action) $ \e ->
-    pure . Left . ConnectionError $ SomeException (e :: HttpException)

servant-client/test/Servant/Client/PerformRequest/GHCJSSpec.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Servant.Client.PerformRequest.GHCJSSpec where
+
+import           Test.Hspec
+
+#ifdef __GHCJS__
+
+import           Servant.Client.PerformRequest.GHCJS
+
+spec :: Spec
+spec = do
+  describe "parseHeaders" $ do
+    it "parses single headers" $ do
+      parseHeaders "key: value" `shouldBe` [("key", "value")]
+
+    it "parses multiple headers" $ do
+      parseHeaders "foo: bar\r\nnext: yay" `shouldBe`
+        [("foo", "bar"), ("next", "yay")]
+
+    it "handles colons in header values correctly" $ do
+      parseHeaders "foo: bar:baz" `shouldBe` [("foo", "bar:baz")]
+
+#else
+
+spec :: Spec
+spec = return ()
+#endif

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

@@ -0,0 +1,15 @@
+{-# LANGUAGE CPP                    #-}
+
+module Servant.Client.TestServer (
+  buildTestServer,
+  TestServer(..),
+  withServer,
+) where
+
+#ifdef __GHCJS__
+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

@@ -0,0 +1,39 @@
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Servant.Client.TestServer.GHC where
+
+import           Control.Concurrent
+import           Control.Exception
+import           Network.Socket
+import           Network.Wai
+import           Network.Wai.Handler.Warp
+
+import           Servant.Common.BaseUrl
+import           Servant.Client.TestServer.Types
+
+buildTestServer :: IO ()
+buildTestServer = return ()
+
+withServer :: TestServer -> (BaseUrl -> IO a) -> IO a
+withServer (TestServer _ app) action =
+  bracket (startWaiApp app) endWaiApp $ \ (_, url) ->
+    action url
+
+startWaiApp :: Application -> IO (ThreadId, BaseUrl)
+startWaiApp app = do
+    (port, socket) <- openTestSocket
+    let settings = setPort port $ defaultSettings
+    thread <- forkIO $ runSettingsSocket settings socket app
+    return (thread, BaseUrl Http "localhost" port "")
+
+endWaiApp :: (ThreadId, BaseUrl) -> IO ()
+endWaiApp (thread, _) = killThread thread
+
+openTestSocket :: IO (Port, Socket)
+openTestSocket = do
+  s <- socket AF_INET Stream defaultProtocol
+  localhost <- inet_addr "127.0.0.1"
+  bind s (SockAddrInet aNY_PORT localhost)
+  listen s 1
+  port <- socketPort s
+  return (fromIntegral port, s)

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

@@ -0,0 +1,34 @@
+
+module Servant.Client.TestServer.GHCJS where
+
+import           Control.Exception
+import           Safe
+import           System.Exit
+import           System.IO
+import           System.Process
+
+import           Servant.Client.TestServer.Types
+import           Servant.Common.BaseUrl
+
+buildTestServer :: IO ()
+buildTestServer = do
+  process <- spawnProcess "./test/ghcjs/build-test-server.sh" []
+  ExitSuccess <- waitForProcess process
+  return ()
+
+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)
+    start = do
+      (Nothing, Just stdout, Nothing, process) <- createProcess $ (proc "./test/ghcjs/testServer/testServer" []) {
+        std_out = CreatePipe
+      }
+      line <- hGetLine stdout
+      case readMay line :: Maybe Int of
+        Nothing -> die ("unparseable port: " ++ show line)
+        Just port -> return (port, process)
+    stop (_, process) = do
+      terminateProcess process
+      waitForProcess process

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

@@ -0,0 +1,10 @@
+
+module Servant.Client.TestServer.Types where
+
+import           Network.Wai
+
+data TestServer
+  = TestServer {
+    testServerName :: String,
+    testServerApp :: Application
+  }

servant-client/test/Servant/ClientSpec.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE CPP                    #-}
-{-# LANGUAGE ConstraintKinds        #-}
 {-# LANGUAGE DataKinds              #-}
 {-# LANGUAGE DeriveGeneric          #-}
 {-# LANGUAGE FlexibleContexts       #-}
@@ -11,24 +10,19 @@
 {-# LANGUAGE PolyKinds              #-}
 {-# LANGUAGE RecordWildCards        #-}
 {-# LANGUAGE StandaloneDeriving     #-}
-{-# LANGUAGE ScopedTypeVariables    #-}
 {-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE TypeOperators          #-}
 {-# LANGUAGE UndecidableInstances   #-}
 {-# OPTIONS_GHC -fcontext-stack=100 #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
-#include "overlapping-compat.h"
 module Servant.ClientSpec where
 
 #if !MIN_VERSION_base(4,8,0)
 import           Control.Applicative        ((<$>))
 #endif
 import           Control.Arrow              (left)
-import           Control.Concurrent         (forkIO, killThread, ThreadId)
+import           Control.Monad.Trans.Except (runExceptT, throwE)
-import           Control.Exception          (bracket)
-import           Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)
 import           Data.Aeson
 import qualified Data.ByteString.Lazy       as BS
 import           Data.Char                  (chr, isPrint)
@@ -40,33 +34,73 @@ import           GHC.Generics               (Generic)
 import qualified Network.HTTP.Client        as C
 import           Network.HTTP.Media
 import qualified Network.HTTP.Types as HTTP
-import           Network.Socket
+import           Network.Wai                (responseLBS)
-import           Network.Wai                (Application, Request,
+import qualified Network.Wai as Wai
-                                             requestHeaders, responseLBS)
+import           System.Exit
-import           Network.Wai.Handler.Warp
 import           System.IO.Unsafe           (unsafePerformIO)
+import           Test.HUnit
 import           Test.Hspec
 import           Test.Hspec.QuickCheck
-import           Test.HUnit
 import           Test.QuickCheck
 
 import           Servant.API
-import           Servant.API.Internal.Test.ComprehensiveAPI
 import           Servant.Client
+import           Servant.Client.TestServer
+import qualified Servant.Common.Req as SCR
 import           Servant.Server
 import           Servant.Server.Experimental.Auth
-import qualified Servant.Common.Req         as SCR
-
--- This declaration simply checks that all instances are in place.
-_ = client comprehensiveAPI
 
 spec :: Spec
-spec = describe "Servant.Client" $ do
+spec = do
+  runIO buildTestServer
+  describe "Servant.Client" $ do
     sucessSpec
     failSpec
-    wrappedApiSpec
     basicAuthSpec
     genAuthSpec
+    errorSpec
+
+-- | Run a test-server (identified by name) while performing the given action.
+-- The provided 'BaseUrl' points to the running server.
+--
+-- Running the test-servers is done differently depending on the compiler
+-- (ghc or ghcjs).
+--
+-- With ghc it's somewhat straight-forward: a wai 'Application' is being started
+-- on a free port inside the same process using 'warp'.
+--
+-- When running the test-suite with ghcjs all the test-servers are compiled into
+-- a single external executable (with ghc and warp). This is done through
+-- 'buildTestServer' once at the start of the test-suite. This built executable
+-- will provide all the test-servers on a free port under a path that
+-- corresponds to the test-servers name, for example under
+-- 'http://localhost:82923/failServer'. 'withTestServer' will then
+-- start this executable as an external process while the given action is being
+-- executed and provide it with the correct BaseUrl.
+-- 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 name action = do
+  server <- lookupTestServer name
+  withServer server action
+
+lookupTestServer :: String -> IO TestServer
+lookupTestServer name = case lookup name mapping of
+  Nothing -> die ("test server not found: " ++ name)
+  Just testServer -> return testServer
+  where
+    mapping :: [(String, TestServer)]
+    mapping = map (\ server -> (testServerName server, server)) allTestServers
+
+-- | All test-servers must be registered here.
+allTestServers :: [TestServer]
+allTestServers =
+  server :
+  errorServer :
+  failServer :
+  basicAuthServer :
+  genAuthServer :
+  []
 
 -- * test data types
 
@@ -147,8 +181,8 @@ getGet
   :<|> getRespHeaders
   :<|> getDeleteContentType = client api
 
-server :: Application
+server :: TestServer
-server = serve api (
+server = TestServer "server" $ serve api (
        return alice
   :<|> return NoContent
   :<|> (\ name -> return $ Person name 0)
@@ -166,16 +200,16 @@ server = serve api (
   :<|> return NoContent
  )
 
-
 type FailApi =
        "get" :> Raw
   :<|> "capture" :> Capture "name" String :> Raw
   :<|> "body" :> Raw
+
 failApi :: Proxy FailApi
 failApi = Proxy
 
-failServer :: Application
+failServer :: TestServer
-failServer = serve failApi (
+failServer = TestServer "failServer" $ serve failApi (
        (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
   :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
   :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
@@ -200,8 +234,9 @@ basicAuthHandler =
 basicServerContext :: Context '[ BasicAuthCheck () ]
 basicServerContext = basicAuthHandler :. EmptyContext
 
-basicAuthServer :: Application
+basicAuthServer :: TestServer
-basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
+basicAuthServer = TestServer "basicAuthServer" $
+  serveWithContext basicAuthAPI basicServerContext (const (return alice))
 
 -- * general auth stuff
 
@@ -214,58 +249,59 @@ genAuthAPI = Proxy
 type instance AuthServerData (AuthProtect "auth-tag") = ()
 type instance AuthClientData (AuthProtect "auth-tag") = ()
 
-genAuthHandler :: AuthHandler Request ()
+genAuthHandler :: AuthHandler Wai.Request ()
 genAuthHandler =
-  let handler req = case lookup "AuthHeader" (requestHeaders req) of
+  let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
         Nothing -> throwE (err401 { errBody = "Missing auth header" })
         Just _ -> return ()
   in mkAuthHandler handler
 
-genAuthServerContext :: Context '[ AuthHandler Request () ]
+genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
 genAuthServerContext = genAuthHandler :. EmptyContext
 
-genAuthServer :: Application
+genAuthServer :: TestServer
-genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
+genAuthServer = TestServer "genAuthServer" $
+  serveWithContext genAuthAPI genAuthServerContext (const (return alice))
 
 {-# NOINLINE manager #-}
 manager :: C.Manager
 manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
 
 sucessSpec :: Spec
-sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
+sucessSpec = around (withTestServer "server") $ do
 
-    it "Servant.API.Get" $ \(_, baseUrl) -> do
+    it "Servant.API.Get" $ \baseUrl -> do
       (left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice
 
     describe "Servant.API.Delete" $ do
-      it "allows empty content type" $ \(_, baseUrl) -> do
+      it "allows empty content type" $ \baseUrl -> do
         (left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent
 
-      it "allows content type" $ \(_, baseUrl) -> do
+      it "allows content type" $ \baseUrl -> do
         (left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent
 
-    it "Servant.API.Capture" $ \(_, baseUrl) -> do
+    it "Servant.API.Capture" $ \baseUrl -> do
       (left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0)
 
-    it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
+    it "Servant.API.ReqBody" $ \baseUrl -> do
       let p = Person "Clara" 42
       (left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p
 
-    it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
+    it "Servant.API.QueryParam" $ \baseUrl -> do
       left show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice
       Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl)
       responseStatus `shouldBe` HTTP.Status 400 "bob not found"
 
-    it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
+    it "Servant.API.QueryParam.QueryParams" $ \baseUrl -> do
       (left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right []
       (left show <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl))
         `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
 
     context "Servant.API.QueryParam.QueryFlag" $
-      forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
+      forM_ [False, True] $ \ flag -> it (show flag) $ \baseUrl -> do
         (left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag
 
-    it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
+    it "Servant.API.Raw on success" $ \baseUrl -> do
       res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl)
       case res of
         Left e -> assertFailure $ show e
@@ -274,7 +310,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
           C.responseBody response `shouldBe` body
           C.responseStatus response `shouldBe` HTTP.ok200
 
-    it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
+    it "Servant.API.Raw should return a Left in case of failure" $ \baseUrl -> do
       res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl)
       case res of
         Right _ -> assertFailure "expected Left, but got Right"
@@ -282,51 +318,93 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
           Servant.Client.responseStatus e `shouldBe` HTTP.status400
           Servant.Client.responseBody e `shouldBe` "rawFailure"
 
-    it "Returns headers appropriately" $ \(_, baseUrl) -> do
+    it "Returns headers appropriately" $ \baseUrl -> do
       res <- runExceptT (getRespHeaders manager baseUrl)
       case res of
         Left e -> assertFailure $ show e
         Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
 
     modifyMaxSuccess (const 20) $ do
-      it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
+      it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \baseUrl ->
         property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
           ioProperty $ do
             result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl)
             return $
               result === Right (cap, num, flag, body)
 
+type ErrorApi =
+  Delete '[JSON] () :<|>
+  Get '[JSON] () :<|>
+  Post '[JSON] () :<|>
+  Put '[JSON] ()
 
-wrappedApiSpec :: Spec
+errorApi :: Proxy ErrorApi
-wrappedApiSpec = describe "error status codes" $ do
+errorApi = Proxy
-  let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
+
-  context "are correctly handled by the client" $
+errorServer :: TestServer
-    let test :: (WrappedApi, String) -> Spec
+errorServer = TestServer "errorServer" $ serve errorApi $
-        test (WrappedApi api, desc) =
+  err :<|> err :<|> err :<|> err
-          it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
+  where
-            let getResponse :: C.Manager -> BaseUrl -> SCR.ClientM ()
+    err = throwE $ ServantErr 500 "error message" "" []
-                getResponse = client api
+
-            Left FailureResponse{..} <- runExceptT (getResponse manager baseUrl)
+errorSpec :: Spec
-            responseStatus `shouldBe` (HTTP.Status 500 "error message")
+errorSpec =
-    in mapM_ test $
+  around (withTestServer "errorServer") $ do
-        (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
+    describe "error status codes" $
-        (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
+      it "reports error statuses correctly" $ \baseUrl -> do
-        (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
+        let delete :<|> get :<|> post :<|> put =
-        (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
+              client errorApi
-        []
+            actions = map (\ f -> f manager baseUrl) [delete, get, post, put]
+        forM_ actions $ \ clientAction -> do
+          Left FailureResponse{..} <- runExceptT clientAction
+          responseStatus `shouldBe` HTTP.Status 500 "error message"
+
+basicAuthSpec :: Spec
+basicAuthSpec = around (withTestServer "basicAuthServer") $ do
+  context "Authentication works when requests are properly authenticated" $ do
+
+    it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
+      let getBasic = client basicAuthAPI
+      let basicAuthData = BasicAuthData "servant" "server"
+      (left show <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice
+
+  context "Authentication is rejected when requests are not authenticated properly" $ do
+
+    it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
+      let getBasic = client basicAuthAPI
+      let basicAuthData = BasicAuthData "not" "password"
+      Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl)
+      responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
+
+genAuthSpec :: Spec
+genAuthSpec = around (withTestServer "genAuthServer") $ do
+  context "Authentication works when requests are properly authenticated" $ do
+
+    it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
+      let getProtected = client genAuthAPI
+      let authRequest = mkAuthenticateReq () (\_ req ->  SCR.addHeader "AuthHeader" ("cool" :: String) req)
+      (left show <$> runExceptT (getProtected authRequest manager baseUrl)) `shouldReturn` Right alice
+
+  context "Authentication is rejected when requests are not authenticated properly" $ do
+
+    it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
+      let getProtected = client genAuthAPI
+      let authRequest = mkAuthenticateReq () (\_ req ->  SCR.addHeader "Wrong" ("header" :: String) req)
+      Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl)
+      responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
 
 failSpec :: Spec
-failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
+failSpec = around (withTestServer "failServer") $ do
 
     context "client returns errors appropriately" $ do
-      it "reports FailureResponse" $ \(_, baseUrl) -> do
+      it "reports FailureResponse" $ \baseUrl -> do
         let (_ :<|> getDeleteEmpty :<|> _) = client api
         Left res <- runExceptT (getDeleteEmpty manager baseUrl)
         case res of
           FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
           _ -> fail $ "expected 404 response, but got " <> show res
 
-      it "reports DecodeFailure" $ \(_, baseUrl) -> do
+      it "reports DecodeFailure" $ \baseUrl -> do
         let (_ :<|> _ :<|> getCapture :<|> _) = client api
         Left res <- runExceptT (getCapture "foo" manager baseUrl)
         case res of
@@ -340,81 +418,23 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
           ConnectionError _ -> return ()
           _ -> fail $ "expected ConnectionError, but got " <> show res
 
-      it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
+      it "reports UnsupportedContentType" $ \baseUrl -> do
         let (getGet :<|> _ ) = client api
         Left res <- runExceptT (getGet manager baseUrl)
         case res of
           UnsupportedContentType ("application/octet-stream") _ -> return ()
           _ -> fail $ "expected UnsupportedContentType, but got " <> show res
 
-      it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
+      it "reports InvalidContentTypeHeader" $ \baseUrl -> do
         let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
         Left res <- runExceptT (getBody alice manager baseUrl)
         case res of
           InvalidContentTypeHeader "fooooo" _ -> return ()
           _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
 
-data WrappedApi where
-  WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a,
-                 HasClient api, Client api ~ (C.Manager -> BaseUrl -> SCR.ClientM ())) =>
-    Proxy api -> WrappedApi
-
-basicAuthSpec :: Spec
-basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
-  context "Authentication works when requests are properly authenticated" $ do
-
-    it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
-      let getBasic = client basicAuthAPI
-      let basicAuthData = BasicAuthData "servant" "server"
-      (left show <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice
-
-  context "Authentication is rejected when requests are not authenticated properly" $ do
-
-    it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
-      let getBasic = client basicAuthAPI
-      let basicAuthData = BasicAuthData "not" "password"
-      Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl)
-      responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
-
-genAuthSpec :: Spec
-genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
-  context "Authentication works when requests are properly authenticated" $ do
-
-    it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
-      let getProtected = client genAuthAPI
-      let authRequest = mkAuthenticateReq () (\_ req ->  SCR.addHeader "AuthHeader" ("cool" :: String) req)
-      (left show <$> runExceptT (getProtected authRequest manager baseUrl)) `shouldReturn` Right alice
-
-  context "Authentication is rejected when requests are not authenticated properly" $ do
-
-    it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
-      let getProtected = client genAuthAPI
-      let authRequest = mkAuthenticateReq () (\_ req ->  SCR.addHeader "Wrong" ("header" :: String) req)
-      Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl)
-      responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
 
 -- * utils
 
-startWaiApp :: Application -> IO (ThreadId, BaseUrl)
-startWaiApp app = do
-    (port, socket) <- openTestSocket
-    let settings = setPort port $ defaultSettings
-    thread <- forkIO $ runSettingsSocket settings socket app
-    return (thread, BaseUrl Http "localhost" port "")
-
-
-endWaiApp :: (ThreadId, BaseUrl) -> IO ()
-endWaiApp (thread, _) = killThread thread
-
-openTestSocket :: IO (Port, Socket)
-openTestSocket = do
-  s <- socket AF_INET Stream defaultProtocol
-  localhost <- inet_addr "127.0.0.1"
-  bind s (SockAddrInet aNY_PORT localhost)
-  listen s 1
-  port <- socketPort s
-  return (fromIntegral port, s)
-
 pathGen :: Gen (NonEmptyList Char)
 pathGen = fmap NonEmpty path
  where

servant-client/test/ghcjs/build-test-server.sh

@@ -0,0 +1,10 @@
+#/usr/bin/env bash
+
+set -o errexit
+
+cd test/ghcjs/testServer
+
+unset STACK_YAML
+stack setup
+stack build
+cp $(stack exec which testServer) .

servant-client/test/ghcjs/run-tests.sh

@@ -0,0 +1,14 @@
+#!/usr/bin/env bash
+
+set -o errexit
+
+loc=$(dirname $0)
+cd $loc
+
+cd ../../
+
+npm install xhr2
+
+export STACK_YAML=test/ghcjs/stack-ghcjs.yaml
+stack setup
+stack test --fast

servant-client/test/ghcjs/stack-ghcjs.yaml

@@ -0,0 +1,25 @@
+# This file was added for being able to test ghcjs support
+
+packages:
+  - location: ../../.
+  - location: ../../../servant
+    extra-dep: true
+  - location: ../../../servant-server
+    extra-dep: true
+
+resolver: lts-5.11
+
+compiler: ghcjs-0.2.0.20160315_ghc-7.10.2
+compiler-check: match-exact
+setup-info:
+  ghcjs:
+    source:
+      ghcjs-0.2.0.20160315_ghc-7.10.2:
+        url: "https://github.com/nrolland/ghcjs/releases/download/v.0.2.0.20160315/ghcjs-0.2.0.20160315.tar.gz"
+
+extra-deps:
+  - hspec-expectations-0.7.2
+  - hspec-discover-2.2.1
+  - http-api-data-0.1.1.1
+  - hspec-2.2.1
+  - hspec-core-2.2.1

servant-client/test/ghcjs/testServer/package.yaml

@@ -0,0 +1,35 @@
+name: testServer
+
+executables:
+  testServer:
+    main: testServer.hs
+    other-modules: []
+    dependencies:
+      - base
+      - aeson
+      - base64-bytestring
+      - bytestring
+      - exceptions
+      - hspec
+      - http-api-data
+      - http-client
+      - http-media
+      - http-types
+      - HUnit
+      - network
+      - network-uri
+      - QuickCheck
+      - safe
+      - servant
+      - servant-server
+      - string-conversions
+      - text
+      - transformers
+      - wai
+      - warp
+    source-dirs:
+      - ./
+      - ../../../test
+      - ../../../src
+    include-dirs:
+      - ../../../include

servant-client/test/ghcjs/testServer/stack.yaml

@@ -0,0 +1,10 @@
+flags: {}
+packages:
+- location: ./.
+- location: ../../../../
+  subdirs:
+  - servant
+  - servant-client
+  - servant-server
+  extra-dep: true
+resolver: lts-5.15

servant-client/test/ghcjs/testServer/testServer.cabal

@@ -0,0 +1,41 @@
+-- This file has been generated from package.yaml by hpack version 0.13.0.
+--
+-- see: https://github.com/sol/hpack
+
+name:           testServer
+version:        0.0.0
+build-type:     Simple
+cabal-version:  >= 1.10
+
+executable testServer
+  main-is: testServer.hs
+  hs-source-dirs:
+      ./
+    , ../../../test
+    , ../../../src
+  include-dirs:
+      ../../../include
+  build-depends:
+      base
+    , aeson
+    , base64-bytestring
+    , bytestring
+    , exceptions
+    , hspec
+    , http-api-data
+    , http-client
+    , http-media
+    , http-types
+    , HUnit
+    , network
+    , network-uri
+    , QuickCheck
+    , safe
+    , servant
+    , servant-server
+    , string-conversions
+    , text
+    , transformers
+    , wai
+    , warp
+  default-language: Haskell2010

servant-client/test/ghcjs/testServer/testServer.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+import           Network.Wai.Handler.Warp
+import           Servant
+import           System.IO
+
+import           Servant.Client.TestServer.GHC
+import           Servant.Client.TestServer.Types
+import           Servant.ClientSpec
+
+main :: IO ()
+main = do
+  (port, socket) <- openTestSocket
+  let settings =
+        setPort port $
+        setBeforeMainLoop (print port >> hFlush stdout) $
+        defaultSettings
+  runSettingsSocket settings socket $
+    serve testServerApi $ \ testServerName request respond -> do
+      app <- testServerApp <$> lookupTestServer testServerName
+      app request respond
+
+type TestServerApi =
+  Capture "testServerName" String :> Raw
+
+testServerApi :: Proxy TestServerApi
+testServerApi = Proxy