From d46a41662e58cd9790a2326d589fb6d8042cc53a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?S=C3=B6nke=20Hahn?= <soenkehahn@gmail.com>
Date: Wed, 25 Nov 2015 17:31:58 +0800
Subject: [PATCH] wip

---
 .travis-ghc.sh                                |   6 +
 .travis-ghcjs.sh                              |  12 ++
 .travis.yml                                   |  15 +-
 servant-client/servant-client.cabal           |  31 +++-
 servant-client/src/Servant/Client.hs          |   1 +
 .../src/Servant/Client/PerformRequest.hs      |  13 ++
 .../src/Servant/Client/PerformRequest/Base.hs |  63 ++++++++
 .../src/Servant/Client/PerformRequest/GHC.hs  |  29 ++++
 .../Servant/Client/PerformRequest/GHCJS.hs    | 151 ++++++++++++++++++
 servant-client/src/Servant/Common/Req.hs      |  38 +----
 servant-client/stack-ghc.yaml                 |  23 +++
 servant-client/stack-ghcjs.yaml               |  25 +++
 .../Servant/Client/PerformRequest/BaseSpec.hs |  20 +++
 .../test/Servant/Client/TestServer.hs         |  12 ++
 .../test/Servant/Client/TestServer/GHC.hs     |  38 +++++
 .../test/Servant/Client/TestServer/GHCJS.hs   |  34 ++++
 servant-client/test/Servant/ClientSpec.hs     | 128 +++++++--------
 .../test/ghcjs/build-test-server.sh           |  10 ++
 servant-client/test/ghcjs/package.yaml        |  25 +++
 servant-client/test/ghcjs/run-tests.sh        |  11 ++
 servant-client/test/ghcjs/stack-ghc.yaml      |  15 ++
 servant-client/test/ghcjs/testServer.cabal    |  40 +++++
 servant-client/test/ghcjs/testServer.hs       |  27 ++++
 23 files changed, 656 insertions(+), 111 deletions(-)
 create mode 100755 .travis-ghc.sh
 create mode 100755 .travis-ghcjs.sh
 create mode 100644 servant-client/src/Servant/Client/PerformRequest.hs
 create mode 100644 servant-client/src/Servant/Client/PerformRequest/Base.hs
 create mode 100644 servant-client/src/Servant/Client/PerformRequest/GHC.hs
 create mode 100644 servant-client/src/Servant/Client/PerformRequest/GHCJS.hs
 create mode 100644 servant-client/stack-ghc.yaml
 create mode 100644 servant-client/stack-ghcjs.yaml
 create mode 100644 servant-client/test/Servant/Client/PerformRequest/BaseSpec.hs
 create mode 100644 servant-client/test/Servant/Client/TestServer.hs
 create mode 100644 servant-client/test/Servant/Client/TestServer/GHC.hs
 create mode 100644 servant-client/test/Servant/Client/TestServer/GHCJS.hs
 create mode 100755 servant-client/test/ghcjs/build-test-server.sh
 create mode 100644 servant-client/test/ghcjs/package.yaml
 create mode 100755 servant-client/test/ghcjs/run-tests.sh
 create mode 100644 servant-client/test/ghcjs/stack-ghc.yaml
 create mode 100644 servant-client/test/ghcjs/testServer.cabal
 create mode 100644 servant-client/test/ghcjs/testServer.hs

diff --git a/.travis-ghc.sh b/.travis-ghc.sh
new file mode 100755
index 00000000..1dc5ac84
--- /dev/null
+++ b/.travis-ghc.sh
@@ -0,0 +1,6 @@
+#/usr/bin/env bash
+set -ev
+
+for package in $(cat sources.txt); do
+  (cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1
+done
diff --git a/.travis-ghcjs.sh b/.travis-ghcjs.sh
new file mode 100755
index 00000000..2ae23d62
--- /dev/null
+++ b/.travis-ghcjs.sh
@@ -0,0 +1,12 @@
+#/usr/bin/env bash
+set -ev
+
+# tinc
+#cabal exec which hspec-discover
+#barf
+cabal install hspec-discover --prefix $HOME/.local
+# export PATH=$HOME/huhu/bin:$PATH
+which hspec-discover
+
+cd servant-client
+./test/ghcjs/run-tests.sh
diff --git a/.travis.yml b/.travis.yml
index 62501f7a..1c45c6fa 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -5,6 +5,8 @@ language: c
 env:
   - GHCVER=7.8.4
   - GHCVER=7.10.2
+  - GHCVER=7.10.2
+    GHCJS=true
 
 addons:
   apt:
@@ -17,6 +19,7 @@ addons:
       - libgmp-dev
 
 install:
+  # set up tinc
   - (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
   - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH
   - ghc --version
@@ -24,9 +27,19 @@ install:
   - travis_retry cabal update
   - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
 
+  # set up stack (for ghcjs in servant-client)
+  - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
+  - stack --version
+
 script:
-  - for package in $(cat sources.txt); do (cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done
+  - if [ "$GHCJS" = "true" ];
+      then ./.travis-ghcjs.sh ;
+      else ./.travis-ghc.sh ;
+    fi
+  - export CASHER_TIME_OUT=500
 
 cache:
   directories:
     - $HOME/.tinc/cache
+    - $HOME/.stack
+    - $HOME/.ghcjs
diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal
index 7fe69521..15bed2c0 100644
--- a/servant-client/servant-client.cabal
+++ b/servant-client/servant-client.cabal
@@ -28,6 +28,16 @@ library
     Servant.Client
     Servant.Common.BaseUrl
     Servant.Common.Req
+     -- fixme: shouldn't be part of the public API:
+    Servant.Client.PerformRequest.Base
+  other-modules:
+    Servant.Client.PerformRequest
+  if impl(ghcjs)
+    other-modules:
+      Servant.Client.PerformRequest.GHCJS
+  else
+    other-modules:
+      Servant.Client.PerformRequest.GHC
   build-depends:
       base >=4.7 && <5
     , aeson
@@ -46,9 +56,14 @@ library
     , text
     , transformers
     , transformers-compat
+    , case-insensitive
+  if impl(ghcjs)
+    build-depends:
+        ghcjs-base
+      , ghcjs-prim
   hs-source-dirs: src
   default-language: Haskell2010
-  ghc-options: -Wall
+  ghc-options: -Wall -Werror
 
 test-suite spec
   type: exitcode-stdio-1.0
@@ -59,7 +74,16 @@ test-suite spec
   main-is: Spec.hs
   other-modules:
       Servant.ClientSpec
+    , Servant.Client.PerformRequest.BaseSpec
+    , Servant.Client.TestServer
     , 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
@@ -67,7 +91,7 @@ test-suite spec
     , aeson
     , bytestring
     , deepseq
-    , hspec == 2.*
+    , hspec >= 2.2.1 && < 2.3
     , http-client
     , http-media
     , http-types
@@ -80,3 +104,6 @@ test-suite spec
     , text
     , wai
     , warp
+    , mockery
+    , safe
+    , process
diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs
index 987a2bd4..3ef63c4a 100644
--- a/servant-client/src/Servant/Client.hs
+++ b/servant-client/src/Servant/Client.hs
@@ -39,6 +39,7 @@ import qualified Network.HTTP.Types.Header  as HTTP
 import           Servant.API
 import           Servant.Common.BaseUrl
 import           Servant.Common.Req
+import           Servant.Client.PerformRequest (ServantError(..))
 
 -- * Accessing APIs as a Client
 
diff --git a/servant-client/src/Servant/Client/PerformRequest.hs b/servant-client/src/Servant/Client/PerformRequest.hs
new file mode 100644
index 00000000..50c8e793
--- /dev/null
+++ b/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
diff --git a/servant-client/src/Servant/Client/PerformRequest/Base.hs b/servant-client/src/Servant/Client/PerformRequest/Base.hs
new file mode 100644
index 00000000..2e39a3b4
--- /dev/null
+++ b/servant-client/src/Servant/Client/PerformRequest/Base.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Servant.Client.PerformRequest.Base where
+
+import           Control.Arrow
+import           Control.Exception
+import qualified Data.ByteString.Char8 as BS
+import           Data.ByteString.Lazy
+import           Data.CaseInsensitive
+import           Data.Char
+import           Data.String.Conversions
+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
+
+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
diff --git a/servant-client/src/Servant/Client/PerformRequest/GHC.hs b/servant-client/src/Servant/Client/PerformRequest/GHC.hs
new file mode 100644
index 00000000..2fbc7161
--- /dev/null
+++ b/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)
diff --git a/servant-client/src/Servant/Client/PerformRequest/GHCJS.hs b/servant-client/src/Servant/Client/PerformRequest/GHCJS.hs
new file mode 100644
index 00000000..84afdbb2
--- /dev/null
+++ b/servant-client/src/Servant/Client/PerformRequest/GHCJS.hs
@@ -0,0 +1,151 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Servant.Client.PerformRequest.GHCJS (
+  ServantError(..),
+  performHttpRequest,
+  ) where
+
+import           Control.Concurrent
+import           Control.Exception
+import           Control.Monad
+import qualified Data.ByteString.Lazy as LBS
+import           Data.CaseInsensitive
+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
diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs
index 38aa39b5..cfe22c78 100644
--- a/servant-client/src/Servant/Common/Req.hs
+++ b/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
-  = 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
+import qualified Network.HTTP.Client as Client
 
 data Req = Req
   { reqPath   :: String
@@ -134,7 +107,7 @@ performRequest reqMethod req reqHost manager = 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
@@ -168,8 +141,3 @@ performRequestCT ct reqMethod req reqHost manager = do
 performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ()
 performRequestNoBody reqMethod req reqHost manager =
   void $ performRequest reqMethod req reqHost manager
-
-catchConnectionError :: IO a -> IO (Either ServantError a)
-catchConnectionError action =
-  catch (Right <$> action) $ \e ->
-    pure . Left . ConnectionError $ SomeException (e :: HttpException)
diff --git a/servant-client/stack-ghc.yaml b/servant-client/stack-ghc.yaml
new file mode 100644
index 00000000..f8a7b5d0
--- /dev/null
+++ b/servant-client/stack-ghc.yaml
@@ -0,0 +1,23 @@
+# This file was added for being able to test ghcjs support
+
+packages:
+  - location: ./.
+  - location: ../
+    subdirs:
+      - servant
+      - servant-server
+    extra-dep: true
+  - location:
+      git: https://github.com/hspec/hspec
+      commit: bd06049
+    subdirs:
+      - ./
+      - hspec-core
+    extra-dep: true
+
+resolver: lts-3.10
+
+extra-deps:
+  - hspec-expectations-0.7.2
+  - hspec-discover-2.2.0
+  - http-api-data-0.1.1.1
diff --git a/servant-client/stack-ghcjs.yaml b/servant-client/stack-ghcjs.yaml
new file mode 100644
index 00000000..437fe3e0
--- /dev/null
+++ b/servant-client/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-3.10
+
+compiler: ghcjs-0.2.0.20151029_ghc-7.10.2
+compiler-check: match-exact
+setup-info:
+ ghcjs:
+  source:
+   ghcjs-0.2.0.20151029_ghc-7.10.2:
+    url: "https://github.com/nrolland/ghcjs/releases/download/v0.2.0.20151029/ghcjs-0.2.0.20151029.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
diff --git a/servant-client/test/Servant/Client/PerformRequest/BaseSpec.hs b/servant-client/test/Servant/Client/PerformRequest/BaseSpec.hs
new file mode 100644
index 00000000..9bad04ff
--- /dev/null
+++ b/servant-client/test/Servant/Client/PerformRequest/BaseSpec.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Servant.Client.PerformRequest.BaseSpec where
+
+import           Test.Hspec
+
+import           Servant.Client.PerformRequest.Base
+
+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")]
diff --git a/servant-client/test/Servant/Client/TestServer.hs b/servant-client/test/Servant/Client/TestServer.hs
new file mode 100644
index 00000000..e6aae5e0
--- /dev/null
+++ b/servant-client/test/Servant/Client/TestServer.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE CPP                    #-}
+
+module Servant.Client.TestServer (
+  buildTestServer,
+  withTestServer,
+)where
+
+#ifdef __GHCJS__
+import           Servant.Client.TestServer.GHCJS
+#else
+import           Servant.Client.TestServer.GHC
+#endif
diff --git a/servant-client/test/Servant/Client/TestServer/GHC.hs b/servant-client/test/Servant/Client/TestServer/GHC.hs
new file mode 100644
index 00000000..0a4dce20
--- /dev/null
+++ b/servant-client/test/Servant/Client/TestServer/GHC.hs
@@ -0,0 +1,38 @@
+{-# 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
+
+buildTestServer :: IO ()
+buildTestServer = return ()
+
+withTestServer :: Application -> String -> (BaseUrl -> IO a) -> IO a
+withTestServer 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)
diff --git a/servant-client/test/Servant/Client/TestServer/GHCJS.hs b/servant-client/test/Servant/Client/TestServer/GHCJS.hs
new file mode 100644
index 00000000..7deae806
--- /dev/null
+++ b/servant-client/test/Servant/Client/TestServer/GHCJS.hs
@@ -0,0 +1,34 @@
+
+module Servant.Client.TestServer.GHCJS where
+
+import           Control.Exception
+import           Network.Wai
+import           Safe
+import           System.Exit
+import           System.IO
+import           System.Process
+
+import           Servant.Common.BaseUrl
+
+buildTestServer :: IO ()
+buildTestServer = do
+  process <- spawnProcess "./test/ghcjs/build-test-server.sh" []
+  ExitSuccess <- waitForProcess process
+  return ()
+
+withTestServer :: Application -> String -> (BaseUrl -> IO a) -> IO a
+withTestServer _ 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" []) {
+        std_out = CreatePipe
+      }
+      line <- hGetLine stdout
+      case readMay line :: Maybe Int of
+        Nothing -> error ("unparseable port: " ++ show line)
+        Just port -> return (port, process)
+    stop (_, process) = do
+      terminateProcess process
+      waitForProcess process
diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs
index fc3cdcfb..c6e363aa 100644
--- a/servant-client/test/Servant/ClientSpec.hs
+++ b/servant-client/test/Servant/ClientSpec.hs
@@ -23,12 +23,10 @@
 module Servant.ClientSpec where
 
 #if !MIN_VERSION_base(4,8,0)
-import           Control.Applicative        ((<$>))
+import           Control.Applicative        ((<$>), pure)
 #endif
 import           Control.Arrow              (left)
-import           Control.Concurrent         (forkIO, killThread, ThreadId)
-import           Control.Exception          (bracket)
-import           Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
+import           Control.Monad.Trans.Except (runExceptT, throwE)
 import           Data.Aeson
 import           Data.Char                  (chr, isPrint)
 import           Data.Foldable              (forM_)
@@ -41,9 +39,7 @@ import qualified Network.HTTP.Client        as C
 import           Network.HTTP.Media
 import           Network.HTTP.Types         (Status (..), badRequest400,
                                              methodGet, ok200, status400)
-import           Network.Socket
 import           Network.Wai                (Application, responseLBS)
-import           Network.Wai.Handler.Warp
 import           System.IO.Unsafe           (unsafePerformIO)
 import           Test.Hspec
 import           Test.Hspec.QuickCheck
@@ -52,13 +48,16 @@ import           Test.QuickCheck
 
 import           Servant.API
 import           Servant.Client
+import           Servant.Client.TestServer
 import           Servant.Server
 
 spec :: Spec
-spec = describe "Servant.Client" $ do
+spec = do
+  runIO buildTestServer
+  describe "Servant.Client" $ do
     sucessSpec
     failSpec
-    wrappedApiSpec
+    errorSpec
 
 -- * test data types
 
@@ -105,7 +104,7 @@ type Api =
             QueryParam "second" Int :>
             QueryFlag "third" :>
             ReqBody '[JSON] [(String, [Rational])] :>
-            Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
+            Post '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
   :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
   :<|> "deleteContentType" :> Delete '[JSON] ()
 api :: Proxy Api
@@ -130,11 +129,11 @@ server = serve api (
   :<|> return ()
  )
 
-
 type FailApi =
        "get" :> Raw
   :<|> "capture" :> Capture "name" String :> Raw
   :<|> "body" :> Raw
+
 failApi :: Proxy FailApi
 failApi = Proxy
 
@@ -142,56 +141,56 @@ failServer :: Application
 failServer = serve failApi (
        (\ _request respond -> respond $ responseLBS ok200 [] "")
   :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")
-  :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
- )
+  :<|> (\ _request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
+  )
 
 {-# NOINLINE manager #-}
 manager :: C.Manager
 manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
 
 sucessSpec :: Spec
-sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
+sucessSpec = around (withTestServer server "server") $ do
 
-    it "Servant.API.Get" $ \(_, baseUrl) -> do
+    it "Servant.API.Get" $ \baseUrl -> do
       let getGet = getNth (Proxy :: Proxy 0) $ client api baseUrl manager
       (left show <$> runExceptT getGet) `shouldReturn` Right alice
 
     describe "Servant.API.Delete" $ do
-      it "allows empty content type" $ \(_, baseUrl) -> do
+      it "allows empty content type" $ \baseUrl -> do
         let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager
         (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right ()
 
-      it "allows content type" $ \(_, baseUrl) -> do
+      it "allows content type" $ \baseUrl -> do
         let getDeleteContentType = getLast $ client api baseUrl manager
         (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right ()
 
-    it "Servant.API.Capture" $ \(_, baseUrl) -> do
+    it "Servant.API.Capture" $ \baseUrl -> do
       let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager
       (left show <$> runExceptT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)
 
-    it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
+    it "Servant.API.ReqBody" $ \baseUrl -> do
       let p = Person "Clara" 42
           getBody = getNth (Proxy :: Proxy 3) $ client api baseUrl manager
       (left show <$> runExceptT (getBody p)) `shouldReturn` Right p
 
-    it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
+    it "Servant.API.QueryParam" $ \baseUrl -> do
       let getQueryParam = getNth (Proxy :: Proxy 4) $ client api baseUrl manager
       left show <$> runExceptT (getQueryParam (Just "alice")) `shouldReturn` Right alice
       Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob"))
       responseStatus `shouldBe` Status 400 "bob not found"
 
-    it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
+    it "Servant.API.QueryParam.QueryParams" $ \baseUrl -> do
       let getQueryParams = getNth (Proxy :: Proxy 5) $ client api baseUrl manager
       (left show <$> runExceptT (getQueryParams [])) `shouldReturn` Right []
       (left show <$> runExceptT (getQueryParams ["alice", "bob"]))
         `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
         let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api baseUrl manager
         (left show <$> runExceptT (getQueryFlag flag)) `shouldReturn` Right flag
 
-    it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
+    it "Servant.API.Raw on success" $ \baseUrl -> do
       let getRawSuccess = getNth (Proxy :: Proxy 7) $ client api baseUrl manager
       res <- runExceptT (getRawSuccess methodGet)
       case res of
@@ -201,7 +200,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
           C.responseBody response `shouldBe` body
           C.responseStatus response `shouldBe` 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
       let getRawFailure = getNth (Proxy :: Proxy 8) $ client api baseUrl manager
       res <- runExceptT (getRawFailure methodGet)
       case res of
@@ -210,15 +209,15 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
           Servant.Client.responseStatus e `shouldBe` status400
           Servant.Client.responseBody e `shouldBe` "rawFailure"
 
-    it "Returns headers appropriately" $ \(_, baseUrl) -> do
+    it "Returns headers appropriately" $ \baseUrl -> do
       let getRespHeaders = getNth (Proxy :: Proxy 10) $ client api baseUrl manager
       res <- runExceptT getRespHeaders
       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) ->
+    modifyMaxSuccess (const 2) $ do
+      it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \baseUrl ->
         let getMultiple = getNth (Proxy :: Proxy 9) $ client api baseUrl manager
         in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
           ioProperty $ do
@@ -226,37 +225,45 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
             return $
               result === Right (cap, num, flag, body)
 
+type ErrorApi =
+  Delete '[JSON] () :<|>
+  Get '[JSON] () :<|>
+  Post '[JSON] () :<|>
+  Put '[JSON] ()
 
-wrappedApiSpec :: Spec
-wrappedApiSpec = describe "error status codes" $ do
-  let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
-  context "are correctly handled by the client" $
-    let test :: (WrappedApi, String) -> Spec
-        test (WrappedApi api, desc) =
-          it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
-            let getResponse :: ExceptT ServantError IO ()
-                getResponse = client api baseUrl manager
-            Left FailureResponse{..} <- runExceptT getResponse
-            responseStatus `shouldBe` (Status 500 "error message")
-    in mapM_ test $
-        (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
-        (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
-        (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
-        (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
-        []
+errorApi :: Proxy ErrorApi
+errorApi = Proxy
+
+errorServer :: Application
+errorServer = serve errorApi $
+  err :<|> err :<|> err :<|> err
+  where
+    err = throwE $ ServantErr 500 "error message" "" []
+
+errorSpec :: Spec
+errorSpec =
+  around (withTestServer errorServer "errorServer") $ do
+    describe "error status codes" $
+      it "reports error statuses correctly" $ \baseUrl -> do
+        let delete :<|> get :<|> post :<|> put =
+              client errorApi baseUrl manager
+            actions = [delete, get, post, put]
+        forM_ actions $ \ clientAction -> do
+          Left FailureResponse{..} <- runExceptT clientAction
+          responseStatus `shouldBe` Status 500 "error message"
 
 failSpec :: Spec
-failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
+failSpec = around (withTestServer failServer "failServer") $ do
 
     context "client returns errors appropriately" $ do
-      it "reports FailureResponse" $ \(_, baseUrl) -> do
+      it "reports FailureResponse" $ \baseUrl -> do
         let (_ :<|> getDeleteEmpty :<|> _) = client api baseUrl manager
         Left res <- runExceptT getDeleteEmpty
         case res of
           FailureResponse (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 baseUrl manager
         Left res <- runExceptT (getCapture "foo")
         case res of
@@ -270,48 +277,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 baseUrl manager
         Left res <- runExceptT getGet
         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 baseUrl manager
         Left res <- runExceptT (getBody alice)
         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 ~ ExceptT ServantError IO ()) =>
-    Proxy api -> WrappedApi
-
 
 -- * 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
diff --git a/servant-client/test/ghcjs/build-test-server.sh b/servant-client/test/ghcjs/build-test-server.sh
new file mode 100755
index 00000000..5a1df6cd
--- /dev/null
+++ b/servant-client/test/ghcjs/build-test-server.sh
@@ -0,0 +1,10 @@
+#/usr/bin/env bash
+
+set -o errexit
+
+cd test/ghcjs
+
+export STACK_YAML=stack-ghc.yaml
+stack setup
+stack build
+cp $(stack exec which testServer) .
diff --git a/servant-client/test/ghcjs/package.yaml b/servant-client/test/ghcjs/package.yaml
new file mode 100644
index 00000000..35a8cc92
--- /dev/null
+++ b/servant-client/test/ghcjs/package.yaml
@@ -0,0 +1,25 @@
+name: testServer
+
+executables:
+  testServer:
+    main: testServer.hs
+    dependencies:
+      - base
+      - servant
+      - servant-client
+      - servant-server
+      - warp
+      - QuickCheck
+      - hspec
+      - HUnit
+      - http-types
+      - http-media
+      - http-client
+      - text
+      - aeson
+      - wai
+      - transformers
+      - network
+    source-dirs:
+      - ./
+      - ../
diff --git a/servant-client/test/ghcjs/run-tests.sh b/servant-client/test/ghcjs/run-tests.sh
new file mode 100755
index 00000000..9068e98d
--- /dev/null
+++ b/servant-client/test/ghcjs/run-tests.sh
@@ -0,0 +1,11 @@
+#/usr/bin/env bash
+
+# this script has to be executed from the 'servant-client' directory
+
+set -o errexit
+
+npm install xhr2
+
+export STACK_YAML=stack-ghcjs.yaml
+stack setup
+stack test
diff --git a/servant-client/test/ghcjs/stack-ghc.yaml b/servant-client/test/ghcjs/stack-ghc.yaml
new file mode 100644
index 00000000..e49df0d3
--- /dev/null
+++ b/servant-client/test/ghcjs/stack-ghc.yaml
@@ -0,0 +1,15 @@
+# This file was added for being able to test ghcjs support
+
+packages:
+  - location: ./.
+  - location: ../../../
+    subdirs:
+      - servant
+      - servant-client
+      - servant-server
+    extra-dep: true
+
+resolver: nightly-2015-10-08
+
+extra-deps:
+  - http-api-data-0.1.1.1
diff --git a/servant-client/test/ghcjs/testServer.cabal b/servant-client/test/ghcjs/testServer.cabal
new file mode 100644
index 00000000..95ec17c4
--- /dev/null
+++ b/servant-client/test/ghcjs/testServer.cabal
@@ -0,0 +1,40 @@
+-- This file has been generated from package.yaml by hpack version 0.5.4.
+--
+-- 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:
+      ./
+    , ../
+  build-depends:
+      base
+    , servant
+    , servant-client
+    , servant-server
+    , warp
+    , QuickCheck
+    , hspec
+    , HUnit
+    , http-types
+    , http-media
+    , http-client
+    , text
+    , aeson
+    , wai
+    , transformers
+    , network
+  other-modules:
+      Servant.Client.PerformRequest.BaseSpec
+      Servant.Client.TestServer
+      Servant.Client.TestServer.GHC
+      Servant.Client.TestServer.GHCJS
+      Servant.ClientSpec
+      Servant.Common.BaseUrlSpec
+      Spec
+  default-language: Haskell2010
diff --git a/servant-client/test/ghcjs/testServer.hs b/servant-client/test/ghcjs/testServer.hs
new file mode 100644
index 00000000..8510272c
--- /dev/null
+++ b/servant-client/test/ghcjs/testServer.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+import           Network.Wai.Handler.Warp
+import           Servant
+import           System.IO
+
+import           Servant.Client.TestServer.GHC
+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 (server :<|> errorServer :<|> failServer)
+
+type TestServerApi =
+  "server" :> Raw :<|>
+  "errorServer" :> Raw :<|>
+  "failServer" :> Raw
+
+testServerApi :: Proxy TestServerApi
+testServerApi = Proxy