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

View file

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

View file

@ -42,6 +42,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

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.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.Client hiding (Proxy, path)
import Network.HTTP.Media import Network.HTTP.Media
import Network.HTTP.Types 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 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 Exception ServantError
data Req = Req data Req = Req
{ reqPath :: String { reqPath :: String
@ -135,7 +108,7 @@ performRequest reqMethod req manager reqHost = do
, checkStatus = \ _status _headers _cookies -> Nothing , checkStatus = \ _status _headers _cookies -> Nothing
} }
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager eResponse <- liftIO $ performHttpRequest manager request
case eResponse of case eResponse of
Left err -> Left err ->
throwE . ConnectionError $ SomeException err throwE . ConnectionError $ SomeException err
@ -172,8 +145,3 @@ performRequestNoBody :: Method -> Req -> Manager -> BaseUrl
performRequestNoBody reqMethod req manager reqHost = do performRequestNoBody reqMethod req manager reqHost = do
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost
return hdrs 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 CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
@ -11,24 +10,19 @@
{-# 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 #-}
{-# OPTIONS_GHC -fcontext-stack=100 #-} {-# OPTIONS_GHC -fcontext-stack=100 #-}
{-# 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) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
#endif #endif
import Control.Arrow (left) import Control.Arrow (left)
import Control.Concurrent (forkIO, killThread, ThreadId) import Control.Monad.Trans.Except (runExceptT, throwE)
import Control.Exception (bracket)
import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)
import Data.Aeson import Data.Aeson
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
import Data.Char (chr, isPrint) import Data.Char (chr, isPrint)
@ -40,33 +34,73 @@ 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 (Application, Request, import qualified Network.Wai as Wai
requestHeaders, responseLBS) import System.Exit
import Network.Wai.Handler.Warp
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 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
@ -147,8 +181,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)
@ -166,19 +200,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
@ -200,8 +234,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
@ -214,58 +249,59 @@ 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 <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice (left show <$> runExceptT (getGet 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 <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent (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 (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) (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 let p = Person "Clara" 42
(left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p (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 show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice
Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl) Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") 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 <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right [] (left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right []
(left show <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl)) (left show <$> runExceptT (getQueryParams ["alice", "bob"] 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 <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag (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) res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl)
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
@ -274,7 +310,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 <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl) res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl)
case res of case res of
Right _ -> assertFailure "expected Left, but got Right" 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.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 <- runExceptT (getRespHeaders manager baseUrl) res <- runExceptT (getRespHeaders 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 <$> runExceptT (getMultiple cap num flag body manager baseUrl) result <- left show <$> runExceptT (getMultiple cap num flag body 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 :: C.Manager -> BaseUrl -> SCR.ClientM () err = throwE $ ServantErr 500 "error message" "" []
getResponse = client api
Left FailureResponse{..} <- runExceptT (getResponse 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 = 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 :: 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 <- runExceptT (getDeleteEmpty manager baseUrl) Left res <- runExceptT (getDeleteEmpty 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 <- runExceptT (getCapture "foo" manager baseUrl) Left res <- runExceptT (getCapture "foo" manager baseUrl)
case res of case res of
@ -340,81 +418,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 <- runExceptT (getGet manager baseUrl) Left res <- runExceptT (getGet 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 <- runExceptT (getBody alice manager baseUrl) Left res <- runExceptT (getBody alice 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 ~ 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 -- * 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

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