git.iko.soy/servant
on a08b116 help sign in
aaeee88
swap
8 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
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+153−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,76 @@ 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 Servant.Client.TestServer.GHC
54+import qualified Servant.Common.Req as SCR
59import Servant.Server
55import Servant.Server
60import Servant.Server.Experimental.Auth
56import 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
57
66spec :: Spec
58spec :: Spec
59+spec = do
60+ runIO buildTestServer
67−spec = describe "Servant.Client" $ do
61+ describe "Servant.Client" $ do
68 sucessSpec
62 sucessSpec
69 failSpec
63 failSpec
70− wrappedApiSpec
71 basicAuthSpec
64 basicAuthSpec
72 genAuthSpec
65 genAuthSpec
66+ errorSpec
67+
68+-- | Run a test-server (identified by name) while performing the given action.
69+-- The provided 'BaseUrl' points to the running server.
70+--
71+-- Running the test-servers is done differently depending on the compiler
72+-- (ghc or ghcjs).
73+--
74+-- With ghc it's somewhat straight-forward: a wai 'Application' is being started
75+-- on a free port inside the same process using 'warp'.
76+--
77+-- When running the test-suite with ghcjs all the test-servers are compiled into
78+-- a single external executable (with ghc and warp). This is done through
79+-- 'buildTestServer' once at the start of the test-suite. This built executable
80+-- will provide all the test-servers on a free port under a path that
81+-- corresponds to the test-servers name, for example under
82+-- 'http://localhost:82923/failServer'. 'withTestServer' will then
83+-- start this executable as an external process while the given action is being
84+-- executed and provide it with the correct BaseUrl.
85+-- This rather cumbersome approach is taken because it's not easy to run a wai
86+-- Application as a http server when using ghcjs.
87+withTestServer :: String -> (BaseUrl -> IO a) -> IO a
88+withTestServer name action = do
89+ server <- lookupTestServer name
90+ withServer server action
91+
92+lookupTestServer :: String -> IO TestServer
93+lookupTestServer name = case lookup name mapping of
94+ Nothing -> die ("test server not found: " ++ name)
95+ Just testServer -> return testServer
96+ where
97+ mapping :: [(String, TestServer)]
98+ mapping = map (\ server -> (testServerName server, server)) allTestServers
99+
100+-- | All test-servers must be registered here.
101+allTestServers :: [TestServer]
102+allTestServers =
103+ server :
104+ errorServer :
105+ failServer :
106+ basicAuthServer :
107+ genAuthServer :
108+ []
73
109
74-- * test data types
110-- * test data types
75
111
@@ -120,9 +156,9 @@ getBody :: Person -> SCR.ClientM Person
120getQueryParam :: Maybe String -> SCR.ClientM Person
156getQueryParam :: Maybe String -> SCR.ClientM Person
121getQueryParams :: [String] -> SCR.ClientM [Person]
157getQueryParams :: [String] -> SCR.ClientM [Person]
122getQueryFlag :: Bool -> SCR.ClientM Bool
158getQueryFlag :: Bool -> SCR.ClientM Bool
123−getRawSuccess :: HTTP.Method
159+getRawSuccess :: HTTP.Method
124 -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
160 -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
125−getRawFailure :: HTTP.Method
161+getRawFailure :: HTTP.Method
126 -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
162 -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
127getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
163getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
128 -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])])
164 -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])])
@@ -142,8 +178,8 @@ getGet
142 :<|> getRespHeaders
178 :<|> getRespHeaders
143 :<|> getDeleteContentType = client api
179 :<|> getDeleteContentType = client api
144
180
145−server :: Application
181+server :: TestServer
146−server = serve api (
182+server = TestServer "server" $ serve api (
147 return alice
183 return alice
148 :<|> return NoContent
184 :<|> return NoContent
149 :<|> (\ name -> return $ Person name 0)
185 :<|> (\ name -> return $ Person name 0)
@@ -162,19 +198,19 @@ server = serve api (
162 :<|> return NoContent
198 :<|> return NoContent
163 )
199 )
164
200
165−
166type FailApi =
201type FailApi =
167 "get" :> Raw
202 "get" :> Raw
168 :<|> "capture" :> Capture "name" String :> Raw
203 :<|> "capture" :> Capture "name" String :> Raw
169 :<|> "body" :> Raw
204 :<|> "body" :> Raw
205+
170failApi :: Proxy FailApi
206failApi :: Proxy FailApi
171failApi = Proxy
207failApi = Proxy
172
208
173−failServer :: Application
209+failServer :: TestServer
174−failServer = serve failApi (
210+failServer = TestServer "failServer" $ serve failApi (
175 (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
211 (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
176 :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
212 :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
177− :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
213+ :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
178 )
214 )
179
215
180-- * basic auth stuff
216-- * basic auth stuff
@@ -196,8 +232,9 @@ basicAuthHandler =
196basicServerContext :: Context '[ BasicAuthCheck () ]
232basicServerContext :: Context '[ BasicAuthCheck () ]
197basicServerContext = basicAuthHandler :. EmptyContext
233basicServerContext = basicAuthHandler :. EmptyContext
198
234
199−basicAuthServer :: Application
235+basicAuthServer :: TestServer
236+basicAuthServer = TestServer "basicAuthServer" $
200−basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
237+ serveWithContext basicAuthAPI basicServerContext (const (return alice))
201
238
202-- * general auth stuff
239-- * general auth stuff
203
240
@@ -210,62 +247,63 @@ genAuthAPI = Proxy
210type instance AuthServerData (AuthProtect "auth-tag") = ()
247type instance AuthServerData (AuthProtect "auth-tag") = ()
211type instance AuthClientData (AuthProtect "auth-tag") = ()
248type instance AuthClientData (AuthProtect "auth-tag") = ()
212
249
213−genAuthHandler :: AuthHandler Request ()
250+genAuthHandler :: AuthHandler Wai.Request ()
214genAuthHandler =
251genAuthHandler =
215− let handler req = case lookup "AuthHeader" (requestHeaders req) of
252+ let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
216 Nothing -> throwE (err401 { errBody = "Missing auth header" })
253 Nothing -> throwE (err401 { errBody = "Missing auth header" })
217 Just _ -> return ()
254 Just _ -> return ()
218 in mkAuthHandler handler
255 in mkAuthHandler handler
219
256
220−genAuthServerContext :: Context '[ AuthHandler Request () ]
257+genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
221genAuthServerContext = genAuthHandler :. EmptyContext
258genAuthServerContext = genAuthHandler :. EmptyContext
222
259
223−genAuthServer :: Application
260+genAuthServer :: TestServer
261+genAuthServer = TestServer "genAuthServer" $
224−genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
262+ serveWithContext genAuthAPI genAuthServerContext (const (return alice))
225
263
226{-# NOINLINE manager #-}
264{-# NOINLINE manager #-}
227manager :: C.Manager
265manager :: C.Manager
228manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
266manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
229
267
230sucessSpec :: Spec
268sucessSpec :: Spec
231−sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
269+sucessSpec = around (withTestServer "server") $ do
232
270
233− it "Servant.API.Get" $ \(_, baseUrl) -> do
271+ it "Servant.API.Get" $ \baseUrl -> do
234 (left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice
272 (left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice
235
273
236 describe "Servant.API.Delete" $ do
274 describe "Servant.API.Delete" $ do
237− it "allows empty content type" $ \(_, baseUrl) -> do
275+ it "allows empty content type" $ \baseUrl -> do
238 (left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
276 (left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
239
277
240− it "allows content type" $ \(_, baseUrl) -> do
278+ it "allows content type" $ \baseUrl -> do
241 (left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
279 (left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
242
280
243− it "Servant.API.Capture" $ \(_, baseUrl) -> do
281+ it "Servant.API.Capture" $ \baseUrl -> do
244 (left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0)
282 (left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0)
245
283
246− it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
284+ it "Servant.API.CaptureAll" $ \baseUrl -> do
247 let expected = [(Person "Paula" 0), (Person "Peta" 1)]
285 let expected = [(Person "Paula" 0), (Person "Peta" 1)]
248 (left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected
286 (left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected
249
287
250− it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
288+ it "Servant.API.ReqBody" $ \baseUrl -> do
251 let p = Person "Clara" 42
289 let p = Person "Clara" 42
252 (left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p
290 (left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p
253
291
254− it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
292+ it "Servant.API.QueryParam" $ \baseUrl -> do
255 left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice
293 left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice
256 Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl)
294 Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl)
257 responseStatus `shouldBe` HTTP.Status 400 "bob not found"
295 responseStatus `shouldBe` HTTP.Status 400 "bob not found"
258
296
259− it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
297+ it "Servant.API.QueryParam.QueryParams" $ \baseUrl -> do
260 (left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right []
298 (left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right []
261 (left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl))
299 (left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl))
262 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
300 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
263
301
264 context "Servant.API.QueryParam.QueryFlag" $
302 context "Servant.API.QueryParam.QueryFlag" $
265− forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
303+ forM_ [False, True] $ \ flag -> it (show flag) $ \baseUrl -> do
266 (left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag
304 (left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag
267
305
268− it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
306+ it "Servant.API.Raw on success" $ \baseUrl -> do
269 res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl)
307 res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl)
270 case res of
308 case res of
271 Left e -> assertFailure $ show e
309 Left e -> assertFailure $ show e
@@ -274,7 +312,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
274 C.responseBody response `shouldBe` body
312 C.responseBody response `shouldBe` body
275 C.responseStatus response `shouldBe` HTTP.ok200
313 C.responseStatus response `shouldBe` HTTP.ok200
276
314
277− it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
315+ it "Servant.API.Raw should return a Left in case of failure" $ \baseUrl -> do
278 res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl)
316 res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl)
279 case res of
317 case res of
280 Right _ -> assertFailure "expected Left, but got Right"
318 Right _ -> assertFailure "expected Left, but got Right"
@@ -282,51 +320,93 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
282 Servant.Client.responseStatus e `shouldBe` HTTP.status400
320 Servant.Client.responseStatus e `shouldBe` HTTP.status400
283 Servant.Client.responseBody e `shouldBe` "rawFailure"
321 Servant.Client.responseBody e `shouldBe` "rawFailure"
284
322
285− it "Returns headers appropriately" $ \(_, baseUrl) -> do
323+ it "Returns headers appropriately" $ \baseUrl -> do
286 res <- runClientM getRespHeaders (ClientEnv manager baseUrl)
324 res <- runClientM getRespHeaders (ClientEnv manager baseUrl)
287 case res of
325 case res of
288 Left e -> assertFailure $ show e
326 Left e -> assertFailure $ show e
289 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
327 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
290
328
291 modifyMaxSuccess (const 20) $ do
329 modifyMaxSuccess (const 20) $ do
292− it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
330+ it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \baseUrl ->
293 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
331 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
294 ioProperty $ do
332 ioProperty $ do
295 result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl)
333 result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl)
296 return $
334 return $
297 result === Right (cap, num, flag, body)
335 result === Right (cap, num, flag, body)
298
336
337+type ErrorApi =
338+ Delete '[JSON] () :<|>
339+ Get '[JSON] () :<|>
340+ Post '[JSON] () :<|>
341+ Put '[JSON] ()
342+
343+errorApi :: Proxy ErrorApi
344+errorApi = Proxy
345+
346+errorServer :: TestServer
347+errorServer = TestServer "errorServer" $ serve errorApi $
348+ err :<|> err :<|> err :<|> err
349+ where
350+ err = throwE $ ServantErr 500 "error message" "" []
351+
352+errorSpec :: Spec
353+errorSpec =
354+ around (withTestServer "errorServer") $ do
355+ describe "error status codes" $
356+ it "reports error statuses correctly" $ \baseUrl -> do
357+ let delete :<|> get :<|> post :<|> put =
358+ client errorApi
359+ actions = [delete, get, post, put]
360+ forM_ actions $ \ clientAction -> do
361+ Left FailureResponse{..} <- runClientM clientAction (ClientEnv manager baseUrl)
362+ responseStatus `shouldBe` HTTP.Status 500 "error message"
363+
364+basicAuthSpec :: Spec
365+basicAuthSpec = around (withTestServer "basicAuthServer") $ do
366+ context "Authentication works when requests are properly authenticated" $ do
367+
368+ it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
369+ let getBasic = client basicAuthAPI
370+ let basicAuthData = BasicAuthData "servant" "server"
371+ (left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
372+
373+ context "Authentication is rejected when requests are not authenticated properly" $ do
374+
375+ it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
376+ let getBasic = client basicAuthAPI
377+ let basicAuthData = BasicAuthData "not" "password"
378+ Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)
379+ responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
380+
381+genAuthSpec :: Spec
382+genAuthSpec = around (withTestServer "genAuthServer") $ do
383+ context "Authentication works when requests are properly authenticated" $ do
384+
385+ it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
386+ let getProtected = client genAuthAPI
387+ let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
388+ (left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
299
389
300−wrappedApiSpec :: Spec
390+ context "Authentication is rejected when requests are not authenticated properly" $ do
301−wrappedApiSpec = describe "error status codes" $ do
391+
302− let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
392+ it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
303− context "are correctly handled by the client" $
393+ let getProtected = client genAuthAPI
304− let test :: (WrappedApi, String) -> Spec
394+ 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)
395+ Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl)
310− responseStatus `shouldBe` (HTTP.Status 500 "error message")
396+ 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
397
318failSpec :: Spec
398failSpec :: Spec
319−failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
399+failSpec = around (withTestServer "failServer") $ do
320
400
321 context "client returns errors appropriately" $ do
401 context "client returns errors appropriately" $ do
322− it "reports FailureResponse" $ \(_, baseUrl) -> do
402+ it "reports FailureResponse" $ \baseUrl -> do
323 let (_ :<|> getDeleteEmpty :<|> _) = client api
403 let (_ :<|> getDeleteEmpty :<|> _) = client api
324 Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl)
404 Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl)
325 case res of
405 case res of
326 FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
406 FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
327 _ -> fail $ "expected 404 response, but got " <> show res
407 _ -> fail $ "expected 404 response, but got " <> show res
328
408
329− it "reports DecodeFailure" $ \(_, baseUrl) -> do
409+ it "reports DecodeFailure" $ \baseUrl -> do
330 let (_ :<|> _ :<|> getCapture :<|> _) = client api
410 let (_ :<|> _ :<|> getCapture :<|> _) = client api
331 Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl)
411 Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl)
332 case res of
412 case res of
@@ -340,81 +420,23 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
340 ConnectionError _ -> return ()
420 ConnectionError _ -> return ()
341 _ -> fail $ "expected ConnectionError, but got " <> show res
421 _ -> fail $ "expected ConnectionError, but got " <> show res
342
422
343− it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
423+ it "reports UnsupportedContentType" $ \baseUrl -> do
344 let (getGet :<|> _ ) = client api
424 let (getGet :<|> _ ) = client api
345 Left res <- runClientM getGet (ClientEnv manager baseUrl)
425 Left res <- runClientM getGet (ClientEnv manager baseUrl)
346 case res of
426 case res of
347 UnsupportedContentType ("application/octet-stream") _ -> return ()
427 UnsupportedContentType ("application/octet-stream") _ -> return ()
348 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
428 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
349
429
350− it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
430+ it "reports InvalidContentTypeHeader" $ \baseUrl -> do
351 let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
431 let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
352 Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl)
432 Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl)
433+
353 case res of
434 case res of
354 InvalidContentTypeHeader "fooooo" _ -> return ()
435 InvalidContentTypeHeader "fooooo" _ -> return ()
355 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
436 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
356
437
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
438-- * utils
397
439
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)
440pathGen :: Gen (NonEmptyList Char)
419pathGen = fmap NonEmpty path
441pathGen = fmap NonEmpty path
420 where
442 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+14
@@ -0,0 +1,14 @@
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 test --fast
servant-client/test/ghcjs/stack-ghcjs.yamlnew file+26
@@ -0,0 +1,26 @@
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-5.12
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+ - hspec-expectations-0.7.2
23+ - hspec-discover-2.2.1
24+ - http-api-data-0.1.1.1
25+ - hspec-2.2.1
26+ - hspec-core-2.2.1
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