git.iko.soy/servant
on e740390 help sign in
aaeee88
swap
14 ahead, 1207 behind
.gitignore+2
since splitsnapshots
unifiedsplit
@@ -29,3 +29,5 @@ doc/_build
29doc/venv
29doc/venv
30doc/tutorial/static/api.js
30doc/tutorial/static/api.js
31doc/tutorial/static/jq.js
31doc/tutorial/static/jq.js
32+servant-client/node_modules/
33+servant-client/test/ghcjs/testServer/testServer
.travis.yml+1
@@ -19,6 +19,7 @@ install:
19 - stack --version
19 - stack --version
20 - stack setup --no-terminal
20 - stack setup --no-terminal
21 - (cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
21 - (cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
22+ - if [ "$STACK_YAML" = "stack.yaml" ] ; then (cd servant-client/test/ghcjs/ && ./run-tests.sh) ; fi
22
23
23script:
24script:
24 - if [ "$TRAVIS_EVENT_TYPE" = "cron" ] ; then ./scripts/ci-cron.sh ; else stack test --ghc-options=-Werror --no-terminal ; fi
25 - if [ "$TRAVIS_EVENT_TYPE" = "cron" ] ; then ./scripts/ci-cron.sh ; else stack test --ghc-options=-Werror --no-terminal ; fi
GHCJS.mdnew file+51
@@ -0,0 +1,51 @@
1+# Support for ghcjs
2+
3+This branch of servant implements experimental support for
4+[ghcjs](https://github.com/ghcjs/ghcjs) for `servant-client`.
5+This means it allows you to write Haskell code in terms of `servant-client`,
6+compile it with `ghcjs` to javascript and then use it to execute XHRs from a
7+browser. The idea is that this should work transparently for the programmer,
8+i.e. from a user's perspective it should work exactly as it does when compiled
9+with `ghc`.
10+
11+## Status
12+
13+This branch is experimental.
14+
15+Known caveats:
16+
17+- Sending bodies in requests doesn't work when using methods `GET` and `HEAD`.
18+ At least when running the test-suite with node. `GET` and `HEAD` requests are
19+ not supposed to have request bodies and [xhr2](https://www.npmjs.com/package/xhr2)
20+ -- which we use to issue XHRs from node -- discards the request bodies for `GET` and
21+ `HEAD` requests. (This might actually work in some browsers, no clue.) This causes one
22+ failing test in the test-suite.
23+- We don't have CI for running the test-suite with `ghcjs`. We tried to make
24+ that work, but failed miserably. That's the main reason why this is not merged
25+ to `master`.
26+- `servant-client` uses libraries that are not optimized for `ghcjs`. I haven't
27+ investigated this much, but I could imagine that e.g. a native javascript JSON
28+ parser would be much faster than `aeson` compiled by `ghcjs`.
29+
30+## Getting it to work
31+
32+The `stack` file that is used to run the test-suite with `ghcjs` may provide
33+some inspiration: `servant-client/test/ghcjs/stack-ghcjs.yaml`.
34+
35+## Running the tests
36+
37+You can run the tests by doing:
38+
39+``` bash
40+./servant-client/test/ghcjs/run-tests.sh
41+```
42+
43+## Further development
44+
45+I propose to use the branch `client-ghcjs` as a place for further development
46+on `ghcjs` support for `servant-client`. We could
47+
48+- create PRs against the branch,
49+- for releases on `master` merge `master` into this branch to not fall behind,
50+- maybe even create tags, e.g. `ghcjs-v0.6` and `ghcjs-v0.7.1` to give people
51+ fixed commits to stick to.
servant-client/servant-client.cabal+46−4
@@ -34,6 +34,15 @@ library
34 Servant.Common.BaseUrl
34 Servant.Common.BaseUrl
35 Servant.Common.BasicAuth
35 Servant.Common.BasicAuth
36 Servant.Common.Req
36 Servant.Common.Req
37+ other-modules:
38+ Servant.Client.PerformRequest
39+ Servant.Client.PerformRequest.Base
40+ if impl(ghcjs)
41+ other-modules:
42+ Servant.Client.PerformRequest.GHCJS
43+ else
44+ other-modules:
45+ Servant.Client.PerformRequest.GHC
37 build-depends:
46 build-depends:
38 base >= 4.7 && < 4.10
47 base >= 4.7 && < 4.10
39 , aeson >= 0.7 && < 1.1
48 , aeson >= 0.7 && < 1.1
@@ -54,6 +63,11 @@ library
54 , transformers >= 0.3 && < 0.6
63 , transformers >= 0.3 && < 0.6
55 , transformers-compat >= 0.4 && < 0.6
64 , transformers-compat >= 0.4 && < 0.6
56 , mtl
65 , mtl
66+ if impl(ghcjs)
67+ build-depends:
68+ ghcjs-base
69+ , ghcjs-prim
70+ , case-insensitive
57 hs-source-dirs: src
71 hs-source-dirs: src
58 default-language: Haskell2010
72 default-language: Haskell2010
59 ghc-options: -Wall
73 ghc-options: -Wall
@@ -63,31 +77,59 @@ library
63
77
64test-suite spec
78test-suite spec
65 type: exitcode-stdio-1.0
79 type: exitcode-stdio-1.0
66− ghc-options: -Wall
80+ ghc-options: -Wall -fno-warn-name-shadowing
81+ if impl(ghc >= 8.0)
82+ ghc-options: -Wno-redundant-constraints
67 default-language: Haskell2010
83 default-language: Haskell2010
68− hs-source-dirs: test
84+ hs-source-dirs: test, src
69 main-is: Spec.hs
85 main-is: Spec.hs
70 other-modules:
86 other-modules:
71 Servant.ClientSpec
87 Servant.ClientSpec
88+ , Servant.Client.PerformRequest.GHCJSSpec
89+ , Servant.Client.TestServer
90+ , Servant.Client.TestServer.Types
91+ , Servant.Common.BaseUrl
72 , Servant.Common.BaseUrlSpec
92 , Servant.Common.BaseUrlSpec
93+ , Spec
94+ if impl(ghcjs)
95+ other-modules:
96+ Servant.Client.TestServer.GHCJS
97+ else
98+ other-modules:
99+ Servant.Client.TestServer.GHC
73 build-depends:
100 build-depends:
74 base == 4.*
101 base == 4.*
102+ , base-compat
75 , transformers
103 , transformers
76 , transformers-compat
104 , transformers-compat
77 , aeson
105 , aeson
106+ , base64-bytestring
78 , bytestring
107 , bytestring
79 , deepseq
108 , deepseq
80− , hspec == 2.*
109+ , hspec >= 2.2.1 && < 2.3
81 , http-api-data
110 , http-api-data
82 , http-client
111 , http-client
83 , http-media
112 , http-media
84 , http-types
113 , http-types
85 , HUnit
114 , HUnit
115+ , mtl
86 , network >= 2.6
116 , network >= 2.6
87 , QuickCheck >= 2.7
117 , QuickCheck >= 2.7
88 , servant == 0.9.*
118 , servant == 0.9.*
89− , servant-client
90 , servant-server == 0.9.*
119 , servant-server == 0.9.*
91 , text
120 , text
92 , wai
121 , wai
93 , warp
122 , warp
123+ , mockery
124+ , safe
125+ , process
126+ , http-api-data
127+ , network-uri
128+ , exceptions
129+ , string-conversions
130+ if impl(ghcjs)
131+ build-depends:
132+ ghcjs-base
133+ , ghcjs-prim
134+ , case-insensitive
135+ include-dirs: include
servant-client/src/Servant/Client.hs+1
@@ -45,6 +45,7 @@ import Servant.Client.Experimental.Auth
45import Servant.Common.BaseUrl
45import Servant.Common.BaseUrl
46import Servant.Common.BasicAuth
46import Servant.Common.BasicAuth
47import Servant.Common.Req
47import Servant.Common.Req
48+import Servant.Client.PerformRequest (ServantError(..))
48
49
49-- * Accessing APIs as a Client
50-- * Accessing APIs as a Client
50
51
servant-client/src/Servant/Client/PerformRequest.hsnew file+13
@@ -0,0 +1,13 @@
1+{-# LANGUAGE CPP #-}
2+
3+module Servant.Client.PerformRequest (
4+ ServantError(..),
5+ performHttpRequest,
6+) where
7+
8+import Servant.Client.PerformRequest.Base
9+#ifdef __GHCJS__
10+import Servant.Client.PerformRequest.GHCJS
11+#else
12+import Servant.Client.PerformRequest.GHC
13+#endif
servant-client/src/Servant/Client/PerformRequest/Base.hsnew file+48
@@ -0,0 +1,48 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+
3+module Servant.Client.PerformRequest.Base where
4+
5+import Control.Exception
6+import Data.ByteString.Lazy
7+import Data.Typeable
8+import Network.HTTP.Media
9+import Network.HTTP.Types
10+
11+data ServantError
12+ = FailureResponse
13+ { responseStatus :: Status
14+ , responseContentType :: MediaType
15+ , responseBody :: ByteString
16+ }
17+ | DecodeFailure
18+ { decodeError :: String
19+ , responseContentType :: MediaType
20+ , responseBody :: ByteString
21+ }
22+ | UnsupportedContentType
23+ { responseContentType :: MediaType
24+ , responseBody :: ByteString
25+ }
26+ | InvalidContentTypeHeader
27+ { responseContentTypeHeader :: ByteString
28+ , responseBody :: ByteString
29+ }
30+ | ConnectionError
31+ { connectionError :: SomeException
32+ }
33+ deriving (Show, Typeable)
34+
35+instance Eq ServantError where
36+ FailureResponse a b c == FailureResponse x y z =
37+ (a, b, c) == (x, y, z)
38+ DecodeFailure a b c == DecodeFailure x y z =
39+ (a, b, c) == (x, y, z)
40+ UnsupportedContentType a b == UnsupportedContentType x y =
41+ (a, b) == (x, y)
42+ InvalidContentTypeHeader a b == InvalidContentTypeHeader x y =
43+ (a, b) == (x, y)
44+ ConnectionError a == ConnectionError x =
45+ show a == show x
46+ _ == _ = False
47+
48+instance Exception ServantError
servant-client/src/Servant/Client/PerformRequest/GHC.hsnew file+29
@@ -0,0 +1,29 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ViewPatterns #-}
4+
5+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
6+
7+module Servant.Client.PerformRequest.GHC (
8+ ServantError(..),
9+ performHttpRequest,
10+ ) where
11+
12+#if !MIN_VERSION_base(4,8,0)
13+import Control.Applicative
14+#endif
15+import Control.Exception
16+import qualified Data.ByteString.Lazy as LBS
17+import Network.HTTP.Client
18+
19+import Servant.Client.PerformRequest.Base
20+
21+performHttpRequest :: Manager -> Request
22+ -> IO (Either ServantError (Response LBS.ByteString))
23+performHttpRequest manager request =
24+ catchConnectionError $ httpLbs request manager
25+
26+catchConnectionError :: IO a -> IO (Either ServantError a)
27+catchConnectionError action =
28+ catch (Right <$> action) $ \e ->
29+ pure . Left . ConnectionError $ SomeException (e :: HttpException)
servant-client/src/Servant/Client/PerformRequest/GHCJS.hsnew file+190
@@ -0,0 +1,190 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE ViewPatterns #-}
3+
4+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
5+
6+module Servant.Client.PerformRequest.GHCJS (
7+ ServantError(..),
8+ performHttpRequest,
9+
10+ -- exported for testing
11+ parseHeaders,
12+ ) where
13+
14+import Control.Arrow
15+import Control.Concurrent
16+import Control.Exception
17+import Control.Monad
18+import qualified Data.ByteString.Char8 as BS
19+import qualified Data.ByteString.Lazy as LBS
20+import Data.CaseInsensitive
21+import Data.Char
22+import Data.String.Conversions
23+import Foreign.StablePtr
24+import GHCJS.Foreign.Callback
25+import GHCJS.Prim
26+import Network.HTTP.Client
27+import Network.HTTP.Client.Internal as HttpClient
28+import Network.HTTP.Types
29+import Servant.Client.PerformRequest.Base
30+
31+newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
32+
33+newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
34+
35+performHttpRequest :: Manager -> Request -> IO (Either ServantError (Response LBS.ByteString))
36+performHttpRequest _ request = do
37+ xhr <- initXhr
38+ performXhr xhr request
39+ toResponse xhr
40+
41+-- * initialization
42+
43+initXhr :: IO JSXMLHttpRequest
44+initXhr = do
45+ lib <- requireXMLHttpRequestClass
46+ newXMLHttpRequest lib
47+
48+foreign import javascript unsafe
49+ -- branching between node (for testing) and browsers
50+ "(function () {if (typeof require !== 'undefined') { return require('xhr2'); } else { return XMLHttpRequest; };})()"
51+ requireXMLHttpRequestClass :: IO JSXMLHttpRequestClass
52+
53+foreign import javascript unsafe "new $1()"
54+ newXMLHttpRequest :: JSXMLHttpRequestClass -> IO JSXMLHttpRequest
55+
56+-- * performing requests
57+
58+-- Performs the xhr and blocks until the response was received
59+performXhr :: JSXMLHttpRequest -> Request -> IO ()
60+performXhr xhr request = do
61+ waiter <- newEmptyMVar
62+
63+ bracket (acquire waiter) releaseCallback $ \_callback -> do
64+ t <- myThreadId
65+ s <- newStablePtr t
66+
67+ openXhr xhr (cs $ method request) (toUrl request) True
68+ setHeaders xhr (requestHeaders request)
69+ sendXhr xhr (toBody request)
70+ takeMVar waiter
71+
72+ freeStablePtr s
73+ where
74+ acquire waiter = onReadyStateChange xhr $ do
75+ state <- readyState xhr
76+ case state of
77+ -- onReadyStateChange's callback can fire state 4
78+ -- (which means "request finished and response is ready")
79+ -- multiple times. By using tryPutMVar, only the first time
80+ -- state 4 is fired will cause an MVar to be put. Subsequent
81+ -- fires are ignored.
82+ 4 -> tryPutMVar waiter () >> return ()
83+ _ -> return ()
84+
85+onReadyStateChange :: JSXMLHttpRequest -> IO () -> IO (Callback (IO ()))
86+onReadyStateChange xhr action = do
87+ callback <- asyncCallback action
88+ js_onReadyStateChange xhr callback
89+ return callback
90+foreign import javascript safe "$1.onreadystatechange = $2;"
91+ js_onReadyStateChange :: JSXMLHttpRequest -> Callback (IO ()) -> IO ()
92+
93+foreign import javascript unsafe "$1.readyState"
94+ readyState :: JSXMLHttpRequest -> IO Int
95+
96+openXhr :: JSXMLHttpRequest -> String -> String -> Bool -> IO ()
97+openXhr xhr method url async =
98+ js_openXhr xhr (toJSString method) (toJSString url) async
99+foreign import javascript unsafe "$1.open($2, $3, $4)"
100+ js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
101+
102+toUrl :: Request -> String
103+toUrl request =
104+ let protocol = if secure request then "https" else "http"
105+ hostS = cs $ host request
106+ portS = show $ port request
107+ pathS = cs $ path request
108+ queryS = cs $ queryString request
109+ in protocol ++ "://" ++ hostS ++ ":" ++ portS ++ pathS ++ queryS
110+
111+setHeaders :: JSXMLHttpRequest -> RequestHeaders -> IO ()
112+setHeaders xhr headers = forM_ headers $ \ (key, value) ->
113+ js_setRequestHeader xhr (toJSString $ cs $ original key) (toJSString $ cs value)
114+foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
115+ js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
116+
117+sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()
118+sendXhr xhr Nothing = js_sendXhr xhr
119+sendXhr xhr (Just body) =
120+ js_sendXhrWithBody xhr (toJSString body)
121+foreign import javascript unsafe "$1.send()"
122+ js_sendXhr :: JSXMLHttpRequest -> IO ()
123+foreign import javascript unsafe "$1.send($2)"
124+ js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
125+
126+toBody :: Request -> Maybe String
127+toBody request = case requestBody request of
128+ RequestBodyLBS "" -> Nothing
129+ RequestBodyLBS x -> Just $ cs x
130+ _ -> error "servant-client only uses RequestBodyLBS"
131+
132+-- * inspecting the xhr response
133+
134+-- This function is only supposed to handle 'ConnectionError's. Other
135+-- 'ServantError's are created in Servant.Client.Req.
136+toResponse :: JSXMLHttpRequest -> IO (Either ServantError (Response LBS.ByteString))
137+toResponse xhr = do
138+ status <- getStatus xhr
139+ case status of
140+ 0 -> return $ Left $ ConnectionError $ SomeException $ ErrorCall "connection error"
141+ _ -> do
142+ statusText <- cs <$> getStatusText xhr
143+ headers <- parseHeaders <$> getAllResponseHeaders xhr
144+ responseText <- cs <$> getResponseText xhr
145+ return $ Right $ Response {
146+ HttpClient.responseStatus = mkStatus status statusText,
147+ responseVersion = http11, -- this is made up
148+ responseHeaders = headers,
149+ HttpClient.responseBody = responseText,
150+ responseCookieJar = mempty,
151+ responseClose' = ResponseClose (return ())
152+ }
153+
154+foreign import javascript unsafe "$1.status"
155+ getStatus :: JSXMLHttpRequest -> IO Int
156+
157+getStatusText :: JSXMLHttpRequest -> IO String
158+getStatusText = fmap fromJSString . js_statusText
159+foreign import javascript unsafe "$1.statusText"
160+ js_statusText :: JSXMLHttpRequest -> IO JSVal
161+
162+getAllResponseHeaders :: JSXMLHttpRequest -> IO String
163+getAllResponseHeaders xhr =
164+ fromJSString <$> js_getAllResponseHeaders xhr
165+foreign import javascript unsafe "$1.getAllResponseHeaders()"
166+ js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
167+
168+getResponseText :: JSXMLHttpRequest -> IO String
169+getResponseText xhr = fromJSString <$> js_responseText xhr
170+foreign import javascript unsafe "$1.responseText"
171+ js_responseText :: JSXMLHttpRequest -> IO JSVal
172+
173+parseHeaders :: String -> ResponseHeaders
174+parseHeaders s =
175+ fmap (first mk) $
176+ fmap (first strip . second strip) $
177+ fmap parseHeader $
178+ splitOn "\r\n" (cs s)
179+ where
180+ parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)
181+ parseHeader h = case BS.breakSubstring ":" (cs h) of
182+ (key, (BS.drop 1 -> value)) -> (key, value)
183+
184+ splitOn :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
185+ splitOn separator input = case BS.breakSubstring separator input of
186+ (prefix, "") -> [prefix]
187+ (prefix, rest) -> prefix : splitOn separator (BS.drop (BS.length separator) rest)
188+
189+ strip :: BS.ByteString -> BS.ByteString
190+ strip = BS.dropWhile isSpace . BS.reverse . BS.dropWhile isSpace . BS.reverse
servant-client/src/Servant/Common/Req.hs+11−52
@@ -5,6 +5,10 @@
5{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7
7
8+#if MIN_VERSION_base(4,9,0)
9+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
10+#endif
11+
8module Servant.Common.Req where
12module Servant.Common.Req where
9
13
10#if !MIN_VERSION_base(4,8,0)
14#if !MIN_VERSION_base(4,8,0)
@@ -31,57 +35,17 @@ import Data.String.Conversions
31import Data.Proxy
35import Data.Proxy
32import Data.Text (Text)
36import Data.Text (Text)
33import Data.Text.Encoding
37import Data.Text.Encoding
34−import Data.Typeable
38+import Network.HTTP.Client hiding (Proxy, path)
35import Network.HTTP.Media
39import Network.HTTP.Media
36import Network.HTTP.Types
40import Network.HTTP.Types
37−import Network.HTTP.Client hiding (Proxy, path)
38−import qualified Network.HTTP.Types.Header as HTTP
41+import qualified Network.HTTP.Types.Header as HTTP
39import Network.URI hiding (path)
42import Network.URI hiding (path)
40import Servant.API.ContentTypes
43import Servant.API.ContentTypes
44+import Servant.Client.PerformRequest
41import Servant.Common.BaseUrl
45import Servant.Common.BaseUrl
42−
43−import qualified Network.HTTP.Client as Client
44−
45import Web.HttpApiData
46import Web.HttpApiData
46
47
47−data ServantError
48+import qualified Network.HTTP.Client as Client
48− = FailureResponse
49− { responseStatus :: Status
50− , responseContentType :: MediaType
51− , responseBody :: ByteString
52− }
53− | DecodeFailure
54− { decodeError :: String
55− , responseContentType :: MediaType
56− , responseBody :: ByteString
57− }
58− | UnsupportedContentType
59− { responseContentType :: MediaType
60− , responseBody :: ByteString
61− }
62− | InvalidContentTypeHeader
63− { responseContentTypeHeader :: ByteString
64− , responseBody :: ByteString
65− }
66− | ConnectionError
67− { connectionError :: SomeException
68− }
69− deriving (Show, Typeable)
70−
71−instance Eq ServantError where
72− FailureResponse a b c == FailureResponse x y z =
73− (a, b, c) == (x, y, z)
74− DecodeFailure a b c == DecodeFailure x y z =
75− (a, b, c) == (x, y, z)
76− UnsupportedContentType a b == UnsupportedContentType x y =
77− (a, b) == (x, y)
78− InvalidContentTypeHeader a b == InvalidContentTypeHeader x y =
79− (a, b) == (x, y)
80− ConnectionError a == ConnectionError x =
81− show a == show x
82− _ == _ = False
83−
84−instance Exception ServantError
85
49
86data Req = Req
50data Req = Req
87 { reqPath :: String
51 { reqPath :: String
@@ -182,7 +146,7 @@ runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
182runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
146runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
183
147
184
148
185−performRequest :: Method -> Req
149+performRequest :: Method -> Req
186 -> ClientM ( Int, ByteString, MediaType
150 -> ClientM ( Int, ByteString, MediaType
187 , [HTTP.Header], Response ByteString)
151 , [HTTP.Header], Response ByteString)
188performRequest reqMethod req = do
152performRequest reqMethod req = do
@@ -192,7 +156,7 @@ performRequest reqMethod req = do
192
156
193 let request = partialRequest { Client.method = reqMethod }
157 let request = partialRequest { Client.method = reqMethod }
194
158
195− eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
159+ eResponse <- liftIO $ performHttpRequest m request
196 case eResponse of
160 case eResponse of
197 Left err ->
161 Left err ->
198 throwError . ConnectionError $ SomeException err
162 throwError . ConnectionError $ SomeException err
@@ -211,7 +175,7 @@ performRequest reqMethod req = do
211 throwError $ FailureResponse status ct body
175 throwError $ FailureResponse status ct body
212 return (status_code, body, ct, hdrs, response)
176 return (status_code, body, ct, hdrs, response)
213
177
214−performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
178+performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
215 -> ClientM ([HTTP.Header], result)
179 -> ClientM ([HTTP.Header], result)
216performRequestCT ct reqMethod req = do
180performRequestCT ct reqMethod req = do
217 let acceptCT = contentType ct
181 let acceptCT = contentType ct
@@ -226,8 +190,3 @@ performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
226performRequestNoBody reqMethod req = do
190performRequestNoBody reqMethod req = do
227 (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
191 (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
228 return hdrs
192 return hdrs
229−
230−catchConnectionError :: IO a -> IO (Either ServantError a)
231−catchConnectionError action =
232− catch (Right <$> action) $ \e ->
233− pure . Left . ConnectionError $ SomeException (e :: HttpException)
servant-client/test/Servant/Client/PerformRequest/GHCJSSpec.hsnew file+29
@@ -0,0 +1,29 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
4+module Servant.Client.PerformRequest.GHCJSSpec where
5+
6+import Test.Hspec
7+
8+#ifdef __GHCJS__
9+
10+import Servant.Client.PerformRequest.GHCJS
11+
12+spec :: Spec
13+spec = do
14+ describe "parseHeaders" $ do
15+ it "parses single headers" $ do
16+ parseHeaders "key: value" `shouldBe` [("key", "value")]
17+
18+ it "parses multiple headers" $ do
19+ parseHeaders "foo: bar\r\nnext: yay" `shouldBe`
20+ [("foo", "bar"), ("next", "yay")]
21+
22+ it "handles colons in header values correctly" $ do
23+ parseHeaders "foo: bar:baz" `shouldBe` [("foo", "bar:baz")]
24+
25+#else
26+
27+spec :: Spec
28+spec = return ()
29+#endif
servant-client/test/Servant/Client/TestServer.hsnew file+15
@@ -0,0 +1,15 @@
1+{-# LANGUAGE CPP #-}
2+
3+module Servant.Client.TestServer (
4+ buildTestServer,
5+ TestServer(..),
6+ withServer,
7+) where
8+
9+#ifdef __GHCJS__
10+import Servant.Client.TestServer.GHCJS
11+#else
12+import Servant.Client.TestServer.GHC
13+#endif
14+
15+import Servant.Client.TestServer.Types
servant-client/test/Servant/Client/TestServer/GHC.hsnew file+39
@@ -0,0 +1,39 @@
1+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2+
3+module Servant.Client.TestServer.GHC where
4+
5+import Control.Concurrent
6+import Control.Exception
7+import Network.Socket
8+import Network.Wai
9+import Network.Wai.Handler.Warp
10+
11+import Servant.Common.BaseUrl
12+import Servant.Client.TestServer.Types
13+
14+buildTestServer :: IO ()
15+buildTestServer = return ()
16+
17+withServer :: TestServer -> (BaseUrl -> IO a) -> IO a
18+withServer (TestServer _ app) action =
19+ bracket (startWaiApp app) endWaiApp $ \ (_, url) ->
20+ action url
21+
22+startWaiApp :: Application -> IO (ThreadId, BaseUrl)
23+startWaiApp app = do
24+ (port, socket) <- openTestSocket
25+ let settings = setPort port $ defaultSettings
26+ thread <- forkIO $ runSettingsSocket settings socket app
27+ return (thread, BaseUrl Http "localhost" port "")
28+
29+endWaiApp :: (ThreadId, BaseUrl) -> IO ()
30+endWaiApp (thread, _) = killThread thread
31+
32+openTestSocket :: IO (Port, Socket)
33+openTestSocket = do
34+ s <- socket AF_INET Stream defaultProtocol
35+ localhost <- inet_addr "127.0.0.1"
36+ bind s (SockAddrInet aNY_PORT localhost)
37+ listen s 1
38+ port <- socketPort s
39+ return (fromIntegral port, s)
servant-client/test/Servant/Client/TestServer/GHCJS.hsnew file+34
@@ -0,0 +1,34 @@
1+
2+module Servant.Client.TestServer.GHCJS where
3+
4+import Control.Exception
5+import Safe
6+import System.Exit
7+import System.IO
8+import System.Process
9+
10+import Servant.Client.TestServer.Types
11+import Servant.Common.BaseUrl
12+
13+buildTestServer :: IO ()
14+buildTestServer = do
15+ process <- spawnProcess "./test/ghcjs/build-test-server.sh" []
16+ ExitSuccess <- waitForProcess process
17+ return ()
18+
19+withServer :: TestServer -> (BaseUrl -> IO a) -> IO a
20+withServer (TestServer testServerName _) action = do
21+ bracket start stop $ \ (port, _) -> action (BaseUrl Http "localhost" port ("/" ++ testServerName))
22+ where
23+ start :: IO (Int, ProcessHandle)
24+ start = do
25+ (Nothing, Just stdout, Nothing, process) <- createProcess $ (proc "./test/ghcjs/testServer/testServer" []) {
26+ std_out = CreatePipe
27+ }
28+ line <- hGetLine stdout
29+ case readMay line :: Maybe Int of
30+ Nothing -> die ("unparseable port: " ++ show line)
31+ Just port -> return (port, process)
32+ stop (_, process) = do
33+ terminateProcess process
34+ waitForProcess process
servant-client/test/Servant/Client/TestServer/Types.hsnew file+10
@@ -0,0 +1,10 @@
1+
2+module Servant.Client.TestServer.Types where
3+
4+import Network.Wai
5+
6+data TestServer
7+ = TestServer {
8+ testServerName :: String,
9+ testServerApp :: Application
10+ }
servant-client/test/Servant/ClientSpec.hs+152−131
@@ -1,5 +1,4 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DeriveGeneric #-}
5{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
@@ -11,7 +10,6 @@
11{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE PolyKinds #-}
12{-# LANGUAGE RecordWildCards #-}
11{-# LANGUAGE RecordWildCards #-}
13{-# LANGUAGE StandaloneDeriving #-}
12{-# LANGUAGE StandaloneDeriving #-}
14−{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeFamilies #-}
16{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE TypeOperators #-}
17{-# LANGUAGE UndecidableInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
@@ -21,17 +19,13 @@
21{-# OPTIONS_GHC -fcontext-stack=100 #-}
19{-# OPTIONS_GHC -fcontext-stack=100 #-}
22#endif
20#endif
23{-# OPTIONS_GHC -fno-warn-orphans #-}
21{-# OPTIONS_GHC -fno-warn-orphans #-}
24−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
25
22
26−#include "overlapping-compat.h"
27module Servant.ClientSpec where
23module Servant.ClientSpec where
28
24
29−#if !MIN_VERSION_base(4,8,0)
25+import Prelude ()
30−import Control.Applicative ((<$>))
26+import Prelude.Compat
31−#endif
27+
32import Control.Arrow (left)
28import Control.Arrow (left)
33−import Control.Concurrent (forkIO, killThread, ThreadId)
34−import Control.Exception (bracket)
35import Control.Monad.Trans.Except (throwE )
29import Control.Monad.Trans.Except (throwE )
36import Data.Aeson
30import Data.Aeson
37import qualified Data.ByteString.Lazy as BS
31import qualified Data.ByteString.Lazy as BS
@@ -42,34 +36,75 @@ import Data.Proxy
42import GHC.Generics (Generic)
36import GHC.Generics (Generic)
43import qualified Network.HTTP.Client as C
37import qualified Network.HTTP.Client as C
44import Network.HTTP.Media
38import Network.HTTP.Media
45−import qualified Network.HTTP.Types as HTTP
39+import qualified Network.HTTP.Types as HTTP
46−import Network.Socket
47−import Network.Wai (Request, requestHeaders, responseLBS)
40+import Network.Wai (responseLBS)
48−import Network.Wai.Handler.Warp
41+import qualified Network.Wai as Wai
42+import System.Exit.Compat
49import System.IO.Unsafe (unsafePerformIO)
43import System.IO.Unsafe (unsafePerformIO)
44+import Test.HUnit
50import Test.Hspec
45import Test.Hspec
51import Test.Hspec.QuickCheck
46import Test.Hspec.QuickCheck
52−import Test.HUnit
53import Test.QuickCheck
47import Test.QuickCheck
54import Web.FormUrlEncoded (FromForm, ToForm)
48import Web.FormUrlEncoded (FromForm, ToForm)
55
49
56import Servant.API
50import Servant.API
57−import Servant.API.Internal.Test.ComprehensiveAPI
58import Servant.Client
51import Servant.Client
52+import Servant.Client.TestServer
53+import qualified Servant.Common.Req as SCR
59import Servant.Server
54import Servant.Server
60import Servant.Server.Experimental.Auth
55import Servant.Server.Experimental.Auth
61−import qualified Servant.Common.Req as SCR
62−
63−-- This declaration simply checks that all instances are in place.
64−_ = client comprehensiveAPI
65
56
66spec :: Spec
57spec :: Spec
58+spec = do
59+ runIO buildTestServer
67−spec = describe "Servant.Client" $ do
60+ describe "Servant.Client" $ do
68 sucessSpec
61 sucessSpec
69 failSpec
62 failSpec
70− wrappedApiSpec
71 basicAuthSpec
63 basicAuthSpec
72 genAuthSpec
64 genAuthSpec
65+ errorSpec
66+
67+-- | Run a test-server (identified by name) while performing the given action.
68+-- The provided 'BaseUrl' points to the running server.
69+--
70+-- Running the test-servers is done differently depending on the compiler
71+-- (ghc or ghcjs).
72+--
73+-- With ghc it's somewhat straight-forward: a wai 'Application' is being started
74+-- on a free port inside the same process using 'warp'.
75+--
76+-- When running the test-suite with ghcjs all the test-servers are compiled into
77+-- a single external executable (with ghc and warp). This is done through
78+-- 'buildTestServer' once at the start of the test-suite. This built executable
79+-- will provide all the test-servers on a free port under a path that
80+-- corresponds to the test-servers name, for example under
81+-- 'http://localhost:82923/failServer'. 'withTestServer' will then
82+-- start this executable as an external process while the given action is being
83+-- executed and provide it with the correct BaseUrl.
84+-- This rather cumbersome approach is taken because it's not easy to run a wai
85+-- Application as a http server when using ghcjs.
86+withTestServer :: String -> (BaseUrl -> IO a) -> IO a
87+withTestServer name action = do
88+ server <- lookupTestServer name
89+ withServer server action
90+
91+lookupTestServer :: String -> IO TestServer
92+lookupTestServer name = case lookup name mapping of
93+ Nothing -> die ("test server not found: " ++ name)
94+ Just testServer -> return testServer
95+ where
96+ mapping :: [(String, TestServer)]
97+ mapping = map (\ server -> (testServerName server, server)) allTestServers
98+
99+-- | All test-servers must be registered here.
100+allTestServers :: [TestServer]
101+allTestServers =
102+ server :
103+ errorServer :
104+ failServer :
105+ basicAuthServer :
106+ genAuthServer :
107+ []
73
108
74-- * test data types
109-- * test data types
75
110
@@ -120,9 +155,9 @@ getBody :: Person -> SCR.ClientM Person
120getQueryParam :: Maybe String -> SCR.ClientM Person
155getQueryParam :: Maybe String -> SCR.ClientM Person
121getQueryParams :: [String] -> SCR.ClientM [Person]
156getQueryParams :: [String] -> SCR.ClientM [Person]
122getQueryFlag :: Bool -> SCR.ClientM Bool
157getQueryFlag :: Bool -> SCR.ClientM Bool
123−getRawSuccess :: HTTP.Method
158+getRawSuccess :: HTTP.Method
124 -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
159 -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
125−getRawFailure :: HTTP.Method
160+getRawFailure :: HTTP.Method
126 -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
161 -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
127getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
162getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
128 -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])])
163 -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])])
@@ -142,8 +177,8 @@ getGet
142 :<|> getRespHeaders
177 :<|> getRespHeaders
143 :<|> getDeleteContentType = client api
178 :<|> getDeleteContentType = client api
144
179
145−server :: Application
180+server :: TestServer
146−server = serve api (
181+server = TestServer "server" $ serve api (
147 return alice
182 return alice
148 :<|> return NoContent
183 :<|> return NoContent
149 :<|> (\ name -> return $ Person name 0)
184 :<|> (\ name -> return $ Person name 0)
@@ -162,19 +197,19 @@ server = serve api (
162 :<|> return NoContent
197 :<|> return NoContent
163 )
198 )
164
199
165−
166type FailApi =
200type FailApi =
167 "get" :> Raw
201 "get" :> Raw
168 :<|> "capture" :> Capture "name" String :> Raw
202 :<|> "capture" :> Capture "name" String :> Raw
169 :<|> "body" :> Raw
203 :<|> "body" :> Raw
204+
170failApi :: Proxy FailApi
205failApi :: Proxy FailApi
171failApi = Proxy
206failApi = Proxy
172
207
173−failServer :: Application
208+failServer :: TestServer
174−failServer = serve failApi (
209+failServer = TestServer "failServer" $ serve failApi (
175 (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
210 (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
176 :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
211 :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
177− :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
212+ :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
178 )
213 )
179
214
180-- * basic auth stuff
215-- * basic auth stuff
@@ -196,8 +231,9 @@ basicAuthHandler =
196basicServerContext :: Context '[ BasicAuthCheck () ]
231basicServerContext :: Context '[ BasicAuthCheck () ]
197basicServerContext = basicAuthHandler :. EmptyContext
232basicServerContext = basicAuthHandler :. EmptyContext
198
233
199−basicAuthServer :: Application
234+basicAuthServer :: TestServer
235+basicAuthServer = TestServer "basicAuthServer" $
200−basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
236+ serveWithContext basicAuthAPI basicServerContext (const (return alice))
201
237
202-- * general auth stuff
238-- * general auth stuff
203
239
@@ -210,62 +246,63 @@ genAuthAPI = Proxy
210type instance AuthServerData (AuthProtect "auth-tag") = ()
246type instance AuthServerData (AuthProtect "auth-tag") = ()
211type instance AuthClientData (AuthProtect "auth-tag") = ()
247type instance AuthClientData (AuthProtect "auth-tag") = ()
212
248
213−genAuthHandler :: AuthHandler Request ()
249+genAuthHandler :: AuthHandler Wai.Request ()
214genAuthHandler =
250genAuthHandler =
215− let handler req = case lookup "AuthHeader" (requestHeaders req) of
251+ let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
216 Nothing -> throwE (err401 { errBody = "Missing auth header" })
252 Nothing -> throwE (err401 { errBody = "Missing auth header" })
217 Just _ -> return ()
253 Just _ -> return ()
218 in mkAuthHandler handler
254 in mkAuthHandler handler
219
255
220−genAuthServerContext :: Context '[ AuthHandler Request () ]
256+genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
221genAuthServerContext = genAuthHandler :. EmptyContext
257genAuthServerContext = genAuthHandler :. EmptyContext
222
258
223−genAuthServer :: Application
259+genAuthServer :: TestServer
260+genAuthServer = TestServer "genAuthServer" $
224−genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
261+ serveWithContext genAuthAPI genAuthServerContext (const (return alice))
225
262
226{-# NOINLINE manager #-}
263{-# NOINLINE manager #-}
227manager :: C.Manager
264manager :: C.Manager
228manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
265manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
229
266
230sucessSpec :: Spec
267sucessSpec :: Spec
231−sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
268+sucessSpec = around (withTestServer "server") $ do
232
269
233− it "Servant.API.Get" $ \(_, baseUrl) -> do
270+ it "Servant.API.Get" $ \baseUrl -> do
234 (left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice
271 (left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice
235
272
236 describe "Servant.API.Delete" $ do
273 describe "Servant.API.Delete" $ do
237− it "allows empty content type" $ \(_, baseUrl) -> do
274+ it "allows empty content type" $ \baseUrl -> do
238 (left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
275 (left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
239
276
240− it "allows content type" $ \(_, baseUrl) -> do
277+ it "allows content type" $ \baseUrl -> do
241 (left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
278 (left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
242
279
243− it "Servant.API.Capture" $ \(_, baseUrl) -> do
280+ it "Servant.API.Capture" $ \baseUrl -> do
244 (left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0)
281 (left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0)
245
282
246− it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
283+ it "Servant.API.CaptureAll" $ \baseUrl -> do
247 let expected = [(Person "Paula" 0), (Person "Peta" 1)]
284 let expected = [(Person "Paula" 0), (Person "Peta" 1)]
248 (left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected
285 (left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected
249
286
250− it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
287+ it "Servant.API.ReqBody" $ \baseUrl -> do
251 let p = Person "Clara" 42
288 let p = Person "Clara" 42
252 (left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p
289 (left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p
253
290
254− it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
291+ it "Servant.API.QueryParam" $ \baseUrl -> do
255 left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice
292 left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice
256 Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl)
293 Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl)
257 responseStatus `shouldBe` HTTP.Status 400 "bob not found"
294 responseStatus `shouldBe` HTTP.Status 400 "bob not found"
258
295
259− it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
296+ it "Servant.API.QueryParam.QueryParams" $ \baseUrl -> do
260 (left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right []
297 (left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right []
261 (left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl))
298 (left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl))
262 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
299 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
263
300
264 context "Servant.API.QueryParam.QueryFlag" $
301 context "Servant.API.QueryParam.QueryFlag" $
265− forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
302+ forM_ [False, True] $ \ flag -> it (show flag) $ \baseUrl -> do
266 (left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag
303 (left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag
267
304
268− it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
305+ it "Servant.API.Raw on success" $ \baseUrl -> do
269 res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl)
306 res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl)
270 case res of
307 case res of
271 Left e -> assertFailure $ show e
308 Left e -> assertFailure $ show e
@@ -274,7 +311,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
274 C.responseBody response `shouldBe` body
311 C.responseBody response `shouldBe` body
275 C.responseStatus response `shouldBe` HTTP.ok200
312 C.responseStatus response `shouldBe` HTTP.ok200
276
313
277− it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
314+ it "Servant.API.Raw should return a Left in case of failure" $ \baseUrl -> do
278 res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl)
315 res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl)
279 case res of
316 case res of
280 Right _ -> assertFailure "expected Left, but got Right"
317 Right _ -> assertFailure "expected Left, but got Right"
@@ -282,51 +319,93 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
282 Servant.Client.responseStatus e `shouldBe` HTTP.status400
319 Servant.Client.responseStatus e `shouldBe` HTTP.status400
283 Servant.Client.responseBody e `shouldBe` "rawFailure"
320 Servant.Client.responseBody e `shouldBe` "rawFailure"
284
321
285− it "Returns headers appropriately" $ \(_, baseUrl) -> do
322+ it "Returns headers appropriately" $ \baseUrl -> do
286 res <- runClientM getRespHeaders (ClientEnv manager baseUrl)
323 res <- runClientM getRespHeaders (ClientEnv manager baseUrl)
287 case res of
324 case res of
288 Left e -> assertFailure $ show e
325 Left e -> assertFailure $ show e
289 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
326 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
290
327
291 modifyMaxSuccess (const 20) $ do
328 modifyMaxSuccess (const 20) $ do
292− it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
329+ it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \baseUrl ->
293 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
330 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
294 ioProperty $ do
331 ioProperty $ do
295 result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl)
332 result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl)
296 return $
333 return $
297 result === Right (cap, num, flag, body)
334 result === Right (cap, num, flag, body)
298
335
336+type ErrorApi =
337+ Delete '[JSON] () :<|>
338+ Get '[JSON] () :<|>
339+ Post '[JSON] () :<|>
340+ Put '[JSON] ()
341+
342+errorApi :: Proxy ErrorApi
343+errorApi = Proxy
344+
345+errorServer :: TestServer
346+errorServer = TestServer "errorServer" $ serve errorApi $
347+ err :<|> err :<|> err :<|> err
348+ where
349+ err = throwE $ ServantErr 500 "error message" "" []
350+
351+errorSpec :: Spec
352+errorSpec =
353+ around (withTestServer "errorServer") $ do
354+ describe "error status codes" $
355+ it "reports error statuses correctly" $ \baseUrl -> do
356+ let delete :<|> get :<|> post :<|> put =
357+ client errorApi
358+ actions = [delete, get, post, put]
359+ forM_ actions $ \ clientAction -> do
360+ Left FailureResponse{..} <- runClientM clientAction (ClientEnv manager baseUrl)
361+ responseStatus `shouldBe` HTTP.Status 500 "error message"
362+
363+basicAuthSpec :: Spec
364+basicAuthSpec = around (withTestServer "basicAuthServer") $ do
365+ context "Authentication works when requests are properly authenticated" $ do
366+
367+ it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
368+ let getBasic = client basicAuthAPI
369+ let basicAuthData = BasicAuthData "servant" "server"
370+ (left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
371+
372+ context "Authentication is rejected when requests are not authenticated properly" $ do
373+
374+ it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
375+ let getBasic = client basicAuthAPI
376+ let basicAuthData = BasicAuthData "not" "password"
377+ Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)
378+ responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
379+
380+genAuthSpec :: Spec
381+genAuthSpec = around (withTestServer "genAuthServer") $ do
382+ context "Authentication works when requests are properly authenticated" $ do
383+
384+ it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
385+ let getProtected = client genAuthAPI
386+ let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
387+ (left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
299
388
300−wrappedApiSpec :: Spec
389+ context "Authentication is rejected when requests are not authenticated properly" $ do
301−wrappedApiSpec = describe "error status codes" $ do
390+
302− let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
391+ it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
303− context "are correctly handled by the client" $
392+ let getProtected = client genAuthAPI
304− let test :: (WrappedApi, String) -> Spec
393+ let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
305− test (WrappedApi api, desc) =
306− it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
307− let getResponse :: SCR.ClientM ()
308− getResponse = client api
309− Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl)
394+ Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl)
310− responseStatus `shouldBe` (HTTP.Status 500 "error message")
395+ responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
311− in mapM_ test $
312− (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
313− (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
314− (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
315− (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
316− []
317
396
318failSpec :: Spec
397failSpec :: Spec
319−failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
398+failSpec = around (withTestServer "failServer") $ do
320
399
321 context "client returns errors appropriately" $ do
400 context "client returns errors appropriately" $ do
322− it "reports FailureResponse" $ \(_, baseUrl) -> do
401+ it "reports FailureResponse" $ \baseUrl -> do
323 let (_ :<|> getDeleteEmpty :<|> _) = client api
402 let (_ :<|> getDeleteEmpty :<|> _) = client api
324 Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl)
403 Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl)
325 case res of
404 case res of
326 FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
405 FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
327 _ -> fail $ "expected 404 response, but got " <> show res
406 _ -> fail $ "expected 404 response, but got " <> show res
328
407
329− it "reports DecodeFailure" $ \(_, baseUrl) -> do
408+ it "reports DecodeFailure" $ \baseUrl -> do
330 let (_ :<|> _ :<|> getCapture :<|> _) = client api
409 let (_ :<|> _ :<|> getCapture :<|> _) = client api
331 Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl)
410 Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl)
332 case res of
411 case res of
@@ -340,81 +419,23 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
340 ConnectionError _ -> return ()
419 ConnectionError _ -> return ()
341 _ -> fail $ "expected ConnectionError, but got " <> show res
420 _ -> fail $ "expected ConnectionError, but got " <> show res
342
421
343− it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
422+ it "reports UnsupportedContentType" $ \baseUrl -> do
344 let (getGet :<|> _ ) = client api
423 let (getGet :<|> _ ) = client api
345 Left res <- runClientM getGet (ClientEnv manager baseUrl)
424 Left res <- runClientM getGet (ClientEnv manager baseUrl)
346 case res of
425 case res of
347 UnsupportedContentType ("application/octet-stream") _ -> return ()
426 UnsupportedContentType ("application/octet-stream") _ -> return ()
348 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
427 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
349
428
350− it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
429+ it "reports InvalidContentTypeHeader" $ \baseUrl -> do
351 let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
430 let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
352 Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl)
431 Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl)
432+
353 case res of
433 case res of
354 InvalidContentTypeHeader "fooooo" _ -> return ()
434 InvalidContentTypeHeader "fooooo" _ -> return ()
355 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
435 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
356
436
357−data WrappedApi where
358− WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
359− HasClient api, Client api ~ SCR.ClientM ()) =>
360− Proxy api -> WrappedApi
361−
362−basicAuthSpec :: Spec
363−basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
364− context "Authentication works when requests are properly authenticated" $ do
365−
366− it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
367− let getBasic = client basicAuthAPI
368− let basicAuthData = BasicAuthData "servant" "server"
369− (left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
370−
371− context "Authentication is rejected when requests are not authenticated properly" $ do
372−
373− it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
374− let getBasic = client basicAuthAPI
375− let basicAuthData = BasicAuthData "not" "password"
376− Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)
377− responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
378−
379−genAuthSpec :: Spec
380−genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
381− context "Authentication works when requests are properly authenticated" $ do
382−
383− it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
384− let getProtected = client genAuthAPI
385− let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
386− (left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
387−
388− context "Authentication is rejected when requests are not authenticated properly" $ do
389−
390− it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
391− let getProtected = client genAuthAPI
392− let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
393− Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl)
394− responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
395−
396-- * utils
437-- * utils
397
438
398−startWaiApp :: Application -> IO (ThreadId, BaseUrl)
399−startWaiApp app = do
400− (port, socket) <- openTestSocket
401− let settings = setPort port $ defaultSettings
402− thread <- forkIO $ runSettingsSocket settings socket app
403− return (thread, BaseUrl Http "localhost" port "")
404−
405−
406−endWaiApp :: (ThreadId, BaseUrl) -> IO ()
407−endWaiApp (thread, _) = killThread thread
408−
409−openTestSocket :: IO (Port, Socket)
410−openTestSocket = do
411− s <- socket AF_INET Stream defaultProtocol
412− localhost <- inet_addr "127.0.0.1"
413− bind s (SockAddrInet aNY_PORT localhost)
414− listen s 1
415− port <- socketPort s
416− return (fromIntegral port, s)
417−
418pathGen :: Gen (NonEmptyList Char)
439pathGen :: Gen (NonEmptyList Char)
419pathGen = fmap NonEmpty path
440pathGen = fmap NonEmpty path
420 where
441 where
servant-client/test/ghcjs/build-test-server.shnew file+10
@@ -0,0 +1,10 @@
1+#/usr/bin/env bash
2+
3+set -o errexit
4+
5+cd test/ghcjs/testServer
6+
7+unset STACK_YAML
8+stack setup
9+stack build
10+cp $(stack exec which testServer) .
servant-client/test/ghcjs/run-tests.shnew file+15
@@ -0,0 +1,15 @@
1+#!/usr/bin/env bash
2+
3+set -o errexit
4+
5+loc=$(dirname $0)
6+cd $loc
7+
8+cd ../../
9+
10+npm install xhr2
11+
12+export STACK_YAML=test/ghcjs/stack-ghcjs.yaml
13+stack setup
14+stack build
15+# stack test --fast
servant-client/test/ghcjs/stack-ghcjs.yamlnew file+22
@@ -0,0 +1,22 @@
1+# This file was added for being able to test ghcjs support
2+
3+packages:
4+ - location: ../../.
5+ - location: ../../../servant
6+ extra-dep: true
7+ - location: ../../../servant-server
8+ extra-dep: true
9+
10+resolver: lts-6.0
11+
12+compiler: ghcjs-0.2.0.20160414_ghc-7.10.3
13+compiler-check: match-exact
14+setup-info:
15+ ghcjs:
16+ source:
17+ ghcjs-0.2.0.20160414_ghc-7.10.3:
18+ url: https://s3.amazonaws.com/ghcjs/ghcjs-0.2.0.20160414_ghc-7.10.3.tar.gz
19+ sha1: 6d6f307503be9e94e0c96ef1308c7cf224d06be3
20+
21+extra-deps:
22+- http-api-data-0.3
servant-client/test/ghcjs/testServer/package.yamlnew file+36
@@ -0,0 +1,36 @@
1+name: testServer
2+
3+executables:
4+ testServer:
5+ main: testServer.hs
6+ other-modules: []
7+ dependencies:
8+ - base
9+ - base-compat
10+ - aeson
11+ - base64-bytestring
12+ - bytestring
13+ - exceptions
14+ - hspec
15+ - http-api-data
16+ - http-client
17+ - http-media
18+ - http-types
19+ - HUnit
20+ - network
21+ - network-uri
22+ - QuickCheck
23+ - safe
24+ - servant
25+ - servant-server
26+ - string-conversions
27+ - text
28+ - transformers
29+ - wai
30+ - warp
31+ source-dirs:
32+ - ./
33+ - ../../../test
34+ - ../../../src
35+ include-dirs:
36+ - ../../../include
servant-client/test/ghcjs/testServer/stack.yamlnew file+10
@@ -0,0 +1,10 @@
1+flags: {}
2+packages:
3+- location: ./.
4+- location: ../../../../
5+ subdirs:
6+ - servant
7+ - servant-client
8+ - servant-server
9+ extra-dep: true
10+resolver: lts-5.15
servant-client/test/ghcjs/testServer/testServer.cabalnew file+42
@@ -0,0 +1,42 @@
1+-- This file has been generated from package.yaml by hpack version 0.14.0.
2+--
3+-- see: https://github.com/sol/hpack
4+
5+name: testServer
6+version: 0.0.0
7+build-type: Simple
8+cabal-version: >= 1.10
9+
10+executable testServer
11+ main-is: testServer.hs
12+ hs-source-dirs:
13+ ./
14+ , ../../../test
15+ , ../../../src
16+ include-dirs:
17+ ../../../include
18+ build-depends:
19+ base
20+ , base-compat
21+ , aeson
22+ , base64-bytestring
23+ , bytestring
24+ , exceptions
25+ , hspec
26+ , http-api-data
27+ , http-client
28+ , http-media
29+ , http-types
30+ , HUnit
31+ , network
32+ , network-uri
33+ , QuickCheck
34+ , safe
35+ , servant
36+ , servant-server
37+ , string-conversions
38+ , text
39+ , transformers
40+ , wai
41+ , warp
42+ default-language: Haskell2010
servant-client/test/ghcjs/testServer/testServer.hsnew file+28
@@ -0,0 +1,28 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TypeOperators #-}
3+
4+import Network.Wai.Handler.Warp
5+import Servant
6+import System.IO
7+
8+import Servant.Client.TestServer.GHC
9+import Servant.Client.TestServer.Types
10+import Servant.ClientSpec
11+
12+main :: IO ()
13+main = do
14+ (port, socket) <- openTestSocket
15+ let settings =
16+ setPort port $
17+ setBeforeMainLoop (print port >> hFlush stdout) $
18+ defaultSettings
19+ runSettingsSocket settings socket $
20+ serve testServerApi $ \ testServerName request respond -> do
21+ app <- testServerApp <$> lookupTestServer testServerName
22+ app request respond
23+
24+type TestServerApi =
25+ Capture "testServerName" String :> Raw
26+
27+testServerApi :: Proxy TestServerApi
28+testServerApi = Proxy