servant-client: support for ghcjs

This commit is contained in:
Sönke Hahn 2016-05-12 21:20:15 +08:00
parent 14a8139cbe
commit 5c91864ee4
21 changed files with 739 additions and 165 deletions

2
.gitignore vendored
View file

@ -29,3 +29,5 @@ doc/_build
doc/venv
doc/tutorial/static/api.js
doc/tutorial/static/jq.js
servant-client/node_modules/
servant-client/test/ghcjs/testServer/testServer

View file

@ -31,12 +31,22 @@ library
Servant.Common.BaseUrl
Servant.Common.BasicAuth
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:
base >=4.7 && <5
, aeson
, attoparsec
, base64-bytestring
, bytestring
, case-insensitive
, exceptions
, http-api-data >= 0.1 && < 0.3
, http-client
@ -50,6 +60,10 @@ library
, text
, transformers
, transformers-compat
if impl(ghcjs)
build-depends:
ghcjs-base
, ghcjs-prim
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
@ -60,19 +74,31 @@ test-suite spec
ghc-options:
-Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
default-language: Haskell2010
hs-source-dirs: test
hs-source-dirs: test, src
main-is: Spec.hs
other-modules:
Servant.ClientSpec
, Servant.Client.PerformRequest.GHCJSSpec
, Servant.Client.TestServer
, Servant.Client.TestServer.Types
, Servant.Common.BaseUrl
, Servant.Common.BaseUrlSpec
, Spec
if impl(ghcjs)
other-modules:
Servant.Client.TestServer.GHCJS
else
other-modules:
Servant.Client.TestServer.GHC
build-depends:
base == 4.*
, transformers
, transformers-compat
, aeson
, base64-bytestring
, bytestring
, deepseq
, hspec == 2.*
, hspec >= 2.2.1 && < 2.3
, http-client
, http-media
, http-types
@ -80,8 +106,20 @@ test-suite spec
, network >= 2.6
, QuickCheck >= 2.7
, servant == 0.6.*
, servant-client
, servant-server == 0.6.*
, text
, wai
, 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

View file

@ -42,6 +42,7 @@ import Servant.Client.Experimental.Auth
import Servant.Common.BaseUrl
import Servant.Common.BasicAuth
import Servant.Common.Req
import Servant.Client.PerformRequest (ServantError(..))
-- * Accessing APIs as a Client

View 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

View file

@ -0,0 +1,35 @@
{-# 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 Exception ServantError

View 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)

View file

@ -0,0 +1,178 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Servant.Client.PerformRequest.GHCJS (
ServantError(..),
performHttpRequest,
-- exported for testing
parseHeaders,
) where
import Control.Arrow
import Control.Concurrent
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as LBS
import Data.CaseInsensitive
import Data.Char
import Data.String.Conversions
import GHCJS.Foreign.Callback
import GHCJS.Prim
import Network.HTTP.Client
import Network.HTTP.Client.Internal as HttpClient
import Network.HTTP.Types
import Servant.Client.PerformRequest.Base
newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
performHttpRequest :: Manager -> Request -> IO (Either ServantError (Response LBS.ByteString))
performHttpRequest _ request = do
xhr <- initXhr
performXhr xhr request
toResponse xhr
-- * initialization
initXhr :: IO JSXMLHttpRequest
initXhr = do
lib <- requireXMLHttpRequestClass
newXMLHttpRequest lib
foreign import javascript unsafe
-- branching between node (for testing) and browsers
"(function () {if (typeof require !== 'undefined') { return require('xhr2'); } else { return XMLHttpRequest; };})()"
requireXMLHttpRequestClass :: IO JSXMLHttpRequestClass
foreign import javascript unsafe "new $1()"
newXMLHttpRequest :: JSXMLHttpRequestClass -> IO JSXMLHttpRequest
-- * performing requests
-- Performs the xhr and blocks until the response was received
performXhr :: JSXMLHttpRequest -> Request -> IO ()
performXhr xhr request = do
waiter <- newEmptyMVar
callback <- onReadyStateChange xhr $ do
state <- readyState xhr
case state of
4 -> putMVar waiter ()
_ -> return ()
openXhr xhr (cs $ method request) (toUrl request) True
setHeaders xhr (requestHeaders request)
sendXhr xhr (toBody request)
takeMVar waiter
releaseCallback callback
onReadyStateChange :: JSXMLHttpRequest -> IO () -> IO (Callback (IO ()))
onReadyStateChange xhr action = do
callback <- asyncCallback action
js_onReadyStateChange xhr callback
return callback
foreign import javascript safe "$1.onreadystatechange = $2;"
js_onReadyStateChange :: JSXMLHttpRequest -> Callback (IO ()) -> IO ()
foreign import javascript unsafe "$1.readyState"
readyState :: JSXMLHttpRequest -> IO Int
openXhr :: JSXMLHttpRequest -> String -> String -> Bool -> IO ()
openXhr xhr method url async =
js_openXhr xhr (toJSString method) (toJSString url) async
foreign import javascript unsafe "$1.open($2, $3, $4)"
js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
toUrl :: Request -> String
toUrl request =
let protocol = if secure request then "https" else "http"
hostS = cs $ host request
portS = show $ port request
pathS = cs $ path request
queryS = cs $ queryString request
in protocol ++ "://" ++ hostS ++ ":" ++ portS ++ pathS ++ queryS
setHeaders :: JSXMLHttpRequest -> RequestHeaders -> IO ()
setHeaders xhr headers = forM_ headers $ \ (key, value) ->
js_setRequestHeader xhr (toJSString $ cs $ original key) (toJSString $ cs value)
foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()
sendXhr xhr Nothing = js_sendXhr xhr
sendXhr xhr (Just body) =
js_sendXhrWithBody xhr (toJSString body)
foreign import javascript unsafe "$1.send()"
js_sendXhr :: JSXMLHttpRequest -> IO ()
foreign import javascript unsafe "$1.send($2)"
js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
toBody :: Request -> Maybe String
toBody request = case requestBody request of
RequestBodyLBS "" -> Nothing
RequestBodyLBS x -> Just $ cs x
_ -> error "servant-client only uses RequestBodyLBS"
-- * inspecting the xhr response
-- This function is only supposed to handle 'ConnectionError's. Other
-- 'ServantError's are created in Servant.Client.Req.
toResponse :: JSXMLHttpRequest -> IO (Either ServantError (Response LBS.ByteString))
toResponse xhr = do
status <- getStatus xhr
case status of
0 -> return $ Left $ ConnectionError $ SomeException $ ErrorCall "connection error"
_ -> do
statusText <- cs <$> getStatusText xhr
headers <- parseHeaders <$> getAllResponseHeaders xhr
responseText <- cs <$> getResponseText xhr
return $ Right $ Response {
HttpClient.responseStatus = mkStatus status statusText,
responseVersion = http11, -- this is made up
responseHeaders = headers,
HttpClient.responseBody = responseText,
responseCookieJar = mempty,
responseClose' = ResponseClose (return ())
}
foreign import javascript unsafe "$1.status"
getStatus :: JSXMLHttpRequest -> IO Int
getStatusText :: JSXMLHttpRequest -> IO String
getStatusText = fmap fromJSString . js_statusText
foreign import javascript unsafe "$1.statusText"
js_statusText :: JSXMLHttpRequest -> IO JSVal
getAllResponseHeaders :: JSXMLHttpRequest -> IO String
getAllResponseHeaders xhr =
fromJSString <$> js_getAllResponseHeaders xhr
foreign import javascript unsafe "$1.getAllResponseHeaders()"
js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
getResponseText :: JSXMLHttpRequest -> IO String
getResponseText xhr = fromJSString <$> js_responseText xhr
foreign import javascript unsafe "$1.responseText"
js_responseText :: JSXMLHttpRequest -> IO JSVal
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

View file

@ -18,44 +18,17 @@ import Data.String.Conversions
import Data.Proxy
import Data.Text (Text)
import Data.Text.Encoding
import Data.Typeable
import Network.HTTP.Client hiding (Proxy, path)
import Network.HTTP.Media
import Network.HTTP.Types
import qualified Network.HTTP.Types.Header as HTTP
import qualified Network.HTTP.Types.Header as HTTP
import Network.URI hiding (path)
import Servant.API.ContentTypes
import Servant.Client.PerformRequest
import Servant.Common.BaseUrl
import qualified Network.HTTP.Client as Client
import Web.HttpApiData
data ServantError
= FailureResponse
{ responseStatus :: Status
, responseContentType :: MediaType
, responseBody :: ByteString
}
| DecodeFailure
{ decodeError :: String
, responseContentType :: MediaType
, responseBody :: ByteString
}
| UnsupportedContentType
{ responseContentType :: MediaType
, responseBody :: ByteString
}
| InvalidContentTypeHeader
{ responseContentTypeHeader :: ByteString
, responseBody :: ByteString
}
| ConnectionError
{ connectionError :: SomeException
}
deriving (Show, Typeable)
instance Exception ServantError
import qualified Network.HTTP.Client as Client
data Req = Req
{ reqPath :: String
@ -135,7 +108,7 @@ performRequest reqMethod req manager reqHost = do
, checkStatus = \ _status _headers _cookies -> Nothing
}
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
eResponse <- liftIO $ performHttpRequest manager request
case eResponse of
Left err ->
throwE . ConnectionError $ SomeException err
@ -172,8 +145,3 @@ performRequestNoBody :: Method -> Req -> Manager -> BaseUrl
performRequestNoBody reqMethod req manager reqHost = do
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost
return hdrs
catchConnectionError :: IO a -> IO (Either ServantError a)
catchConnectionError action =
catch (Right <$> action) $ \e ->
pure . Left . ConnectionError $ SomeException (e :: HttpException)

View file

@ -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

View 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

View 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)

View 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

View file

@ -0,0 +1,10 @@
module Servant.Client.TestServer.Types where
import Network.Wai
data TestServer
= TestServer {
testServerName :: String,
testServerApp :: Application
}

View file

@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
@ -11,24 +10,19 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fcontext-stack=100 #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
#include "overlapping-compat.h"
module Servant.ClientSpec where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Arrow (left)
import Control.Concurrent (forkIO, killThread, ThreadId)
import Control.Exception (bracket)
import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)
import Control.Monad.Trans.Except (runExceptT, throwE)
import Data.Aeson
import qualified Data.ByteString.Lazy as BS
import Data.Char (chr, isPrint)
@ -39,34 +33,74 @@ import qualified Data.Text as T
import GHC.Generics (Generic)
import qualified Network.HTTP.Client as C
import Network.HTTP.Media
import qualified Network.HTTP.Types as HTTP
import Network.Socket
import Network.Wai (Application, Request,
requestHeaders, responseLBS)
import Network.Wai.Handler.Warp
import qualified Network.HTTP.Types as HTTP
import Network.Wai (responseLBS)
import qualified Network.Wai as Wai
import System.Exit
import System.IO.Unsafe (unsafePerformIO)
import Test.HUnit
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.HUnit
import Test.QuickCheck
import Servant.API
import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Client
import Servant.Client.TestServer
import qualified Servant.Common.Req as SCR
import Servant.Server
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 = describe "Servant.Client" $ do
spec = do
runIO buildTestServer
describe "Servant.Client" $ do
sucessSpec
failSpec
wrappedApiSpec
basicAuthSpec
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
@ -147,8 +181,8 @@ getGet
:<|> getRespHeaders
:<|> getDeleteContentType = client api
server :: Application
server = serve api (
server :: TestServer
server = TestServer "server" $ serve api (
return alice
:<|> return NoContent
:<|> (\ name -> return $ Person name 0)
@ -166,19 +200,19 @@ server = serve api (
:<|> return NoContent
)
type FailApi =
"get" :> Raw
:<|> "capture" :> Capture "name" String :> Raw
:<|> "body" :> Raw
failApi :: Proxy FailApi
failApi = Proxy
failServer :: Application
failServer = serve failApi (
failServer :: TestServer
failServer = TestServer "failServer" $ serve failApi (
(\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
:<|> (\ _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
@ -200,8 +234,9 @@ basicAuthHandler =
basicServerContext :: Context '[ BasicAuthCheck () ]
basicServerContext = basicAuthHandler :. EmptyContext
basicAuthServer :: Application
basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
basicAuthServer :: TestServer
basicAuthServer = TestServer "basicAuthServer" $
serveWithContext basicAuthAPI basicServerContext (const (return alice))
-- * general auth stuff
@ -214,58 +249,59 @@ genAuthAPI = Proxy
type instance AuthServerData (AuthProtect "auth-tag") = ()
type instance AuthClientData (AuthProtect "auth-tag") = ()
genAuthHandler :: AuthHandler Request ()
genAuthHandler :: AuthHandler Wai.Request ()
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" })
Just _ -> return ()
in mkAuthHandler handler
genAuthServerContext :: Context '[ AuthHandler Request () ]
genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
genAuthServerContext = genAuthHandler :. EmptyContext
genAuthServer :: Application
genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
genAuthServer :: TestServer
genAuthServer = TestServer "genAuthServer" $
serveWithContext genAuthAPI genAuthServerContext (const (return alice))
{-# NOINLINE manager #-}
manager :: C.Manager
manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
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 <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice
describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do
it "allows empty content type" $ \baseUrl -> do
(left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent
it "allows content type" $ \(_, baseUrl) -> do
it "allows content type" $ \baseUrl -> do
(left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent
it "Servant.API.Capture" $ \(_, baseUrl) -> do
it "Servant.API.Capture" $ \baseUrl -> do
(left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
it "Servant.API.ReqBody" $ \baseUrl -> do
let p = Person "Clara" 42
(left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p
it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
it "Servant.API.QueryParam" $ \baseUrl -> do
left show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice
Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl)
responseStatus `shouldBe` HTTP.Status 400 "bob not found"
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
it "Servant.API.QueryParam.QueryParams" $ \baseUrl -> do
(left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right []
(left show <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl))
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.QueryParam.QueryFlag" $
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
forM_ [False, True] $ \ flag -> it (show flag) $ \baseUrl -> do
(left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
it "Servant.API.Raw on success" $ \baseUrl -> do
res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl)
case res of
Left e -> assertFailure $ show e
@ -274,7 +310,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
C.responseBody response `shouldBe` body
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 <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl)
case res of
Right _ -> assertFailure "expected Left, but got Right"
@ -282,51 +318,93 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
Servant.Client.responseStatus e `shouldBe` HTTP.status400
Servant.Client.responseBody e `shouldBe` "rawFailure"
it "Returns headers appropriately" $ \(_, baseUrl) -> do
it "Returns headers appropriately" $ \baseUrl -> do
res <- runExceptT (getRespHeaders manager baseUrl)
case res of
Left e -> assertFailure $ show e
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
modifyMaxSuccess (const 20) $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \baseUrl ->
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
ioProperty $ do
result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl)
return $
result === Right (cap, num, flag, body)
type ErrorApi =
Delete '[JSON] () :<|>
Get '[JSON] () :<|>
Post '[JSON] () :<|>
Put '[JSON] ()
wrappedApiSpec :: Spec
wrappedApiSpec = describe "error status codes" $ do
let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
context "are correctly handled by the client" $
let test :: (WrappedApi, String) -> Spec
test (WrappedApi api, desc) =
it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
let getResponse :: C.Manager -> BaseUrl -> SCR.ClientM ()
getResponse = client api
Left FailureResponse{..} <- runExceptT (getResponse manager baseUrl)
responseStatus `shouldBe` (HTTP.Status 500 "error message")
in mapM_ test $
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
(WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
(WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
(WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
[]
errorApi :: Proxy ErrorApi
errorApi = Proxy
errorServer :: TestServer
errorServer = TestServer "errorServer" $ serve errorApi $
err :<|> err :<|> err :<|> err
where
err = throwE $ ServantErr 500 "error message" "" []
errorSpec :: Spec
errorSpec =
around (withTestServer "errorServer") $ do
describe "error status codes" $
it "reports error statuses correctly" $ \baseUrl -> do
let delete :<|> get :<|> post :<|> put =
client errorApi
actions = map (\ f -> f manager baseUrl) [delete, get, post, put]
forM_ actions $ \ clientAction -> do
Left FailureResponse{..} <- runExceptT clientAction
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 <$> runExceptT (getBasic basicAuthData 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{..} <- runExceptT (getBasic basicAuthData 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 <$> runExceptT (getProtected authRequest 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{..} <- runExceptT (getProtected authRequest manager baseUrl)
responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
failSpec :: Spec
failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
failSpec = around (withTestServer "failServer") $ do
context "client returns errors appropriately" $ do
it "reports FailureResponse" $ \(_, baseUrl) -> do
it "reports FailureResponse" $ \baseUrl -> do
let (_ :<|> getDeleteEmpty :<|> _) = client api
Left res <- runExceptT (getDeleteEmpty manager baseUrl)
case res of
FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
_ -> fail $ "expected 404 response, but got " <> show res
it "reports DecodeFailure" $ \(_, baseUrl) -> do
it "reports DecodeFailure" $ \baseUrl -> do
let (_ :<|> _ :<|> getCapture :<|> _) = client api
Left res <- runExceptT (getCapture "foo" manager baseUrl)
case res of
@ -340,81 +418,23 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
ConnectionError _ -> return ()
_ -> fail $ "expected ConnectionError, but got " <> show res
it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
it "reports UnsupportedContentType" $ \baseUrl -> do
let (getGet :<|> _ ) = client api
Left res <- runExceptT (getGet manager baseUrl)
case res of
UnsupportedContentType ("application/octet-stream") _ -> return ()
_ -> fail $ "expected UnsupportedContentType, but got " <> show res
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
it "reports InvalidContentTypeHeader" $ \baseUrl -> do
let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
Left res <- runExceptT (getBody alice manager baseUrl)
case res of
InvalidContentTypeHeader "fooooo" _ -> return ()
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where
WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a,
HasClient api, Client api ~ (C.Manager -> BaseUrl -> 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 <$> runExceptT (getBasic basicAuthData 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{..} <- runExceptT (getBasic basicAuthData 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 <$> runExceptT (getProtected authRequest 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{..} <- runExceptT (getProtected authRequest manager baseUrl)
responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
-- * utils
startWaiApp :: Application -> IO (ThreadId, BaseUrl)
startWaiApp app = do
(port, socket) <- openTestSocket
let settings = setPort port $ defaultSettings
thread <- forkIO $ runSettingsSocket settings socket app
return (thread, BaseUrl Http "localhost" port "")
endWaiApp :: (ThreadId, BaseUrl) -> IO ()
endWaiApp (thread, _) = killThread thread
openTestSocket :: IO (Port, Socket)
openTestSocket = do
s <- socket AF_INET Stream defaultProtocol
localhost <- inet_addr "127.0.0.1"
bind s (SockAddrInet aNY_PORT localhost)
listen s 1
port <- socketPort s
return (fromIntegral port, s)
pathGen :: Gen (NonEmptyList Char)
pathGen = fmap NonEmpty path
where

View 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) .

View file

@ -0,0 +1,14 @@
#!/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 test --fast

View file

@ -0,0 +1,25 @@
# This file was added for being able to test ghcjs support
packages:
- location: ../../.
- location: ../../../servant
extra-dep: true
- location: ../../../servant-server
extra-dep: true
resolver: lts-5.11
compiler: ghcjs-0.2.0.20160315_ghc-7.10.2
compiler-check: match-exact
setup-info:
ghcjs:
source:
ghcjs-0.2.0.20160315_ghc-7.10.2:
url: "https://github.com/nrolland/ghcjs/releases/download/v.0.2.0.20160315/ghcjs-0.2.0.20160315.tar.gz"
extra-deps:
- hspec-expectations-0.7.2
- hspec-discover-2.2.1
- http-api-data-0.1.1.1
- hspec-2.2.1
- hspec-core-2.2.1

View file

@ -0,0 +1,35 @@
name: testServer
executables:
testServer:
main: testServer.hs
other-modules: []
dependencies:
- base
- 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

View file

@ -0,0 +1,10 @@
flags: {}
packages:
- location: ./.
- location: ../../../../
subdirs:
- servant
- servant-client
- servant-server
extra-dep: true
resolver: lts-5.15

View file

@ -0,0 +1,41 @@
-- This file has been generated from package.yaml by hpack version 0.13.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
, 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

View 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