diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 1b5cb9f3..e60e1400 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -28,10 +28,9 @@ 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 + Servant.Client.PerformRequest.Base if impl(ghcjs) other-modules: Servant.Client.PerformRequest.GHCJS @@ -56,11 +55,11 @@ library , text , transformers , transformers-compat - , case-insensitive if impl(ghcjs) build-depends: ghcjs-base , ghcjs-prim + , case-insensitive hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -70,11 +69,11 @@ 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.BaseSpec + , Servant.Client.PerformRequest.GHCJSSpec , Servant.Client.TestServer , Servant.Common.BaseUrlSpec , Spec @@ -99,7 +98,6 @@ test-suite spec , network >= 2.6 , QuickCheck >= 2.7 , servant == 0.5.* - , servant-client , servant-server == 0.5.* , text , wai @@ -107,3 +105,12 @@ test-suite spec , mockery , safe , process + , http-api-data + , network-uri + , exceptions + , string-conversions + if impl(ghcjs) + build-depends: + ghcjs-base + , ghcjs-prim + , case-insensitive diff --git a/servant-client/src/Servant/Client/PerformRequest/Base.hs b/servant-client/src/Servant/Client/PerformRequest/Base.hs index 2e39a3b4..7d886c57 100644 --- a/servant-client/src/Servant/Client/PerformRequest/Base.hs +++ b/servant-client/src/Servant/Client/PerformRequest/Base.hs @@ -1,18 +1,9 @@ {-# 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 @@ -42,22 +33,3 @@ data ServantError 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/GHCJS.hs b/servant-client/src/Servant/Client/PerformRequest/GHCJS.hs index 84afdbb2..1969c3bf 100644 --- a/servant-client/src/Servant/Client/PerformRequest/GHCJS.hs +++ b/servant-client/src/Servant/Client/PerformRequest/GHCJS.hs @@ -1,16 +1,24 @@ {-# 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 @@ -149,3 +157,22 @@ 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 diff --git a/servant-client/test/Servant/Client/PerformRequest/BaseSpec.hs b/servant-client/test/Servant/Client/PerformRequest/GHCJSSpec.hs similarity index 71% rename from servant-client/test/Servant/Client/PerformRequest/BaseSpec.hs rename to servant-client/test/Servant/Client/PerformRequest/GHCJSSpec.hs index 9bad04ff..ea1b2b9e 100644 --- a/servant-client/test/Servant/Client/PerformRequest/BaseSpec.hs +++ b/servant-client/test/Servant/Client/PerformRequest/GHCJSSpec.hs @@ -1,10 +1,13 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -module Servant.Client.PerformRequest.BaseSpec where +module Servant.Client.PerformRequest.GHCJSSpec where import Test.Hspec -import Servant.Client.PerformRequest.Base +#ifdef __GHCJS__ + +import Servant.Client.PerformRequest.GHCJS spec :: Spec spec = do @@ -18,3 +21,9 @@ spec = do it "handles colons in header values correctly" $ do parseHeaders "foo: bar:baz" `shouldBe` [("foo", "bar:baz")] + +#else + +spec :: Spec +spec = return () +#endif diff --git a/servant-client/test/ghcjs/testServer.cabal b/servant-client/test/ghcjs/testServer.cabal index 95ec17c4..1f2b5af2 100644 --- a/servant-client/test/ghcjs/testServer.cabal +++ b/servant-client/test/ghcjs/testServer.cabal @@ -1,4 +1,4 @@ --- This file has been generated from package.yaml by hpack version 0.5.4. +-- This file has been generated from package.yaml by hpack version 0.8.0. -- -- see: https://github.com/sol/hpack @@ -30,10 +30,11 @@ executable testServer , transformers , network other-modules: - Servant.Client.PerformRequest.BaseSpec + Servant.Client.PerformRequest.GHCJSSpec Servant.Client.TestServer Servant.Client.TestServer.GHC Servant.Client.TestServer.GHCJS + Servant.Client.TestServer.Types Servant.ClientSpec Servant.Common.BaseUrlSpec Spec