wip

Uses the fix mentioned by @arianvp in
https://github.com/haskell-servant/servant/pull/425.

See also
https://github.com/haskell-servant/servant/issues/51#issuecomment-250737727

The cause of the issue very is similar to the issue described
in this blog post:
https://www.fpcomplete.com/blog/2016/06/async-exceptions-stm-deadlocks

The main thread creates a waiter, creates an asynchronous callback which is
called when the `readyState` of the request changes. When the readyState
changes to 4, which means 'request finished', the waiter MVar is put.
The main thread takes the MVar and continues to do stuff with the response.

The problem is that the `readyState` can change to 4 more than once,
for some reason. The second time this happens, the waiter MVar can be put
again, since the main thread took it. The main thread, however, won't take
it again. After all, it only needed to take the MVar once to know that the
request was finished. The third time `readyState` is set to 4, the putMVar
would block, causing the following exception to be thrown:

```
thread blocked indefinitely in an MVar operation
```

Since state 4 should really mean that the response is ready, it seems
appropriate to decide that all changes of the state to 4 after the initial one
can be safely ignored.

.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

.travis.yml

@@ -19,6 +19,7 @@ install:
   - stack --version
   - stack setup --no-terminal
   - (cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
+  - if [ "$STACK_YAML" = "stack.yaml" ] ; then (cd servant-client/test/ghcjs/ && ./run-tests.sh) ; fi
 
 script:
   - if [ "$TRAVIS_EVENT_TYPE" = "cron" ] ; then ./scripts/ci-cron.sh ; else stack test --ghc-options=-Werror --no-terminal ; fi

GHCJS.md

@@ -0,0 +1,51 @@
+# Support for ghcjs
+
+This branch of servant implements experimental support for
+[ghcjs](https://github.com/ghcjs/ghcjs) for `servant-client`.
+This means it allows you to write Haskell code in terms of `servant-client`,
+compile it with `ghcjs` to javascript and then use it to execute XHRs from a
+browser. The idea is that this should work transparently for the programmer,
+i.e. from a user's perspective it should work exactly as it does when compiled
+with `ghc`.
+
+## Status
+
+This branch is experimental.
+
+Known caveats:
+
+- Sending bodies in requests doesn't work when using methods `GET` and `HEAD`.
+  At least when running the test-suite with node. `GET` and `HEAD` requests are
+  not supposed to have request bodies and [xhr2](https://www.npmjs.com/package/xhr2)
+	-- which we use to issue XHRs from node -- discards the request bodies for `GET` and
+	`HEAD` requests. (This might actually work in some browsers, no clue.) This causes one
+  failing test in the test-suite.
+- We don't have CI for running the test-suite with `ghcjs`. We tried to make
+	that work, but failed miserably. That's the main reason why this is not merged
+  to `master`.
+- `servant-client` uses libraries that are not optimized for `ghcjs`. I haven't
+  investigated this much, but I could imagine that e.g. a native javascript JSON
+  parser would be much faster than `aeson` compiled by `ghcjs`.
+
+## Getting it to work
+
+The `stack` file that is used to run the test-suite with `ghcjs` may provide
+some inspiration: `servant-client/test/ghcjs/stack-ghcjs.yaml`.
+
+## Running the tests
+
+You can run the tests by doing:
+
+``` bash
+./servant-client/test/ghcjs/run-tests.sh
+```
+
+## Further development
+
+I propose to use the branch `client-ghcjs` as a place for further development
+on `ghcjs` support for `servant-client`. We could
+
+- create PRs against the branch,
+- for releases on `master` merge `master` into this branch to not fall behind,
+- maybe even create tags, e.g. `ghcjs-v0.6` and `ghcjs-v0.7.1` to give people
+  fixed commits to stick to.

servant-client/servant-client.cabal

@@ -34,6 +34,15 @@ 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      && < 4.10
     , aeson                 >= 0.7      && < 1.1
@@ -54,6 +63,11 @@ library
     , transformers          >= 0.3      && < 0.6
     , transformers-compat   >= 0.4      && < 0.6
     , mtl
+  if impl(ghcjs)
+    build-depends:
+        ghcjs-base
+      , ghcjs-prim
+      , case-insensitive
   hs-source-dirs: src
   default-language: Haskell2010
   ghc-options: -Wall
@@ -63,31 +77,59 @@ library
 
 test-suite spec
   type: exitcode-stdio-1.0
-  ghc-options: -Wall
+  ghc-options: -Wall -fno-warn-name-shadowing
+  if impl(ghc >= 8.0)
+    ghc-options: -Wno-redundant-constraints
   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.*
+    , base-compat
     , transformers
     , transformers-compat
     , aeson
+    , base64-bytestring
     , bytestring
     , deepseq
-    , hspec == 2.*
+    , hspec >= 2.2.1 && < 2.3
     , http-api-data
     , http-client
     , http-media
     , http-types
     , HUnit
+    , mtl
     , network >= 2.6
     , QuickCheck >= 2.7
     , servant == 0.9.*
-    , servant-client
     , servant-server == 0.9.*
     , 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

@@ -45,6 +45,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,48 @@
+{-# 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 Eq ServantError where
+  FailureResponse a b c == FailureResponse x y z =
+    (a, b, c) == (x, y, z)
+  DecodeFailure a b c == DecodeFailure x y z =
+    (a, b, c) == (x, y, z)
+  UnsupportedContentType a b == UnsupportedContentType x y =
+    (a, b) == (x, y)
+  InvalidContentTypeHeader a b == InvalidContentTypeHeader x y =
+    (a, b) == (x, y)
+  ConnectionError a == ConnectionError x =
+    show a == show x
+  _ == _ = False
+
+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,190 @@
+{-# 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           Foreign.StablePtr
+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
+
+    bracket (acquire waiter) releaseCallback $ \_callback -> do
+        t <- myThreadId
+        s <- newStablePtr t
+
+        openXhr xhr (cs $ method request) (toUrl request) True
+        setHeaders xhr (requestHeaders request)
+        sendXhr xhr (toBody request)
+        takeMVar waiter
+
+        freeStablePtr s
+  where
+    acquire waiter = onReadyStateChange xhr $ do
+      state <- readyState xhr
+      case state of
+        -- onReadyStateChange's callback can fire state 4
+        -- (which means "request finished and response is ready")
+        -- multiple times. By using tryPutMVar, only the first time
+        -- state 4 is fired will cause an MVar to be put. Subsequent
+        -- fires are ignored.
+        4 -> tryPutMVar waiter () >> return ()
+        _ -> return ()
+
+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

@@ -5,6 +5,10 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving   #-}
 
+#if MIN_VERSION_base(4,9,0)
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+#endif
+
 module Servant.Common.Req where
 
 #if !MIN_VERSION_base(4,8,0)
@@ -31,57 +35,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 Network.HTTP.Client hiding (Proxy, path)
+import qualified Network.HTTP.Types.Header as HTTP
-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 Eq ServantError where
-  FailureResponse a b c == FailureResponse x y z =
-    (a, b, c) == (x, y, z)
-  DecodeFailure a b c == DecodeFailure x y z =
-    (a, b, c) == (x, y, z)
-  UnsupportedContentType a b == UnsupportedContentType x y =
-    (a, b) == (x, y)
-  InvalidContentTypeHeader a b == InvalidContentTypeHeader x y =
-    (a, b) == (x, y)
-  ConnectionError a == ConnectionError x =
-    show a == show x
-  _ == _ = False
-
-instance Exception ServantError
 
 data Req = Req
   { reqPath   :: String
@@ -192,7 +156,7 @@ performRequest reqMethod req = do
 
   let request = partialRequest { Client.method = reqMethod }
 
-  eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
+  eResponse <- liftIO $ performHttpRequest m request
   case eResponse of
     Left err ->
       throwError . ConnectionError $ SomeException err
@@ -226,8 +190,3 @@ performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
 performRequestNoBody reqMethod req = do
   (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
   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,7 +10,6 @@
 {-# LANGUAGE PolyKinds              #-}
 {-# LANGUAGE RecordWildCards        #-}
 {-# LANGUAGE StandaloneDeriving     #-}
-{-# LANGUAGE ScopedTypeVariables    #-}
 {-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE TypeOperators          #-}
 {-# LANGUAGE UndecidableInstances   #-}
@@ -21,17 +19,13 @@
 {-# OPTIONS_GHC -fcontext-stack=100 #-}
 #endif
 {-# 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           Prelude ()
-import           Control.Applicative        ((<$>))
+import           Prelude.Compat
-#endif
+
 import           Control.Arrow              (left)
-import           Control.Concurrent         (forkIO, killThread, ThreadId)
-import           Control.Exception          (bracket)
 import           Control.Monad.Trans.Except (throwE )
 import           Data.Aeson
 import qualified Data.ByteString.Lazy       as BS
@@ -42,34 +36,75 @@ import           Data.Proxy
 import           GHC.Generics               (Generic)
 import qualified Network.HTTP.Client        as C
 import           Network.HTTP.Media
-import qualified Network.HTTP.Types         as HTTP
+import qualified Network.HTTP.Types as HTTP
-import           Network.Socket
+import           Network.Wai                (responseLBS)
-import           Network.Wai                (Request, requestHeaders, responseLBS)
+import qualified Network.Wai as Wai
-import           Network.Wai.Handler.Warp
+import           System.Exit.Compat
 import           System.IO.Unsafe           (unsafePerformIO)
+import           Test.HUnit
 import           Test.Hspec
 import           Test.Hspec.QuickCheck
-import           Test.HUnit
 import           Test.QuickCheck
 import           Web.FormUrlEncoded         (FromForm, ToForm)
 
 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
 
@@ -142,8 +177,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)
@@ -162,19 +197,19 @@ 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")] "")
+  :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
  )
 
 -- * basic auth stuff
@@ -196,8 +231,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
 
@@ -210,62 +246,63 @@ 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 <$> (runClientM getGet  (ClientEnv 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 <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
 
-      it "allows content type" $ \(_, baseUrl) -> do
+      it "allows content type" $ \baseUrl -> do
         (left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
 
-    it "Servant.API.Capture" $ \(_, baseUrl) -> do
+    it "Servant.API.Capture" $ \baseUrl -> do
       (left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0)
 
-    it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
+    it "Servant.API.CaptureAll" $ \baseUrl -> do
       let expected = [(Person "Paula" 0), (Person "Peta" 1)]
       (left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv  manager baseUrl))) `shouldReturn` Right expected
 
-    it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
+    it "Servant.API.ReqBody" $ \baseUrl -> do
       let p = Person "Clara" 42
       (left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p
 
-    it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
+    it "Servant.API.QueryParam" $ \baseUrl -> do
       left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl)  `shouldReturn` Right alice
       Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv 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 <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right []
       (left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv 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 <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag
 
-    it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
+    it "Servant.API.Raw on success" $ \baseUrl -> do
       res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl)
       case res of
         Left e -> assertFailure $ show e
@@ -274,7 +311,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 <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl)
       case res of
         Right _ -> assertFailure "expected Left, but got Right"
@@ -282,51 +319,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 <- runClientM getRespHeaders (ClientEnv 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 <$> runClientM (getMultiple cap num flag body) (ClientEnv 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 :: SCR.ClientM ()
+    err = throwE $ ServantErr 500 "error message" "" []
-                getResponse = client api
+
-            Left FailureResponse{..} <- runClientM getResponse (ClientEnv 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 = [delete, get, post, put]
+        forM_ actions $ \ clientAction -> do
+          Left FailureResponse{..} <- runClientM clientAction (ClientEnv manager baseUrl)
+          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 <$> runClientM (getBasic basicAuthData) (ClientEnv 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{..} <- runClientM (getBasic basicAuthData) (ClientEnv 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 <$> runClientM (getProtected authRequest) (ClientEnv 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{..} <- runClientM (getProtected authRequest) (ClientEnv 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 <- runClientM getDeleteEmpty (ClientEnv 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 <- runClientM (getCapture "foo") (ClientEnv manager baseUrl)
         case res of
@@ -340,81 +419,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 <- runClientM getGet (ClientEnv 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 <- runClientM (getBody alice) (ClientEnv manager baseUrl)
+
         case res of
           InvalidContentTypeHeader "fooooo" _ -> return ()
           _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
 
-data WrappedApi where
-  WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
-                 HasClient api, Client api ~ 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 <$> runClientM (getBasic basicAuthData) (ClientEnv  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{..} <- runClientM (getBasic basicAuthData) (ClientEnv 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 <$> runClientM (getProtected authRequest) (ClientEnv 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{..} <- runClientM (getProtected authRequest) (ClientEnv 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,15 @@
+#!/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 build
+# stack test --fast

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

@@ -0,0 +1,22 @@
+# 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-6.0
+
+compiler: ghcjs-0.2.0.20160414_ghc-7.10.3
+compiler-check: match-exact
+setup-info:
+  ghcjs:
+    source:
+      ghcjs-0.2.0.20160414_ghc-7.10.3:
+        url: https://s3.amazonaws.com/ghcjs/ghcjs-0.2.0.20160414_ghc-7.10.3.tar.gz
+        sha1: 6d6f307503be9e94e0c96ef1308c7cf224d06be3
+
+extra-deps:
+- http-api-data-0.3

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

@@ -0,0 +1,36 @@
+name: testServer
+
+executables:
+  testServer:
+    main: testServer.hs
+    other-modules: []
+    dependencies:
+      - base
+      - base-compat
+      - 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,42 @@
+-- This file has been generated from package.yaml by hpack version 0.14.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
+    , base-compat
+    , 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