diff --git a/.travis-ghc.sh b/.travis-ghc.sh new file mode 100755 index 00000000..1dc5ac84 --- /dev/null +++ b/.travis-ghc.sh @@ -0,0 +1,6 @@ +#/usr/bin/env bash +set -ev + +for package in $(cat sources.txt); do + (cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1 +done diff --git a/.travis-ghcjs.sh b/.travis-ghcjs.sh new file mode 100755 index 00000000..2ae23d62 --- /dev/null +++ b/.travis-ghcjs.sh @@ -0,0 +1,12 @@ +#/usr/bin/env bash +set -ev + +# tinc +#cabal exec which hspec-discover +#barf +cabal install hspec-discover --prefix $HOME/.local +# export PATH=$HOME/huhu/bin:$PATH +which hspec-discover + +cd servant-client +./test/ghcjs/run-tests.sh diff --git a/.travis.yml b/.travis.yml index 62501f7a..1c45c6fa 100644 --- a/.travis.yml +++ b/.travis.yml @@ -5,6 +5,8 @@ language: c env: - GHCVER=7.8.4 - GHCVER=7.10.2 + - GHCVER=7.10.2 + GHCJS=true addons: apt: @@ -17,6 +19,7 @@ addons: - libgmp-dev install: + # set up tinc - (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc) - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH - ghc --version @@ -24,9 +27,19 @@ install: - travis_retry cabal update - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config + # set up stack (for ghcjs in servant-client) + - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' + - stack --version + script: - - for package in $(cat sources.txt); do (cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done + - if [ "$GHCJS" = "true" ]; + then ./.travis-ghcjs.sh ; + else ./.travis-ghc.sh ; + fi + - export CASHER_TIME_OUT=500 cache: directories: - $HOME/.tinc/cache + - $HOME/.stack + - $HOME/.ghcjs diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 7fe69521..15bed2c0 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -28,6 +28,16 @@ library Servant.Client Servant.Common.BaseUrl Servant.Common.Req + -- fixme: shouldn't be part of the public API: + Servant.Client.PerformRequest.Base + other-modules: + Servant.Client.PerformRequest + if impl(ghcjs) + other-modules: + Servant.Client.PerformRequest.GHCJS + else + other-modules: + Servant.Client.PerformRequest.GHC build-depends: base >=4.7 && <5 , aeson @@ -46,9 +56,14 @@ library , text , transformers , transformers-compat + , case-insensitive + if impl(ghcjs) + build-depends: + ghcjs-base + , ghcjs-prim hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -Werror test-suite spec type: exitcode-stdio-1.0 @@ -59,7 +74,16 @@ test-suite spec main-is: Spec.hs other-modules: Servant.ClientSpec + , Servant.Client.PerformRequest.BaseSpec + , Servant.Client.TestServer , 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 @@ -67,7 +91,7 @@ test-suite spec , aeson , bytestring , deepseq - , hspec == 2.* + , hspec >= 2.2.1 && < 2.3 , http-client , http-media , http-types @@ -80,3 +104,6 @@ test-suite spec , text , wai , warp + , mockery + , safe + , process diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 987a2bd4..3ef63c4a 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -39,6 +39,7 @@ import qualified Network.HTTP.Types.Header as HTTP import Servant.API import Servant.Common.BaseUrl import Servant.Common.Req +import Servant.Client.PerformRequest (ServantError(..)) -- * Accessing APIs as a Client diff --git a/servant-client/src/Servant/Client/PerformRequest.hs b/servant-client/src/Servant/Client/PerformRequest.hs new file mode 100644 index 00000000..50c8e793 --- /dev/null +++ b/servant-client/src/Servant/Client/PerformRequest.hs @@ -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 diff --git a/servant-client/src/Servant/Client/PerformRequest/Base.hs b/servant-client/src/Servant/Client/PerformRequest/Base.hs new file mode 100644 index 00000000..2e39a3b4 --- /dev/null +++ b/servant-client/src/Servant/Client/PerformRequest/Base.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.Client.PerformRequest.Base where + +import Control.Arrow +import Control.Exception +import qualified Data.ByteString.Char8 as BS +import Data.ByteString.Lazy +import Data.CaseInsensitive +import Data.Char +import Data.String.Conversions +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 + +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 diff --git a/servant-client/src/Servant/Client/PerformRequest/GHC.hs b/servant-client/src/Servant/Client/PerformRequest/GHC.hs new file mode 100644 index 00000000..2fbc7161 --- /dev/null +++ b/servant-client/src/Servant/Client/PerformRequest/GHC.hs @@ -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) diff --git a/servant-client/src/Servant/Client/PerformRequest/GHCJS.hs b/servant-client/src/Servant/Client/PerformRequest/GHCJS.hs new file mode 100644 index 00000000..84afdbb2 --- /dev/null +++ b/servant-client/src/Servant/Client/PerformRequest/GHCJS.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.Client.PerformRequest.GHCJS ( + ServantError(..), + performHttpRequest, + ) where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import qualified Data.ByteString.Lazy as LBS +import Data.CaseInsensitive +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 diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 38aa39b5..cfe22c78 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -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 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 @@ -134,7 +107,7 @@ performRequest reqMethod req reqHost manager = 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 @@ -168,8 +141,3 @@ performRequestCT ct reqMethod req reqHost manager = do performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO () performRequestNoBody reqMethod req reqHost manager = void $ performRequest reqMethod req reqHost manager - -catchConnectionError :: IO a -> IO (Either ServantError a) -catchConnectionError action = - catch (Right <$> action) $ \e -> - pure . Left . ConnectionError $ SomeException (e :: HttpException) diff --git a/servant-client/stack-ghc.yaml b/servant-client/stack-ghc.yaml new file mode 100644 index 00000000..f8a7b5d0 --- /dev/null +++ b/servant-client/stack-ghc.yaml @@ -0,0 +1,23 @@ +# This file was added for being able to test ghcjs support + +packages: + - location: ./. + - location: ../ + subdirs: + - servant + - servant-server + extra-dep: true + - location: + git: https://github.com/hspec/hspec + commit: bd06049 + subdirs: + - ./ + - hspec-core + extra-dep: true + +resolver: lts-3.10 + +extra-deps: + - hspec-expectations-0.7.2 + - hspec-discover-2.2.0 + - http-api-data-0.1.1.1 diff --git a/servant-client/stack-ghcjs.yaml b/servant-client/stack-ghcjs.yaml new file mode 100644 index 00000000..437fe3e0 --- /dev/null +++ b/servant-client/stack-ghcjs.yaml @@ -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-3.10 + +compiler: ghcjs-0.2.0.20151029_ghc-7.10.2 +compiler-check: match-exact +setup-info: + ghcjs: + source: + ghcjs-0.2.0.20151029_ghc-7.10.2: + url: "https://github.com/nrolland/ghcjs/releases/download/v0.2.0.20151029/ghcjs-0.2.0.20151029.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 diff --git a/servant-client/test/Servant/Client/PerformRequest/BaseSpec.hs b/servant-client/test/Servant/Client/PerformRequest/BaseSpec.hs new file mode 100644 index 00000000..9bad04ff --- /dev/null +++ b/servant-client/test/Servant/Client/PerformRequest/BaseSpec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Servant.Client.PerformRequest.BaseSpec where + +import Test.Hspec + +import Servant.Client.PerformRequest.Base + +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")] diff --git a/servant-client/test/Servant/Client/TestServer.hs b/servant-client/test/Servant/Client/TestServer.hs new file mode 100644 index 00000000..e6aae5e0 --- /dev/null +++ b/servant-client/test/Servant/Client/TestServer.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE CPP #-} + +module Servant.Client.TestServer ( + buildTestServer, + withTestServer, +)where + +#ifdef __GHCJS__ +import Servant.Client.TestServer.GHCJS +#else +import Servant.Client.TestServer.GHC +#endif diff --git a/servant-client/test/Servant/Client/TestServer/GHC.hs b/servant-client/test/Servant/Client/TestServer/GHC.hs new file mode 100644 index 00000000..0a4dce20 --- /dev/null +++ b/servant-client/test/Servant/Client/TestServer/GHC.hs @@ -0,0 +1,38 @@ +{-# 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 + +buildTestServer :: IO () +buildTestServer = return () + +withTestServer :: Application -> String -> (BaseUrl -> IO a) -> IO a +withTestServer 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) diff --git a/servant-client/test/Servant/Client/TestServer/GHCJS.hs b/servant-client/test/Servant/Client/TestServer/GHCJS.hs new file mode 100644 index 00000000..7deae806 --- /dev/null +++ b/servant-client/test/Servant/Client/TestServer/GHCJS.hs @@ -0,0 +1,34 @@ + +module Servant.Client.TestServer.GHCJS where + +import Control.Exception +import Network.Wai +import Safe +import System.Exit +import System.IO +import System.Process + +import Servant.Common.BaseUrl + +buildTestServer :: IO () +buildTestServer = do + process <- spawnProcess "./test/ghcjs/build-test-server.sh" [] + ExitSuccess <- waitForProcess process + return () + +withTestServer :: Application -> String -> (BaseUrl -> IO a) -> IO a +withTestServer _ 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" []) { + std_out = CreatePipe + } + line <- hGetLine stdout + case readMay line :: Maybe Int of + Nothing -> error ("unparseable port: " ++ show line) + Just port -> return (port, process) + stop (_, process) = do + terminateProcess process + waitForProcess process diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index fc3cdcfb..c6e363aa 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -23,12 +23,10 @@ module Servant.ClientSpec where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), pure) #endif import Control.Arrow (left) -import Control.Concurrent (forkIO, killThread, ThreadId) -import Control.Exception (bracket) -import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import Control.Monad.Trans.Except (runExceptT, throwE) import Data.Aeson import Data.Char (chr, isPrint) import Data.Foldable (forM_) @@ -41,9 +39,7 @@ import qualified Network.HTTP.Client as C import Network.HTTP.Media import Network.HTTP.Types (Status (..), badRequest400, methodGet, ok200, status400) -import Network.Socket import Network.Wai (Application, responseLBS) -import Network.Wai.Handler.Warp import System.IO.Unsafe (unsafePerformIO) import Test.Hspec import Test.Hspec.QuickCheck @@ -52,13 +48,16 @@ import Test.QuickCheck import Servant.API import Servant.Client +import Servant.Client.TestServer import Servant.Server spec :: Spec -spec = describe "Servant.Client" $ do +spec = do + runIO buildTestServer + describe "Servant.Client" $ do sucessSpec failSpec - wrappedApiSpec + errorSpec -- * test data types @@ -105,7 +104,7 @@ type Api = QueryParam "second" Int :> QueryFlag "third" :> ReqBody '[JSON] [(String, [Rational])] :> - Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) + Post '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) :<|> "deleteContentType" :> Delete '[JSON] () api :: Proxy Api @@ -130,11 +129,11 @@ server = serve api ( :<|> return () ) - type FailApi = "get" :> Raw :<|> "capture" :> Capture "name" String :> Raw :<|> "body" :> Raw + failApi :: Proxy FailApi failApi = Proxy @@ -142,56 +141,56 @@ failServer :: Application failServer = serve failApi ( (\ _request respond -> respond $ responseLBS ok200 [] "") :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "") - :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") - ) + :<|> (\ _request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") + ) {-# NOINLINE manager #-} manager :: C.Manager manager = unsafePerformIO $ C.newManager C.defaultManagerSettings sucessSpec :: Spec -sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do +sucessSpec = around (withTestServer server "server") $ do - it "Servant.API.Get" $ \(_, baseUrl) -> do + it "Servant.API.Get" $ \baseUrl -> do let getGet = getNth (Proxy :: Proxy 0) $ client api baseUrl manager (left show <$> runExceptT getGet) `shouldReturn` Right alice describe "Servant.API.Delete" $ do - it "allows empty content type" $ \(_, baseUrl) -> do + it "allows empty content type" $ \baseUrl -> do let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right () - it "allows content type" $ \(_, baseUrl) -> do + it "allows content type" $ \baseUrl -> do let getDeleteContentType = getLast $ client api baseUrl manager (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right () - it "Servant.API.Capture" $ \(_, baseUrl) -> do + it "Servant.API.Capture" $ \baseUrl -> do let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager (left show <$> runExceptT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0) - it "Servant.API.ReqBody" $ \(_, baseUrl) -> do + it "Servant.API.ReqBody" $ \baseUrl -> do let p = Person "Clara" 42 getBody = getNth (Proxy :: Proxy 3) $ client api baseUrl manager (left show <$> runExceptT (getBody p)) `shouldReturn` Right p - it "Servant.API.QueryParam" $ \(_, baseUrl) -> do + it "Servant.API.QueryParam" $ \baseUrl -> do let getQueryParam = getNth (Proxy :: Proxy 4) $ client api baseUrl manager left show <$> runExceptT (getQueryParam (Just "alice")) `shouldReturn` Right alice Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob")) responseStatus `shouldBe` Status 400 "bob not found" - it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do + it "Servant.API.QueryParam.QueryParams" $ \baseUrl -> do let getQueryParams = getNth (Proxy :: Proxy 5) $ client api baseUrl manager (left show <$> runExceptT (getQueryParams [])) `shouldReturn` Right [] (left show <$> runExceptT (getQueryParams ["alice", "bob"])) `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 let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api baseUrl manager (left show <$> runExceptT (getQueryFlag flag)) `shouldReturn` Right flag - it "Servant.API.Raw on success" $ \(_, baseUrl) -> do + it "Servant.API.Raw on success" $ \baseUrl -> do let getRawSuccess = getNth (Proxy :: Proxy 7) $ client api baseUrl manager res <- runExceptT (getRawSuccess methodGet) case res of @@ -201,7 +200,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do C.responseBody response `shouldBe` body C.responseStatus response `shouldBe` 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 let getRawFailure = getNth (Proxy :: Proxy 8) $ client api baseUrl manager res <- runExceptT (getRawFailure methodGet) case res of @@ -210,15 +209,15 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do Servant.Client.responseStatus e `shouldBe` status400 Servant.Client.responseBody e `shouldBe` "rawFailure" - it "Returns headers appropriately" $ \(_, baseUrl) -> do + it "Returns headers appropriately" $ \baseUrl -> do let getRespHeaders = getNth (Proxy :: Proxy 10) $ client api baseUrl manager res <- runExceptT getRespHeaders 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) -> + modifyMaxSuccess (const 2) $ do + it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \baseUrl -> let getMultiple = getNth (Proxy :: Proxy 9) $ client api baseUrl manager in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> ioProperty $ do @@ -226,37 +225,45 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do 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 :: ExceptT ServantError IO () - getResponse = client api baseUrl manager - Left FailureResponse{..} <- runExceptT getResponse - responseStatus `shouldBe` (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 :: Application +errorServer = serve errorApi $ + err :<|> err :<|> err :<|> err + where + err = throwE $ ServantErr 500 "error message" "" [] + +errorSpec :: Spec +errorSpec = + around (withTestServer errorServer "errorServer") $ do + describe "error status codes" $ + it "reports error statuses correctly" $ \baseUrl -> do + let delete :<|> get :<|> post :<|> put = + client errorApi baseUrl manager + actions = [delete, get, post, put] + forM_ actions $ \ clientAction -> do + Left FailureResponse{..} <- runExceptT clientAction + responseStatus `shouldBe` Status 500 "error message" failSpec :: Spec -failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do +failSpec = around (withTestServer failServer "failServer") $ do context "client returns errors appropriately" $ do - it "reports FailureResponse" $ \(_, baseUrl) -> do + it "reports FailureResponse" $ \baseUrl -> do let (_ :<|> getDeleteEmpty :<|> _) = client api baseUrl manager Left res <- runExceptT getDeleteEmpty case res of FailureResponse (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 baseUrl manager Left res <- runExceptT (getCapture "foo") case res of @@ -270,48 +277,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 baseUrl manager Left res <- runExceptT getGet 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 baseUrl manager Left res <- runExceptT (getBody alice) 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 ~ ExceptT ServantError IO ()) => - Proxy api -> WrappedApi - -- * 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 diff --git a/servant-client/test/ghcjs/build-test-server.sh b/servant-client/test/ghcjs/build-test-server.sh new file mode 100755 index 00000000..5a1df6cd --- /dev/null +++ b/servant-client/test/ghcjs/build-test-server.sh @@ -0,0 +1,10 @@ +#/usr/bin/env bash + +set -o errexit + +cd test/ghcjs + +export STACK_YAML=stack-ghc.yaml +stack setup +stack build +cp $(stack exec which testServer) . diff --git a/servant-client/test/ghcjs/package.yaml b/servant-client/test/ghcjs/package.yaml new file mode 100644 index 00000000..35a8cc92 --- /dev/null +++ b/servant-client/test/ghcjs/package.yaml @@ -0,0 +1,25 @@ +name: testServer + +executables: + testServer: + main: testServer.hs + dependencies: + - base + - servant + - servant-client + - servant-server + - warp + - QuickCheck + - hspec + - HUnit + - http-types + - http-media + - http-client + - text + - aeson + - wai + - transformers + - network + source-dirs: + - ./ + - ../ diff --git a/servant-client/test/ghcjs/run-tests.sh b/servant-client/test/ghcjs/run-tests.sh new file mode 100755 index 00000000..9068e98d --- /dev/null +++ b/servant-client/test/ghcjs/run-tests.sh @@ -0,0 +1,11 @@ +#/usr/bin/env bash + +# this script has to be executed from the 'servant-client' directory + +set -o errexit + +npm install xhr2 + +export STACK_YAML=stack-ghcjs.yaml +stack setup +stack test diff --git a/servant-client/test/ghcjs/stack-ghc.yaml b/servant-client/test/ghcjs/stack-ghc.yaml new file mode 100644 index 00000000..e49df0d3 --- /dev/null +++ b/servant-client/test/ghcjs/stack-ghc.yaml @@ -0,0 +1,15 @@ +# This file was added for being able to test ghcjs support + +packages: + - location: ./. + - location: ../../../ + subdirs: + - servant + - servant-client + - servant-server + extra-dep: true + +resolver: nightly-2015-10-08 + +extra-deps: + - http-api-data-0.1.1.1 diff --git a/servant-client/test/ghcjs/testServer.cabal b/servant-client/test/ghcjs/testServer.cabal new file mode 100644 index 00000000..95ec17c4 --- /dev/null +++ b/servant-client/test/ghcjs/testServer.cabal @@ -0,0 +1,40 @@ +-- This file has been generated from package.yaml by hpack version 0.5.4. +-- +-- 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: + ./ + , ../ + build-depends: + base + , servant + , servant-client + , servant-server + , warp + , QuickCheck + , hspec + , HUnit + , http-types + , http-media + , http-client + , text + , aeson + , wai + , transformers + , network + other-modules: + Servant.Client.PerformRequest.BaseSpec + Servant.Client.TestServer + Servant.Client.TestServer.GHC + Servant.Client.TestServer.GHCJS + Servant.ClientSpec + Servant.Common.BaseUrlSpec + Spec + default-language: Haskell2010 diff --git a/servant-client/test/ghcjs/testServer.hs b/servant-client/test/ghcjs/testServer.hs new file mode 100644 index 00000000..8510272c --- /dev/null +++ b/servant-client/test/ghcjs/testServer.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +import Network.Wai.Handler.Warp +import Servant +import System.IO + +import Servant.Client.TestServer.GHC +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 (server :<|> errorServer :<|> failServer) + +type TestServerApi = + "server" :> Raw :<|> + "errorServer" :> Raw :<|> + "failServer" :> Raw + +testServerApi :: Proxy TestServerApi +testServerApi = Proxy