Compare commits
14 commits
Author | SHA1 | Date | |
---|---|---|---|
|
e740390b16 | ||
|
a604a00c00 | ||
|
1d19c25bd7 | ||
|
a62c8c7a30 | ||
|
38926ca1d7 | ||
|
5f070634cc | ||
|
a08b116715 | ||
|
798d9e8967 | ||
|
2082abf17b | ||
|
187fe5b139 | ||
|
6c5afe8fb3 | ||
|
cd22bf759e | ||
|
0c8bd4b1a8 | ||
|
5c91864ee4 |
23 changed files with 834 additions and 187 deletions
2
.gitignore
vendored
2
.gitignore
vendored
|
@ -29,3 +29,5 @@ doc/_build
|
||||||
doc/venv
|
doc/venv
|
||||||
doc/tutorial/static/api.js
|
doc/tutorial/static/api.js
|
||||||
doc/tutorial/static/jq.js
|
doc/tutorial/static/jq.js
|
||||||
|
servant-client/node_modules/
|
||||||
|
servant-client/test/ghcjs/testServer/testServer
|
||||||
|
|
|
@ -19,6 +19,7 @@ install:
|
||||||
- stack --version
|
- stack --version
|
||||||
- stack setup --no-terminal
|
- stack setup --no-terminal
|
||||||
- (cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
|
- (cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
|
||||||
|
- if [ "$STACK_YAML" = "stack.yaml" ] ; then (cd servant-client/test/ghcjs/ && ./run-tests.sh) ; fi
|
||||||
|
|
||||||
script:
|
script:
|
||||||
- if [ "$TRAVIS_EVENT_TYPE" = "cron" ] ; then ./scripts/ci-cron.sh ; else stack test --ghc-options=-Werror --no-terminal ; fi
|
- if [ "$TRAVIS_EVENT_TYPE" = "cron" ] ; then ./scripts/ci-cron.sh ; else stack test --ghc-options=-Werror --no-terminal ; fi
|
||||||
|
|
51
GHCJS.md
Normal file
51
GHCJS.md
Normal file
|
@ -0,0 +1,51 @@
|
||||||
|
# Support for ghcjs
|
||||||
|
|
||||||
|
This branch of servant implements experimental support for
|
||||||
|
[ghcjs](https://github.com/ghcjs/ghcjs) for `servant-client`.
|
||||||
|
This means it allows you to write Haskell code in terms of `servant-client`,
|
||||||
|
compile it with `ghcjs` to javascript and then use it to execute XHRs from a
|
||||||
|
browser. The idea is that this should work transparently for the programmer,
|
||||||
|
i.e. from a user's perspective it should work exactly as it does when compiled
|
||||||
|
with `ghc`.
|
||||||
|
|
||||||
|
## Status
|
||||||
|
|
||||||
|
This branch is experimental.
|
||||||
|
|
||||||
|
Known caveats:
|
||||||
|
|
||||||
|
- Sending bodies in requests doesn't work when using methods `GET` and `HEAD`.
|
||||||
|
At least when running the test-suite with node. `GET` and `HEAD` requests are
|
||||||
|
not supposed to have request bodies and [xhr2](https://www.npmjs.com/package/xhr2)
|
||||||
|
-- which we use to issue XHRs from node -- discards the request bodies for `GET` and
|
||||||
|
`HEAD` requests. (This might actually work in some browsers, no clue.) This causes one
|
||||||
|
failing test in the test-suite.
|
||||||
|
- We don't have CI for running the test-suite with `ghcjs`. We tried to make
|
||||||
|
that work, but failed miserably. That's the main reason why this is not merged
|
||||||
|
to `master`.
|
||||||
|
- `servant-client` uses libraries that are not optimized for `ghcjs`. I haven't
|
||||||
|
investigated this much, but I could imagine that e.g. a native javascript JSON
|
||||||
|
parser would be much faster than `aeson` compiled by `ghcjs`.
|
||||||
|
|
||||||
|
## Getting it to work
|
||||||
|
|
||||||
|
The `stack` file that is used to run the test-suite with `ghcjs` may provide
|
||||||
|
some inspiration: `servant-client/test/ghcjs/stack-ghcjs.yaml`.
|
||||||
|
|
||||||
|
## Running the tests
|
||||||
|
|
||||||
|
You can run the tests by doing:
|
||||||
|
|
||||||
|
``` bash
|
||||||
|
./servant-client/test/ghcjs/run-tests.sh
|
||||||
|
```
|
||||||
|
|
||||||
|
## Further development
|
||||||
|
|
||||||
|
I propose to use the branch `client-ghcjs` as a place for further development
|
||||||
|
on `ghcjs` support for `servant-client`. We could
|
||||||
|
|
||||||
|
- create PRs against the branch,
|
||||||
|
- for releases on `master` merge `master` into this branch to not fall behind,
|
||||||
|
- maybe even create tags, e.g. `ghcjs-v0.6` and `ghcjs-v0.7.1` to give people
|
||||||
|
fixed commits to stick to.
|
|
@ -34,6 +34,15 @@ library
|
||||||
Servant.Common.BaseUrl
|
Servant.Common.BaseUrl
|
||||||
Servant.Common.BasicAuth
|
Servant.Common.BasicAuth
|
||||||
Servant.Common.Req
|
Servant.Common.Req
|
||||||
|
other-modules:
|
||||||
|
Servant.Client.PerformRequest
|
||||||
|
Servant.Client.PerformRequest.Base
|
||||||
|
if impl(ghcjs)
|
||||||
|
other-modules:
|
||||||
|
Servant.Client.PerformRequest.GHCJS
|
||||||
|
else
|
||||||
|
other-modules:
|
||||||
|
Servant.Client.PerformRequest.GHC
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.7 && < 4.10
|
base >= 4.7 && < 4.10
|
||||||
, aeson >= 0.7 && < 1.1
|
, aeson >= 0.7 && < 1.1
|
||||||
|
@ -54,6 +63,11 @@ library
|
||||||
, transformers >= 0.3 && < 0.6
|
, transformers >= 0.3 && < 0.6
|
||||||
, transformers-compat >= 0.4 && < 0.6
|
, transformers-compat >= 0.4 && < 0.6
|
||||||
, mtl
|
, mtl
|
||||||
|
if impl(ghcjs)
|
||||||
|
build-depends:
|
||||||
|
ghcjs-base
|
||||||
|
, ghcjs-prim
|
||||||
|
, case-insensitive
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
|
@ -63,31 +77,59 @@ library
|
||||||
|
|
||||||
test-suite spec
|
test-suite spec
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall -fno-warn-name-shadowing
|
||||||
|
if impl(ghc >= 8.0)
|
||||||
|
ghc-options: -Wno-redundant-constraints
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
hs-source-dirs: test
|
hs-source-dirs: test, src
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
other-modules:
|
other-modules:
|
||||||
Servant.ClientSpec
|
Servant.ClientSpec
|
||||||
|
, Servant.Client.PerformRequest.GHCJSSpec
|
||||||
|
, Servant.Client.TestServer
|
||||||
|
, Servant.Client.TestServer.Types
|
||||||
|
, Servant.Common.BaseUrl
|
||||||
, Servant.Common.BaseUrlSpec
|
, Servant.Common.BaseUrlSpec
|
||||||
|
, Spec
|
||||||
|
if impl(ghcjs)
|
||||||
|
other-modules:
|
||||||
|
Servant.Client.TestServer.GHCJS
|
||||||
|
else
|
||||||
|
other-modules:
|
||||||
|
Servant.Client.TestServer.GHC
|
||||||
build-depends:
|
build-depends:
|
||||||
base == 4.*
|
base == 4.*
|
||||||
|
, base-compat
|
||||||
, transformers
|
, transformers
|
||||||
, transformers-compat
|
, transformers-compat
|
||||||
, aeson
|
, aeson
|
||||||
|
, base64-bytestring
|
||||||
, bytestring
|
, bytestring
|
||||||
, deepseq
|
, deepseq
|
||||||
, hspec == 2.*
|
, hspec >= 2.2.1 && < 2.3
|
||||||
, http-api-data
|
, http-api-data
|
||||||
, http-client
|
, http-client
|
||||||
, http-media
|
, http-media
|
||||||
, http-types
|
, http-types
|
||||||
, HUnit
|
, HUnit
|
||||||
|
, mtl
|
||||||
, network >= 2.6
|
, network >= 2.6
|
||||||
, QuickCheck >= 2.7
|
, QuickCheck >= 2.7
|
||||||
, servant == 0.9.*
|
, servant == 0.9.*
|
||||||
, servant-client
|
|
||||||
, servant-server == 0.9.*
|
, servant-server == 0.9.*
|
||||||
, text
|
, text
|
||||||
, wai
|
, wai
|
||||||
, warp
|
, warp
|
||||||
|
, mockery
|
||||||
|
, safe
|
||||||
|
, process
|
||||||
|
, http-api-data
|
||||||
|
, network-uri
|
||||||
|
, exceptions
|
||||||
|
, string-conversions
|
||||||
|
if impl(ghcjs)
|
||||||
|
build-depends:
|
||||||
|
ghcjs-base
|
||||||
|
, ghcjs-prim
|
||||||
|
, case-insensitive
|
||||||
|
include-dirs: include
|
||||||
|
|
|
@ -45,6 +45,7 @@ import Servant.Client.Experimental.Auth
|
||||||
import Servant.Common.BaseUrl
|
import Servant.Common.BaseUrl
|
||||||
import Servant.Common.BasicAuth
|
import Servant.Common.BasicAuth
|
||||||
import Servant.Common.Req
|
import Servant.Common.Req
|
||||||
|
import Servant.Client.PerformRequest (ServantError(..))
|
||||||
|
|
||||||
-- * Accessing APIs as a Client
|
-- * Accessing APIs as a Client
|
||||||
|
|
||||||
|
|
13
servant-client/src/Servant/Client/PerformRequest.hs
Normal file
13
servant-client/src/Servant/Client/PerformRequest.hs
Normal file
|
@ -0,0 +1,13 @@
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
|
||||||
|
module Servant.Client.PerformRequest (
|
||||||
|
ServantError(..),
|
||||||
|
performHttpRequest,
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Servant.Client.PerformRequest.Base
|
||||||
|
#ifdef __GHCJS__
|
||||||
|
import Servant.Client.PerformRequest.GHCJS
|
||||||
|
#else
|
||||||
|
import Servant.Client.PerformRequest.GHC
|
||||||
|
#endif
|
48
servant-client/src/Servant/Client/PerformRequest/Base.hs
Normal file
48
servant-client/src/Servant/Client/PerformRequest/Base.hs
Normal file
|
@ -0,0 +1,48 @@
|
||||||
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
|
|
||||||
|
module Servant.Client.PerformRequest.Base where
|
||||||
|
|
||||||
|
import Control.Exception
|
||||||
|
import Data.ByteString.Lazy
|
||||||
|
import Data.Typeable
|
||||||
|
import Network.HTTP.Media
|
||||||
|
import Network.HTTP.Types
|
||||||
|
|
||||||
|
data ServantError
|
||||||
|
= FailureResponse
|
||||||
|
{ responseStatus :: Status
|
||||||
|
, responseContentType :: MediaType
|
||||||
|
, responseBody :: ByteString
|
||||||
|
}
|
||||||
|
| DecodeFailure
|
||||||
|
{ decodeError :: String
|
||||||
|
, responseContentType :: MediaType
|
||||||
|
, responseBody :: ByteString
|
||||||
|
}
|
||||||
|
| UnsupportedContentType
|
||||||
|
{ responseContentType :: MediaType
|
||||||
|
, responseBody :: ByteString
|
||||||
|
}
|
||||||
|
| InvalidContentTypeHeader
|
||||||
|
{ responseContentTypeHeader :: ByteString
|
||||||
|
, responseBody :: ByteString
|
||||||
|
}
|
||||||
|
| ConnectionError
|
||||||
|
{ connectionError :: SomeException
|
||||||
|
}
|
||||||
|
deriving (Show, Typeable)
|
||||||
|
|
||||||
|
instance Eq ServantError where
|
||||||
|
FailureResponse a b c == FailureResponse x y z =
|
||||||
|
(a, b, c) == (x, y, z)
|
||||||
|
DecodeFailure a b c == DecodeFailure x y z =
|
||||||
|
(a, b, c) == (x, y, z)
|
||||||
|
UnsupportedContentType a b == UnsupportedContentType x y =
|
||||||
|
(a, b) == (x, y)
|
||||||
|
InvalidContentTypeHeader a b == InvalidContentTypeHeader x y =
|
||||||
|
(a, b) == (x, y)
|
||||||
|
ConnectionError a == ConnectionError x =
|
||||||
|
show a == show x
|
||||||
|
_ == _ = False
|
||||||
|
|
||||||
|
instance Exception ServantError
|
29
servant-client/src/Servant/Client/PerformRequest/GHC.hs
Normal file
29
servant-client/src/Servant/Client/PerformRequest/GHC.hs
Normal file
|
@ -0,0 +1,29 @@
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||||
|
|
||||||
|
module Servant.Client.PerformRequest.GHC (
|
||||||
|
ServantError(..),
|
||||||
|
performHttpRequest,
|
||||||
|
) where
|
||||||
|
|
||||||
|
#if !MIN_VERSION_base(4,8,0)
|
||||||
|
import Control.Applicative
|
||||||
|
#endif
|
||||||
|
import Control.Exception
|
||||||
|
import qualified Data.ByteString.Lazy as LBS
|
||||||
|
import Network.HTTP.Client
|
||||||
|
|
||||||
|
import Servant.Client.PerformRequest.Base
|
||||||
|
|
||||||
|
performHttpRequest :: Manager -> Request
|
||||||
|
-> IO (Either ServantError (Response LBS.ByteString))
|
||||||
|
performHttpRequest manager request =
|
||||||
|
catchConnectionError $ httpLbs request manager
|
||||||
|
|
||||||
|
catchConnectionError :: IO a -> IO (Either ServantError a)
|
||||||
|
catchConnectionError action =
|
||||||
|
catch (Right <$> action) $ \e ->
|
||||||
|
pure . Left . ConnectionError $ SomeException (e :: HttpException)
|
190
servant-client/src/Servant/Client/PerformRequest/GHCJS.hs
Normal file
190
servant-client/src/Servant/Client/PerformRequest/GHCJS.hs
Normal file
|
@ -0,0 +1,190 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||||
|
|
||||||
|
module Servant.Client.PerformRequest.GHCJS (
|
||||||
|
ServantError(..),
|
||||||
|
performHttpRequest,
|
||||||
|
|
||||||
|
-- exported for testing
|
||||||
|
parseHeaders,
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Arrow
|
||||||
|
import Control.Concurrent
|
||||||
|
import Control.Exception
|
||||||
|
import Control.Monad
|
||||||
|
import qualified Data.ByteString.Char8 as BS
|
||||||
|
import qualified Data.ByteString.Lazy as LBS
|
||||||
|
import Data.CaseInsensitive
|
||||||
|
import Data.Char
|
||||||
|
import Data.String.Conversions
|
||||||
|
import Foreign.StablePtr
|
||||||
|
import GHCJS.Foreign.Callback
|
||||||
|
import GHCJS.Prim
|
||||||
|
import Network.HTTP.Client
|
||||||
|
import Network.HTTP.Client.Internal as HttpClient
|
||||||
|
import Network.HTTP.Types
|
||||||
|
import Servant.Client.PerformRequest.Base
|
||||||
|
|
||||||
|
newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
|
||||||
|
|
||||||
|
newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
|
||||||
|
|
||||||
|
performHttpRequest :: Manager -> Request -> IO (Either ServantError (Response LBS.ByteString))
|
||||||
|
performHttpRequest _ request = do
|
||||||
|
xhr <- initXhr
|
||||||
|
performXhr xhr request
|
||||||
|
toResponse xhr
|
||||||
|
|
||||||
|
-- * initialization
|
||||||
|
|
||||||
|
initXhr :: IO JSXMLHttpRequest
|
||||||
|
initXhr = do
|
||||||
|
lib <- requireXMLHttpRequestClass
|
||||||
|
newXMLHttpRequest lib
|
||||||
|
|
||||||
|
foreign import javascript unsafe
|
||||||
|
-- branching between node (for testing) and browsers
|
||||||
|
"(function () {if (typeof require !== 'undefined') { return require('xhr2'); } else { return XMLHttpRequest; };})()"
|
||||||
|
requireXMLHttpRequestClass :: IO JSXMLHttpRequestClass
|
||||||
|
|
||||||
|
foreign import javascript unsafe "new $1()"
|
||||||
|
newXMLHttpRequest :: JSXMLHttpRequestClass -> IO JSXMLHttpRequest
|
||||||
|
|
||||||
|
-- * performing requests
|
||||||
|
|
||||||
|
-- Performs the xhr and blocks until the response was received
|
||||||
|
performXhr :: JSXMLHttpRequest -> Request -> IO ()
|
||||||
|
performXhr xhr request = do
|
||||||
|
waiter <- newEmptyMVar
|
||||||
|
|
||||||
|
bracket (acquire waiter) releaseCallback $ \_callback -> do
|
||||||
|
t <- myThreadId
|
||||||
|
s <- newStablePtr t
|
||||||
|
|
||||||
|
openXhr xhr (cs $ method request) (toUrl request) True
|
||||||
|
setHeaders xhr (requestHeaders request)
|
||||||
|
sendXhr xhr (toBody request)
|
||||||
|
takeMVar waiter
|
||||||
|
|
||||||
|
freeStablePtr s
|
||||||
|
where
|
||||||
|
acquire waiter = onReadyStateChange xhr $ do
|
||||||
|
state <- readyState xhr
|
||||||
|
case state of
|
||||||
|
-- onReadyStateChange's callback can fire state 4
|
||||||
|
-- (which means "request finished and response is ready")
|
||||||
|
-- multiple times. By using tryPutMVar, only the first time
|
||||||
|
-- state 4 is fired will cause an MVar to be put. Subsequent
|
||||||
|
-- fires are ignored.
|
||||||
|
4 -> tryPutMVar waiter () >> return ()
|
||||||
|
_ -> return ()
|
||||||
|
|
||||||
|
onReadyStateChange :: JSXMLHttpRequest -> IO () -> IO (Callback (IO ()))
|
||||||
|
onReadyStateChange xhr action = do
|
||||||
|
callback <- asyncCallback action
|
||||||
|
js_onReadyStateChange xhr callback
|
||||||
|
return callback
|
||||||
|
foreign import javascript safe "$1.onreadystatechange = $2;"
|
||||||
|
js_onReadyStateChange :: JSXMLHttpRequest -> Callback (IO ()) -> IO ()
|
||||||
|
|
||||||
|
foreign import javascript unsafe "$1.readyState"
|
||||||
|
readyState :: JSXMLHttpRequest -> IO Int
|
||||||
|
|
||||||
|
openXhr :: JSXMLHttpRequest -> String -> String -> Bool -> IO ()
|
||||||
|
openXhr xhr method url async =
|
||||||
|
js_openXhr xhr (toJSString method) (toJSString url) async
|
||||||
|
foreign import javascript unsafe "$1.open($2, $3, $4)"
|
||||||
|
js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
|
||||||
|
|
||||||
|
toUrl :: Request -> String
|
||||||
|
toUrl request =
|
||||||
|
let protocol = if secure request then "https" else "http"
|
||||||
|
hostS = cs $ host request
|
||||||
|
portS = show $ port request
|
||||||
|
pathS = cs $ path request
|
||||||
|
queryS = cs $ queryString request
|
||||||
|
in protocol ++ "://" ++ hostS ++ ":" ++ portS ++ pathS ++ queryS
|
||||||
|
|
||||||
|
setHeaders :: JSXMLHttpRequest -> RequestHeaders -> IO ()
|
||||||
|
setHeaders xhr headers = forM_ headers $ \ (key, value) ->
|
||||||
|
js_setRequestHeader xhr (toJSString $ cs $ original key) (toJSString $ cs value)
|
||||||
|
foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
|
||||||
|
js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
|
||||||
|
|
||||||
|
sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()
|
||||||
|
sendXhr xhr Nothing = js_sendXhr xhr
|
||||||
|
sendXhr xhr (Just body) =
|
||||||
|
js_sendXhrWithBody xhr (toJSString body)
|
||||||
|
foreign import javascript unsafe "$1.send()"
|
||||||
|
js_sendXhr :: JSXMLHttpRequest -> IO ()
|
||||||
|
foreign import javascript unsafe "$1.send($2)"
|
||||||
|
js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
|
||||||
|
|
||||||
|
toBody :: Request -> Maybe String
|
||||||
|
toBody request = case requestBody request of
|
||||||
|
RequestBodyLBS "" -> Nothing
|
||||||
|
RequestBodyLBS x -> Just $ cs x
|
||||||
|
_ -> error "servant-client only uses RequestBodyLBS"
|
||||||
|
|
||||||
|
-- * inspecting the xhr response
|
||||||
|
|
||||||
|
-- This function is only supposed to handle 'ConnectionError's. Other
|
||||||
|
-- 'ServantError's are created in Servant.Client.Req.
|
||||||
|
toResponse :: JSXMLHttpRequest -> IO (Either ServantError (Response LBS.ByteString))
|
||||||
|
toResponse xhr = do
|
||||||
|
status <- getStatus xhr
|
||||||
|
case status of
|
||||||
|
0 -> return $ Left $ ConnectionError $ SomeException $ ErrorCall "connection error"
|
||||||
|
_ -> do
|
||||||
|
statusText <- cs <$> getStatusText xhr
|
||||||
|
headers <- parseHeaders <$> getAllResponseHeaders xhr
|
||||||
|
responseText <- cs <$> getResponseText xhr
|
||||||
|
return $ Right $ Response {
|
||||||
|
HttpClient.responseStatus = mkStatus status statusText,
|
||||||
|
responseVersion = http11, -- this is made up
|
||||||
|
responseHeaders = headers,
|
||||||
|
HttpClient.responseBody = responseText,
|
||||||
|
responseCookieJar = mempty,
|
||||||
|
responseClose' = ResponseClose (return ())
|
||||||
|
}
|
||||||
|
|
||||||
|
foreign import javascript unsafe "$1.status"
|
||||||
|
getStatus :: JSXMLHttpRequest -> IO Int
|
||||||
|
|
||||||
|
getStatusText :: JSXMLHttpRequest -> IO String
|
||||||
|
getStatusText = fmap fromJSString . js_statusText
|
||||||
|
foreign import javascript unsafe "$1.statusText"
|
||||||
|
js_statusText :: JSXMLHttpRequest -> IO JSVal
|
||||||
|
|
||||||
|
getAllResponseHeaders :: JSXMLHttpRequest -> IO String
|
||||||
|
getAllResponseHeaders xhr =
|
||||||
|
fromJSString <$> js_getAllResponseHeaders xhr
|
||||||
|
foreign import javascript unsafe "$1.getAllResponseHeaders()"
|
||||||
|
js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
|
||||||
|
|
||||||
|
getResponseText :: JSXMLHttpRequest -> IO String
|
||||||
|
getResponseText xhr = fromJSString <$> js_responseText xhr
|
||||||
|
foreign import javascript unsafe "$1.responseText"
|
||||||
|
js_responseText :: JSXMLHttpRequest -> IO JSVal
|
||||||
|
|
||||||
|
parseHeaders :: String -> ResponseHeaders
|
||||||
|
parseHeaders s =
|
||||||
|
fmap (first mk) $
|
||||||
|
fmap (first strip . second strip) $
|
||||||
|
fmap parseHeader $
|
||||||
|
splitOn "\r\n" (cs s)
|
||||||
|
where
|
||||||
|
parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)
|
||||||
|
parseHeader h = case BS.breakSubstring ":" (cs h) of
|
||||||
|
(key, (BS.drop 1 -> value)) -> (key, value)
|
||||||
|
|
||||||
|
splitOn :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
|
||||||
|
splitOn separator input = case BS.breakSubstring separator input of
|
||||||
|
(prefix, "") -> [prefix]
|
||||||
|
(prefix, rest) -> prefix : splitOn separator (BS.drop (BS.length separator) rest)
|
||||||
|
|
||||||
|
strip :: BS.ByteString -> BS.ByteString
|
||||||
|
strip = BS.dropWhile isSpace . BS.reverse . BS.dropWhile isSpace . BS.reverse
|
|
@ -5,6 +5,10 @@
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
|
||||||
|
#if MIN_VERSION_base(4,9,0)
|
||||||
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||||
|
#endif
|
||||||
|
|
||||||
module Servant.Common.Req where
|
module Servant.Common.Req where
|
||||||
|
|
||||||
#if !MIN_VERSION_base(4,8,0)
|
#if !MIN_VERSION_base(4,8,0)
|
||||||
|
@ -31,57 +35,17 @@ import Data.String.Conversions
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text.Encoding
|
import Data.Text.Encoding
|
||||||
import Data.Typeable
|
import Network.HTTP.Client hiding (Proxy, path)
|
||||||
import Network.HTTP.Media
|
import Network.HTTP.Media
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
import Network.HTTP.Client hiding (Proxy, path)
|
|
||||||
import qualified Network.HTTP.Types.Header as HTTP
|
import qualified Network.HTTP.Types.Header as HTTP
|
||||||
import Network.URI hiding (path)
|
import Network.URI hiding (path)
|
||||||
import Servant.API.ContentTypes
|
import Servant.API.ContentTypes
|
||||||
|
import Servant.Client.PerformRequest
|
||||||
import Servant.Common.BaseUrl
|
import Servant.Common.BaseUrl
|
||||||
|
|
||||||
import qualified Network.HTTP.Client as Client
|
|
||||||
|
|
||||||
import Web.HttpApiData
|
import Web.HttpApiData
|
||||||
|
|
||||||
data ServantError
|
import qualified Network.HTTP.Client as Client
|
||||||
= FailureResponse
|
|
||||||
{ responseStatus :: Status
|
|
||||||
, responseContentType :: MediaType
|
|
||||||
, responseBody :: ByteString
|
|
||||||
}
|
|
||||||
| DecodeFailure
|
|
||||||
{ decodeError :: String
|
|
||||||
, responseContentType :: MediaType
|
|
||||||
, responseBody :: ByteString
|
|
||||||
}
|
|
||||||
| UnsupportedContentType
|
|
||||||
{ responseContentType :: MediaType
|
|
||||||
, responseBody :: ByteString
|
|
||||||
}
|
|
||||||
| InvalidContentTypeHeader
|
|
||||||
{ responseContentTypeHeader :: ByteString
|
|
||||||
, responseBody :: ByteString
|
|
||||||
}
|
|
||||||
| ConnectionError
|
|
||||||
{ connectionError :: SomeException
|
|
||||||
}
|
|
||||||
deriving (Show, Typeable)
|
|
||||||
|
|
||||||
instance Eq ServantError where
|
|
||||||
FailureResponse a b c == FailureResponse x y z =
|
|
||||||
(a, b, c) == (x, y, z)
|
|
||||||
DecodeFailure a b c == DecodeFailure x y z =
|
|
||||||
(a, b, c) == (x, y, z)
|
|
||||||
UnsupportedContentType a b == UnsupportedContentType x y =
|
|
||||||
(a, b) == (x, y)
|
|
||||||
InvalidContentTypeHeader a b == InvalidContentTypeHeader x y =
|
|
||||||
(a, b) == (x, y)
|
|
||||||
ConnectionError a == ConnectionError x =
|
|
||||||
show a == show x
|
|
||||||
_ == _ = False
|
|
||||||
|
|
||||||
instance Exception ServantError
|
|
||||||
|
|
||||||
data Req = Req
|
data Req = Req
|
||||||
{ reqPath :: String
|
{ reqPath :: String
|
||||||
|
@ -192,7 +156,7 @@ performRequest reqMethod req = do
|
||||||
|
|
||||||
let request = partialRequest { Client.method = reqMethod }
|
let request = partialRequest { Client.method = reqMethod }
|
||||||
|
|
||||||
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
|
eResponse <- liftIO $ performHttpRequest m request
|
||||||
case eResponse of
|
case eResponse of
|
||||||
Left err ->
|
Left err ->
|
||||||
throwError . ConnectionError $ SomeException err
|
throwError . ConnectionError $ SomeException err
|
||||||
|
@ -226,8 +190,3 @@ performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
|
||||||
performRequestNoBody reqMethod req = do
|
performRequestNoBody reqMethod req = do
|
||||||
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
|
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
|
||||||
return hdrs
|
return hdrs
|
||||||
|
|
||||||
catchConnectionError :: IO a -> IO (Either ServantError a)
|
|
||||||
catchConnectionError action =
|
|
||||||
catch (Right <$> action) $ \e ->
|
|
||||||
pure . Left . ConnectionError $ SomeException (e :: HttpException)
|
|
||||||
|
|
|
@ -0,0 +1,29 @@
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Servant.Client.PerformRequest.GHCJSSpec where
|
||||||
|
|
||||||
|
import Test.Hspec
|
||||||
|
|
||||||
|
#ifdef __GHCJS__
|
||||||
|
|
||||||
|
import Servant.Client.PerformRequest.GHCJS
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = do
|
||||||
|
describe "parseHeaders" $ do
|
||||||
|
it "parses single headers" $ do
|
||||||
|
parseHeaders "key: value" `shouldBe` [("key", "value")]
|
||||||
|
|
||||||
|
it "parses multiple headers" $ do
|
||||||
|
parseHeaders "foo: bar\r\nnext: yay" `shouldBe`
|
||||||
|
[("foo", "bar"), ("next", "yay")]
|
||||||
|
|
||||||
|
it "handles colons in header values correctly" $ do
|
||||||
|
parseHeaders "foo: bar:baz" `shouldBe` [("foo", "bar:baz")]
|
||||||
|
|
||||||
|
#else
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = return ()
|
||||||
|
#endif
|
15
servant-client/test/Servant/Client/TestServer.hs
Normal file
15
servant-client/test/Servant/Client/TestServer.hs
Normal file
|
@ -0,0 +1,15 @@
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
|
||||||
|
module Servant.Client.TestServer (
|
||||||
|
buildTestServer,
|
||||||
|
TestServer(..),
|
||||||
|
withServer,
|
||||||
|
) where
|
||||||
|
|
||||||
|
#ifdef __GHCJS__
|
||||||
|
import Servant.Client.TestServer.GHCJS
|
||||||
|
#else
|
||||||
|
import Servant.Client.TestServer.GHC
|
||||||
|
#endif
|
||||||
|
|
||||||
|
import Servant.Client.TestServer.Types
|
39
servant-client/test/Servant/Client/TestServer/GHC.hs
Normal file
39
servant-client/test/Servant/Client/TestServer/GHC.hs
Normal file
|
@ -0,0 +1,39 @@
|
||||||
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||||
|
|
||||||
|
module Servant.Client.TestServer.GHC where
|
||||||
|
|
||||||
|
import Control.Concurrent
|
||||||
|
import Control.Exception
|
||||||
|
import Network.Socket
|
||||||
|
import Network.Wai
|
||||||
|
import Network.Wai.Handler.Warp
|
||||||
|
|
||||||
|
import Servant.Common.BaseUrl
|
||||||
|
import Servant.Client.TestServer.Types
|
||||||
|
|
||||||
|
buildTestServer :: IO ()
|
||||||
|
buildTestServer = return ()
|
||||||
|
|
||||||
|
withServer :: TestServer -> (BaseUrl -> IO a) -> IO a
|
||||||
|
withServer (TestServer _ app) action =
|
||||||
|
bracket (startWaiApp app) endWaiApp $ \ (_, url) ->
|
||||||
|
action url
|
||||||
|
|
||||||
|
startWaiApp :: Application -> IO (ThreadId, BaseUrl)
|
||||||
|
startWaiApp app = do
|
||||||
|
(port, socket) <- openTestSocket
|
||||||
|
let settings = setPort port $ defaultSettings
|
||||||
|
thread <- forkIO $ runSettingsSocket settings socket app
|
||||||
|
return (thread, BaseUrl Http "localhost" port "")
|
||||||
|
|
||||||
|
endWaiApp :: (ThreadId, BaseUrl) -> IO ()
|
||||||
|
endWaiApp (thread, _) = killThread thread
|
||||||
|
|
||||||
|
openTestSocket :: IO (Port, Socket)
|
||||||
|
openTestSocket = do
|
||||||
|
s <- socket AF_INET Stream defaultProtocol
|
||||||
|
localhost <- inet_addr "127.0.0.1"
|
||||||
|
bind s (SockAddrInet aNY_PORT localhost)
|
||||||
|
listen s 1
|
||||||
|
port <- socketPort s
|
||||||
|
return (fromIntegral port, s)
|
34
servant-client/test/Servant/Client/TestServer/GHCJS.hs
Normal file
34
servant-client/test/Servant/Client/TestServer/GHCJS.hs
Normal file
|
@ -0,0 +1,34 @@
|
||||||
|
|
||||||
|
module Servant.Client.TestServer.GHCJS where
|
||||||
|
|
||||||
|
import Control.Exception
|
||||||
|
import Safe
|
||||||
|
import System.Exit
|
||||||
|
import System.IO
|
||||||
|
import System.Process
|
||||||
|
|
||||||
|
import Servant.Client.TestServer.Types
|
||||||
|
import Servant.Common.BaseUrl
|
||||||
|
|
||||||
|
buildTestServer :: IO ()
|
||||||
|
buildTestServer = do
|
||||||
|
process <- spawnProcess "./test/ghcjs/build-test-server.sh" []
|
||||||
|
ExitSuccess <- waitForProcess process
|
||||||
|
return ()
|
||||||
|
|
||||||
|
withServer :: TestServer -> (BaseUrl -> IO a) -> IO a
|
||||||
|
withServer (TestServer testServerName _) action = do
|
||||||
|
bracket start stop $ \ (port, _) -> action (BaseUrl Http "localhost" port ("/" ++ testServerName))
|
||||||
|
where
|
||||||
|
start :: IO (Int, ProcessHandle)
|
||||||
|
start = do
|
||||||
|
(Nothing, Just stdout, Nothing, process) <- createProcess $ (proc "./test/ghcjs/testServer/testServer" []) {
|
||||||
|
std_out = CreatePipe
|
||||||
|
}
|
||||||
|
line <- hGetLine stdout
|
||||||
|
case readMay line :: Maybe Int of
|
||||||
|
Nothing -> die ("unparseable port: " ++ show line)
|
||||||
|
Just port -> return (port, process)
|
||||||
|
stop (_, process) = do
|
||||||
|
terminateProcess process
|
||||||
|
waitForProcess process
|
10
servant-client/test/Servant/Client/TestServer/Types.hs
Normal file
10
servant-client/test/Servant/Client/TestServer/Types.hs
Normal file
|
@ -0,0 +1,10 @@
|
||||||
|
|
||||||
|
module Servant.Client.TestServer.Types where
|
||||||
|
|
||||||
|
import Network.Wai
|
||||||
|
|
||||||
|
data TestServer
|
||||||
|
= TestServer {
|
||||||
|
testServerName :: String,
|
||||||
|
testServerApp :: Application
|
||||||
|
}
|
|
@ -1,5 +1,4 @@
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
@ -11,7 +10,6 @@
|
||||||
{-# LANGUAGE PolyKinds #-}
|
{-# LANGUAGE PolyKinds #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
@ -21,17 +19,13 @@
|
||||||
{-# OPTIONS_GHC -fcontext-stack=100 #-}
|
{-# OPTIONS_GHC -fcontext-stack=100 #-}
|
||||||
#endif
|
#endif
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
|
||||||
|
|
||||||
#include "overlapping-compat.h"
|
|
||||||
module Servant.ClientSpec where
|
module Servant.ClientSpec where
|
||||||
|
|
||||||
#if !MIN_VERSION_base(4,8,0)
|
import Prelude ()
|
||||||
import Control.Applicative ((<$>))
|
import Prelude.Compat
|
||||||
#endif
|
|
||||||
import Control.Arrow (left)
|
import Control.Arrow (left)
|
||||||
import Control.Concurrent (forkIO, killThread, ThreadId)
|
|
||||||
import Control.Exception (bracket)
|
|
||||||
import Control.Monad.Trans.Except (throwE )
|
import Control.Monad.Trans.Except (throwE )
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import qualified Data.ByteString.Lazy as BS
|
import qualified Data.ByteString.Lazy as BS
|
||||||
|
@ -43,33 +37,74 @@ import GHC.Generics (Generic)
|
||||||
import qualified Network.HTTP.Client as C
|
import qualified Network.HTTP.Client as C
|
||||||
import Network.HTTP.Media
|
import Network.HTTP.Media
|
||||||
import qualified Network.HTTP.Types as HTTP
|
import qualified Network.HTTP.Types as HTTP
|
||||||
import Network.Socket
|
import Network.Wai (responseLBS)
|
||||||
import Network.Wai (Request, requestHeaders, responseLBS)
|
import qualified Network.Wai as Wai
|
||||||
import Network.Wai.Handler.Warp
|
import System.Exit.Compat
|
||||||
import System.IO.Unsafe (unsafePerformIO)
|
import System.IO.Unsafe (unsafePerformIO)
|
||||||
|
import Test.HUnit
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
import Test.Hspec.QuickCheck
|
import Test.Hspec.QuickCheck
|
||||||
import Test.HUnit
|
|
||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
import Web.FormUrlEncoded (FromForm, ToForm)
|
import Web.FormUrlEncoded (FromForm, ToForm)
|
||||||
|
|
||||||
import Servant.API
|
import Servant.API
|
||||||
import Servant.API.Internal.Test.ComprehensiveAPI
|
|
||||||
import Servant.Client
|
import Servant.Client
|
||||||
|
import Servant.Client.TestServer
|
||||||
|
import qualified Servant.Common.Req as SCR
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
import Servant.Server.Experimental.Auth
|
import Servant.Server.Experimental.Auth
|
||||||
import qualified Servant.Common.Req as SCR
|
|
||||||
|
|
||||||
-- This declaration simply checks that all instances are in place.
|
|
||||||
_ = client comprehensiveAPI
|
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = describe "Servant.Client" $ do
|
spec = do
|
||||||
|
runIO buildTestServer
|
||||||
|
describe "Servant.Client" $ do
|
||||||
sucessSpec
|
sucessSpec
|
||||||
failSpec
|
failSpec
|
||||||
wrappedApiSpec
|
|
||||||
basicAuthSpec
|
basicAuthSpec
|
||||||
genAuthSpec
|
genAuthSpec
|
||||||
|
errorSpec
|
||||||
|
|
||||||
|
-- | Run a test-server (identified by name) while performing the given action.
|
||||||
|
-- The provided 'BaseUrl' points to the running server.
|
||||||
|
--
|
||||||
|
-- Running the test-servers is done differently depending on the compiler
|
||||||
|
-- (ghc or ghcjs).
|
||||||
|
--
|
||||||
|
-- With ghc it's somewhat straight-forward: a wai 'Application' is being started
|
||||||
|
-- on a free port inside the same process using 'warp'.
|
||||||
|
--
|
||||||
|
-- When running the test-suite with ghcjs all the test-servers are compiled into
|
||||||
|
-- a single external executable (with ghc and warp). This is done through
|
||||||
|
-- 'buildTestServer' once at the start of the test-suite. This built executable
|
||||||
|
-- will provide all the test-servers on a free port under a path that
|
||||||
|
-- corresponds to the test-servers name, for example under
|
||||||
|
-- 'http://localhost:82923/failServer'. 'withTestServer' will then
|
||||||
|
-- start this executable as an external process while the given action is being
|
||||||
|
-- executed and provide it with the correct BaseUrl.
|
||||||
|
-- This rather cumbersome approach is taken because it's not easy to run a wai
|
||||||
|
-- Application as a http server when using ghcjs.
|
||||||
|
withTestServer :: String -> (BaseUrl -> IO a) -> IO a
|
||||||
|
withTestServer name action = do
|
||||||
|
server <- lookupTestServer name
|
||||||
|
withServer server action
|
||||||
|
|
||||||
|
lookupTestServer :: String -> IO TestServer
|
||||||
|
lookupTestServer name = case lookup name mapping of
|
||||||
|
Nothing -> die ("test server not found: " ++ name)
|
||||||
|
Just testServer -> return testServer
|
||||||
|
where
|
||||||
|
mapping :: [(String, TestServer)]
|
||||||
|
mapping = map (\ server -> (testServerName server, server)) allTestServers
|
||||||
|
|
||||||
|
-- | All test-servers must be registered here.
|
||||||
|
allTestServers :: [TestServer]
|
||||||
|
allTestServers =
|
||||||
|
server :
|
||||||
|
errorServer :
|
||||||
|
failServer :
|
||||||
|
basicAuthServer :
|
||||||
|
genAuthServer :
|
||||||
|
[]
|
||||||
|
|
||||||
-- * test data types
|
-- * test data types
|
||||||
|
|
||||||
|
@ -142,8 +177,8 @@ getGet
|
||||||
:<|> getRespHeaders
|
:<|> getRespHeaders
|
||||||
:<|> getDeleteContentType = client api
|
:<|> getDeleteContentType = client api
|
||||||
|
|
||||||
server :: Application
|
server :: TestServer
|
||||||
server = serve api (
|
server = TestServer "server" $ serve api (
|
||||||
return alice
|
return alice
|
||||||
:<|> return NoContent
|
:<|> return NoContent
|
||||||
:<|> (\ name -> return $ Person name 0)
|
:<|> (\ name -> return $ Person name 0)
|
||||||
|
@ -162,19 +197,19 @@ server = serve api (
|
||||||
:<|> return NoContent
|
:<|> return NoContent
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
type FailApi =
|
type FailApi =
|
||||||
"get" :> Raw
|
"get" :> Raw
|
||||||
:<|> "capture" :> Capture "name" String :> Raw
|
:<|> "capture" :> Capture "name" String :> Raw
|
||||||
:<|> "body" :> Raw
|
:<|> "body" :> Raw
|
||||||
|
|
||||||
failApi :: Proxy FailApi
|
failApi :: Proxy FailApi
|
||||||
failApi = Proxy
|
failApi = Proxy
|
||||||
|
|
||||||
failServer :: Application
|
failServer :: TestServer
|
||||||
failServer = serve failApi (
|
failServer = TestServer "failServer" $ serve failApi (
|
||||||
(\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
|
(\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
|
||||||
:<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
|
:<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
|
||||||
:<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
|
:<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
|
||||||
)
|
)
|
||||||
|
|
||||||
-- * basic auth stuff
|
-- * basic auth stuff
|
||||||
|
@ -196,8 +231,9 @@ basicAuthHandler =
|
||||||
basicServerContext :: Context '[ BasicAuthCheck () ]
|
basicServerContext :: Context '[ BasicAuthCheck () ]
|
||||||
basicServerContext = basicAuthHandler :. EmptyContext
|
basicServerContext = basicAuthHandler :. EmptyContext
|
||||||
|
|
||||||
basicAuthServer :: Application
|
basicAuthServer :: TestServer
|
||||||
basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
|
basicAuthServer = TestServer "basicAuthServer" $
|
||||||
|
serveWithContext basicAuthAPI basicServerContext (const (return alice))
|
||||||
|
|
||||||
-- * general auth stuff
|
-- * general auth stuff
|
||||||
|
|
||||||
|
@ -210,62 +246,63 @@ genAuthAPI = Proxy
|
||||||
type instance AuthServerData (AuthProtect "auth-tag") = ()
|
type instance AuthServerData (AuthProtect "auth-tag") = ()
|
||||||
type instance AuthClientData (AuthProtect "auth-tag") = ()
|
type instance AuthClientData (AuthProtect "auth-tag") = ()
|
||||||
|
|
||||||
genAuthHandler :: AuthHandler Request ()
|
genAuthHandler :: AuthHandler Wai.Request ()
|
||||||
genAuthHandler =
|
genAuthHandler =
|
||||||
let handler req = case lookup "AuthHeader" (requestHeaders req) of
|
let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
|
||||||
Nothing -> throwE (err401 { errBody = "Missing auth header" })
|
Nothing -> throwE (err401 { errBody = "Missing auth header" })
|
||||||
Just _ -> return ()
|
Just _ -> return ()
|
||||||
in mkAuthHandler handler
|
in mkAuthHandler handler
|
||||||
|
|
||||||
genAuthServerContext :: Context '[ AuthHandler Request () ]
|
genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
|
||||||
genAuthServerContext = genAuthHandler :. EmptyContext
|
genAuthServerContext = genAuthHandler :. EmptyContext
|
||||||
|
|
||||||
genAuthServer :: Application
|
genAuthServer :: TestServer
|
||||||
genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
|
genAuthServer = TestServer "genAuthServer" $
|
||||||
|
serveWithContext genAuthAPI genAuthServerContext (const (return alice))
|
||||||
|
|
||||||
{-# NOINLINE manager #-}
|
{-# NOINLINE manager #-}
|
||||||
manager :: C.Manager
|
manager :: C.Manager
|
||||||
manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
|
manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
|
||||||
|
|
||||||
sucessSpec :: Spec
|
sucessSpec :: Spec
|
||||||
sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
sucessSpec = around (withTestServer "server") $ do
|
||||||
|
|
||||||
it "Servant.API.Get" $ \(_, baseUrl) -> do
|
it "Servant.API.Get" $ \baseUrl -> do
|
||||||
(left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice
|
(left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice
|
||||||
|
|
||||||
describe "Servant.API.Delete" $ do
|
describe "Servant.API.Delete" $ do
|
||||||
it "allows empty content type" $ \(_, baseUrl) -> do
|
it "allows empty content type" $ \baseUrl -> do
|
||||||
(left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
|
(left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
|
||||||
|
|
||||||
it "allows content type" $ \(_, baseUrl) -> do
|
it "allows content type" $ \baseUrl -> do
|
||||||
(left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
|
(left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
|
||||||
|
|
||||||
it "Servant.API.Capture" $ \(_, baseUrl) -> do
|
it "Servant.API.Capture" $ \baseUrl -> do
|
||||||
(left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0)
|
(left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0)
|
||||||
|
|
||||||
it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
|
it "Servant.API.CaptureAll" $ \baseUrl -> do
|
||||||
let expected = [(Person "Paula" 0), (Person "Peta" 1)]
|
let expected = [(Person "Paula" 0), (Person "Peta" 1)]
|
||||||
(left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected
|
(left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected
|
||||||
|
|
||||||
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
|
it "Servant.API.ReqBody" $ \baseUrl -> do
|
||||||
let p = Person "Clara" 42
|
let p = Person "Clara" 42
|
||||||
(left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p
|
(left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p
|
||||||
|
|
||||||
it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
|
it "Servant.API.QueryParam" $ \baseUrl -> do
|
||||||
left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice
|
left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice
|
||||||
Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl)
|
Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl)
|
||||||
responseStatus `shouldBe` HTTP.Status 400 "bob not found"
|
responseStatus `shouldBe` HTTP.Status 400 "bob not found"
|
||||||
|
|
||||||
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
|
it "Servant.API.QueryParam.QueryParams" $ \baseUrl -> do
|
||||||
(left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right []
|
(left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right []
|
||||||
(left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl))
|
(left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl))
|
||||||
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
|
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
|
||||||
|
|
||||||
context "Servant.API.QueryParam.QueryFlag" $
|
context "Servant.API.QueryParam.QueryFlag" $
|
||||||
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
|
forM_ [False, True] $ \ flag -> it (show flag) $ \baseUrl -> do
|
||||||
(left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag
|
(left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag
|
||||||
|
|
||||||
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
|
it "Servant.API.Raw on success" $ \baseUrl -> do
|
||||||
res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl)
|
res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl)
|
||||||
case res of
|
case res of
|
||||||
Left e -> assertFailure $ show e
|
Left e -> assertFailure $ show e
|
||||||
|
@ -274,7 +311,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
||||||
C.responseBody response `shouldBe` body
|
C.responseBody response `shouldBe` body
|
||||||
C.responseStatus response `shouldBe` HTTP.ok200
|
C.responseStatus response `shouldBe` HTTP.ok200
|
||||||
|
|
||||||
it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
|
it "Servant.API.Raw should return a Left in case of failure" $ \baseUrl -> do
|
||||||
res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl)
|
res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl)
|
||||||
case res of
|
case res of
|
||||||
Right _ -> assertFailure "expected Left, but got Right"
|
Right _ -> assertFailure "expected Left, but got Right"
|
||||||
|
@ -282,51 +319,93 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
||||||
Servant.Client.responseStatus e `shouldBe` HTTP.status400
|
Servant.Client.responseStatus e `shouldBe` HTTP.status400
|
||||||
Servant.Client.responseBody e `shouldBe` "rawFailure"
|
Servant.Client.responseBody e `shouldBe` "rawFailure"
|
||||||
|
|
||||||
it "Returns headers appropriately" $ \(_, baseUrl) -> do
|
it "Returns headers appropriately" $ \baseUrl -> do
|
||||||
res <- runClientM getRespHeaders (ClientEnv manager baseUrl)
|
res <- runClientM getRespHeaders (ClientEnv manager baseUrl)
|
||||||
case res of
|
case res of
|
||||||
Left e -> assertFailure $ show e
|
Left e -> assertFailure $ show e
|
||||||
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
|
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
|
||||||
|
|
||||||
modifyMaxSuccess (const 20) $ do
|
modifyMaxSuccess (const 20) $ do
|
||||||
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
|
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \baseUrl ->
|
||||||
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
|
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
|
||||||
ioProperty $ do
|
ioProperty $ do
|
||||||
result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl)
|
result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl)
|
||||||
return $
|
return $
|
||||||
result === Right (cap, num, flag, body)
|
result === Right (cap, num, flag, body)
|
||||||
|
|
||||||
|
type ErrorApi =
|
||||||
|
Delete '[JSON] () :<|>
|
||||||
|
Get '[JSON] () :<|>
|
||||||
|
Post '[JSON] () :<|>
|
||||||
|
Put '[JSON] ()
|
||||||
|
|
||||||
wrappedApiSpec :: Spec
|
errorApi :: Proxy ErrorApi
|
||||||
wrappedApiSpec = describe "error status codes" $ do
|
errorApi = Proxy
|
||||||
let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
|
|
||||||
context "are correctly handled by the client" $
|
errorServer :: TestServer
|
||||||
let test :: (WrappedApi, String) -> Spec
|
errorServer = TestServer "errorServer" $ serve errorApi $
|
||||||
test (WrappedApi api, desc) =
|
err :<|> err :<|> err :<|> err
|
||||||
it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
|
where
|
||||||
let getResponse :: SCR.ClientM ()
|
err = throwE $ ServantErr 500 "error message" "" []
|
||||||
getResponse = client api
|
|
||||||
Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl)
|
errorSpec :: Spec
|
||||||
responseStatus `shouldBe` (HTTP.Status 500 "error message")
|
errorSpec =
|
||||||
in mapM_ test $
|
around (withTestServer "errorServer") $ do
|
||||||
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
|
describe "error status codes" $
|
||||||
(WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
|
it "reports error statuses correctly" $ \baseUrl -> do
|
||||||
(WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
|
let delete :<|> get :<|> post :<|> put =
|
||||||
(WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
|
client errorApi
|
||||||
[]
|
actions = [delete, get, post, put]
|
||||||
|
forM_ actions $ \ clientAction -> do
|
||||||
|
Left FailureResponse{..} <- runClientM clientAction (ClientEnv manager baseUrl)
|
||||||
|
responseStatus `shouldBe` HTTP.Status 500 "error message"
|
||||||
|
|
||||||
|
basicAuthSpec :: Spec
|
||||||
|
basicAuthSpec = around (withTestServer "basicAuthServer") $ do
|
||||||
|
context "Authentication works when requests are properly authenticated" $ do
|
||||||
|
|
||||||
|
it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
|
||||||
|
let getBasic = client basicAuthAPI
|
||||||
|
let basicAuthData = BasicAuthData "servant" "server"
|
||||||
|
(left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
|
||||||
|
|
||||||
|
context "Authentication is rejected when requests are not authenticated properly" $ do
|
||||||
|
|
||||||
|
it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
|
||||||
|
let getBasic = client basicAuthAPI
|
||||||
|
let basicAuthData = BasicAuthData "not" "password"
|
||||||
|
Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)
|
||||||
|
responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
|
||||||
|
|
||||||
|
genAuthSpec :: Spec
|
||||||
|
genAuthSpec = around (withTestServer "genAuthServer") $ do
|
||||||
|
context "Authentication works when requests are properly authenticated" $ do
|
||||||
|
|
||||||
|
it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
|
||||||
|
let getProtected = client genAuthAPI
|
||||||
|
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
|
||||||
|
(left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
|
||||||
|
|
||||||
|
context "Authentication is rejected when requests are not authenticated properly" $ do
|
||||||
|
|
||||||
|
it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
|
||||||
|
let getProtected = client genAuthAPI
|
||||||
|
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
|
||||||
|
Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl)
|
||||||
|
responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
|
||||||
|
|
||||||
failSpec :: Spec
|
failSpec :: Spec
|
||||||
failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
|
failSpec = around (withTestServer "failServer") $ do
|
||||||
|
|
||||||
context "client returns errors appropriately" $ do
|
context "client returns errors appropriately" $ do
|
||||||
it "reports FailureResponse" $ \(_, baseUrl) -> do
|
it "reports FailureResponse" $ \baseUrl -> do
|
||||||
let (_ :<|> getDeleteEmpty :<|> _) = client api
|
let (_ :<|> getDeleteEmpty :<|> _) = client api
|
||||||
Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl)
|
Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl)
|
||||||
case res of
|
case res of
|
||||||
FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
|
FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
|
||||||
_ -> fail $ "expected 404 response, but got " <> show res
|
_ -> fail $ "expected 404 response, but got " <> show res
|
||||||
|
|
||||||
it "reports DecodeFailure" $ \(_, baseUrl) -> do
|
it "reports DecodeFailure" $ \baseUrl -> do
|
||||||
let (_ :<|> _ :<|> getCapture :<|> _) = client api
|
let (_ :<|> _ :<|> getCapture :<|> _) = client api
|
||||||
Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl)
|
Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl)
|
||||||
case res of
|
case res of
|
||||||
|
@ -340,81 +419,23 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
|
||||||
ConnectionError _ -> return ()
|
ConnectionError _ -> return ()
|
||||||
_ -> fail $ "expected ConnectionError, but got " <> show res
|
_ -> fail $ "expected ConnectionError, but got " <> show res
|
||||||
|
|
||||||
it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
|
it "reports UnsupportedContentType" $ \baseUrl -> do
|
||||||
let (getGet :<|> _ ) = client api
|
let (getGet :<|> _ ) = client api
|
||||||
Left res <- runClientM getGet (ClientEnv manager baseUrl)
|
Left res <- runClientM getGet (ClientEnv manager baseUrl)
|
||||||
case res of
|
case res of
|
||||||
UnsupportedContentType ("application/octet-stream") _ -> return ()
|
UnsupportedContentType ("application/octet-stream") _ -> return ()
|
||||||
_ -> fail $ "expected UnsupportedContentType, but got " <> show res
|
_ -> fail $ "expected UnsupportedContentType, but got " <> show res
|
||||||
|
|
||||||
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
|
it "reports InvalidContentTypeHeader" $ \baseUrl -> do
|
||||||
let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
|
let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
|
||||||
Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl)
|
Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl)
|
||||||
|
|
||||||
case res of
|
case res of
|
||||||
InvalidContentTypeHeader "fooooo" _ -> return ()
|
InvalidContentTypeHeader "fooooo" _ -> return ()
|
||||||
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
|
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
|
||||||
|
|
||||||
data WrappedApi where
|
|
||||||
WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
|
|
||||||
HasClient api, Client api ~ SCR.ClientM ()) =>
|
|
||||||
Proxy api -> WrappedApi
|
|
||||||
|
|
||||||
basicAuthSpec :: Spec
|
|
||||||
basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
|
|
||||||
context "Authentication works when requests are properly authenticated" $ do
|
|
||||||
|
|
||||||
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
|
|
||||||
let getBasic = client basicAuthAPI
|
|
||||||
let basicAuthData = BasicAuthData "servant" "server"
|
|
||||||
(left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
|
|
||||||
|
|
||||||
context "Authentication is rejected when requests are not authenticated properly" $ do
|
|
||||||
|
|
||||||
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
|
|
||||||
let getBasic = client basicAuthAPI
|
|
||||||
let basicAuthData = BasicAuthData "not" "password"
|
|
||||||
Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)
|
|
||||||
responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
|
|
||||||
|
|
||||||
genAuthSpec :: Spec
|
|
||||||
genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
|
|
||||||
context "Authentication works when requests are properly authenticated" $ do
|
|
||||||
|
|
||||||
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
|
|
||||||
let getProtected = client genAuthAPI
|
|
||||||
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
|
|
||||||
(left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
|
|
||||||
|
|
||||||
context "Authentication is rejected when requests are not authenticated properly" $ do
|
|
||||||
|
|
||||||
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
|
|
||||||
let getProtected = client genAuthAPI
|
|
||||||
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
|
|
||||||
Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl)
|
|
||||||
responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
|
|
||||||
|
|
||||||
-- * utils
|
-- * utils
|
||||||
|
|
||||||
startWaiApp :: Application -> IO (ThreadId, BaseUrl)
|
|
||||||
startWaiApp app = do
|
|
||||||
(port, socket) <- openTestSocket
|
|
||||||
let settings = setPort port $ defaultSettings
|
|
||||||
thread <- forkIO $ runSettingsSocket settings socket app
|
|
||||||
return (thread, BaseUrl Http "localhost" port "")
|
|
||||||
|
|
||||||
|
|
||||||
endWaiApp :: (ThreadId, BaseUrl) -> IO ()
|
|
||||||
endWaiApp (thread, _) = killThread thread
|
|
||||||
|
|
||||||
openTestSocket :: IO (Port, Socket)
|
|
||||||
openTestSocket = do
|
|
||||||
s <- socket AF_INET Stream defaultProtocol
|
|
||||||
localhost <- inet_addr "127.0.0.1"
|
|
||||||
bind s (SockAddrInet aNY_PORT localhost)
|
|
||||||
listen s 1
|
|
||||||
port <- socketPort s
|
|
||||||
return (fromIntegral port, s)
|
|
||||||
|
|
||||||
pathGen :: Gen (NonEmptyList Char)
|
pathGen :: Gen (NonEmptyList Char)
|
||||||
pathGen = fmap NonEmpty path
|
pathGen = fmap NonEmpty path
|
||||||
where
|
where
|
||||||
|
|
10
servant-client/test/ghcjs/build-test-server.sh
Executable file
10
servant-client/test/ghcjs/build-test-server.sh
Executable file
|
@ -0,0 +1,10 @@
|
||||||
|
#/usr/bin/env bash
|
||||||
|
|
||||||
|
set -o errexit
|
||||||
|
|
||||||
|
cd test/ghcjs/testServer
|
||||||
|
|
||||||
|
unset STACK_YAML
|
||||||
|
stack setup
|
||||||
|
stack build
|
||||||
|
cp $(stack exec which testServer) .
|
15
servant-client/test/ghcjs/run-tests.sh
Executable file
15
servant-client/test/ghcjs/run-tests.sh
Executable file
|
@ -0,0 +1,15 @@
|
||||||
|
#!/usr/bin/env bash
|
||||||
|
|
||||||
|
set -o errexit
|
||||||
|
|
||||||
|
loc=$(dirname $0)
|
||||||
|
cd $loc
|
||||||
|
|
||||||
|
cd ../../
|
||||||
|
|
||||||
|
npm install xhr2
|
||||||
|
|
||||||
|
export STACK_YAML=test/ghcjs/stack-ghcjs.yaml
|
||||||
|
stack setup
|
||||||
|
stack build
|
||||||
|
# stack test --fast
|
22
servant-client/test/ghcjs/stack-ghcjs.yaml
Normal file
22
servant-client/test/ghcjs/stack-ghcjs.yaml
Normal file
|
@ -0,0 +1,22 @@
|
||||||
|
# This file was added for being able to test ghcjs support
|
||||||
|
|
||||||
|
packages:
|
||||||
|
- location: ../../.
|
||||||
|
- location: ../../../servant
|
||||||
|
extra-dep: true
|
||||||
|
- location: ../../../servant-server
|
||||||
|
extra-dep: true
|
||||||
|
|
||||||
|
resolver: lts-6.0
|
||||||
|
|
||||||
|
compiler: ghcjs-0.2.0.20160414_ghc-7.10.3
|
||||||
|
compiler-check: match-exact
|
||||||
|
setup-info:
|
||||||
|
ghcjs:
|
||||||
|
source:
|
||||||
|
ghcjs-0.2.0.20160414_ghc-7.10.3:
|
||||||
|
url: https://s3.amazonaws.com/ghcjs/ghcjs-0.2.0.20160414_ghc-7.10.3.tar.gz
|
||||||
|
sha1: 6d6f307503be9e94e0c96ef1308c7cf224d06be3
|
||||||
|
|
||||||
|
extra-deps:
|
||||||
|
- http-api-data-0.3
|
36
servant-client/test/ghcjs/testServer/package.yaml
Normal file
36
servant-client/test/ghcjs/testServer/package.yaml
Normal file
|
@ -0,0 +1,36 @@
|
||||||
|
name: testServer
|
||||||
|
|
||||||
|
executables:
|
||||||
|
testServer:
|
||||||
|
main: testServer.hs
|
||||||
|
other-modules: []
|
||||||
|
dependencies:
|
||||||
|
- base
|
||||||
|
- base-compat
|
||||||
|
- aeson
|
||||||
|
- base64-bytestring
|
||||||
|
- bytestring
|
||||||
|
- exceptions
|
||||||
|
- hspec
|
||||||
|
- http-api-data
|
||||||
|
- http-client
|
||||||
|
- http-media
|
||||||
|
- http-types
|
||||||
|
- HUnit
|
||||||
|
- network
|
||||||
|
- network-uri
|
||||||
|
- QuickCheck
|
||||||
|
- safe
|
||||||
|
- servant
|
||||||
|
- servant-server
|
||||||
|
- string-conversions
|
||||||
|
- text
|
||||||
|
- transformers
|
||||||
|
- wai
|
||||||
|
- warp
|
||||||
|
source-dirs:
|
||||||
|
- ./
|
||||||
|
- ../../../test
|
||||||
|
- ../../../src
|
||||||
|
include-dirs:
|
||||||
|
- ../../../include
|
10
servant-client/test/ghcjs/testServer/stack.yaml
Normal file
10
servant-client/test/ghcjs/testServer/stack.yaml
Normal file
|
@ -0,0 +1,10 @@
|
||||||
|
flags: {}
|
||||||
|
packages:
|
||||||
|
- location: ./.
|
||||||
|
- location: ../../../../
|
||||||
|
subdirs:
|
||||||
|
- servant
|
||||||
|
- servant-client
|
||||||
|
- servant-server
|
||||||
|
extra-dep: true
|
||||||
|
resolver: lts-5.15
|
42
servant-client/test/ghcjs/testServer/testServer.cabal
Normal file
42
servant-client/test/ghcjs/testServer/testServer.cabal
Normal file
|
@ -0,0 +1,42 @@
|
||||||
|
-- This file has been generated from package.yaml by hpack version 0.14.0.
|
||||||
|
--
|
||||||
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
|
name: testServer
|
||||||
|
version: 0.0.0
|
||||||
|
build-type: Simple
|
||||||
|
cabal-version: >= 1.10
|
||||||
|
|
||||||
|
executable testServer
|
||||||
|
main-is: testServer.hs
|
||||||
|
hs-source-dirs:
|
||||||
|
./
|
||||||
|
, ../../../test
|
||||||
|
, ../../../src
|
||||||
|
include-dirs:
|
||||||
|
../../../include
|
||||||
|
build-depends:
|
||||||
|
base
|
||||||
|
, base-compat
|
||||||
|
, aeson
|
||||||
|
, base64-bytestring
|
||||||
|
, bytestring
|
||||||
|
, exceptions
|
||||||
|
, hspec
|
||||||
|
, http-api-data
|
||||||
|
, http-client
|
||||||
|
, http-media
|
||||||
|
, http-types
|
||||||
|
, HUnit
|
||||||
|
, network
|
||||||
|
, network-uri
|
||||||
|
, QuickCheck
|
||||||
|
, safe
|
||||||
|
, servant
|
||||||
|
, servant-server
|
||||||
|
, string-conversions
|
||||||
|
, text
|
||||||
|
, transformers
|
||||||
|
, wai
|
||||||
|
, warp
|
||||||
|
default-language: Haskell2010
|
28
servant-client/test/ghcjs/testServer/testServer.hs
Normal file
28
servant-client/test/ghcjs/testServer/testServer.hs
Normal file
|
@ -0,0 +1,28 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
|
import Network.Wai.Handler.Warp
|
||||||
|
import Servant
|
||||||
|
import System.IO
|
||||||
|
|
||||||
|
import Servant.Client.TestServer.GHC
|
||||||
|
import Servant.Client.TestServer.Types
|
||||||
|
import Servant.ClientSpec
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
(port, socket) <- openTestSocket
|
||||||
|
let settings =
|
||||||
|
setPort port $
|
||||||
|
setBeforeMainLoop (print port >> hFlush stdout) $
|
||||||
|
defaultSettings
|
||||||
|
runSettingsSocket settings socket $
|
||||||
|
serve testServerApi $ \ testServerName request respond -> do
|
||||||
|
app <- testServerApp <$> lookupTestServer testServerName
|
||||||
|
app request respond
|
||||||
|
|
||||||
|
type TestServerApi =
|
||||||
|
Capture "testServerName" String :> Raw
|
||||||
|
|
||||||
|
testServerApi :: Proxy TestServerApi
|
||||||
|
testServerApi = Proxy
|
Loading…
Reference in a new issue