From 5c91864ee4a8ca45d6501341692a0362d60ee1b1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 12 May 2016 21:20:15 +0800 Subject: [PATCH] servant-client: support for ghcjs --- .gitignore | 2 + servant-client/servant-client.cabal | 44 ++- servant-client/src/Servant/Client.hs | 1 + .../src/Servant/Client/PerformRequest.hs | 13 + .../src/Servant/Client/PerformRequest/Base.hs | 35 +++ .../src/Servant/Client/PerformRequest/GHC.hs | 29 ++ .../Servant/Client/PerformRequest/GHCJS.hs | 178 ++++++++++++ servant-client/src/Servant/Common/Req.hs | 40 +-- .../Client/PerformRequest/GHCJSSpec.hs | 29 ++ .../test/Servant/Client/TestServer.hs | 15 + .../test/Servant/Client/TestServer/GHC.hs | 39 +++ .../test/Servant/Client/TestServer/GHCJS.hs | 34 +++ .../test/Servant/Client/TestServer/Types.hs | 10 + servant-client/test/Servant/ClientSpec.hs | 272 ++++++++++-------- .../test/ghcjs/build-test-server.sh | 10 + servant-client/test/ghcjs/run-tests.sh | 14 + servant-client/test/ghcjs/stack-ghcjs.yaml | 25 ++ .../test/ghcjs/testServer/package.yaml | 35 +++ .../test/ghcjs/testServer/stack.yaml | 10 + .../test/ghcjs/testServer/testServer.cabal | 41 +++ .../test/ghcjs/testServer/testServer.hs | 28 ++ 21 files changed, 739 insertions(+), 165 deletions(-) create mode 100644 servant-client/src/Servant/Client/PerformRequest.hs create mode 100644 servant-client/src/Servant/Client/PerformRequest/Base.hs create mode 100644 servant-client/src/Servant/Client/PerformRequest/GHC.hs create mode 100644 servant-client/src/Servant/Client/PerformRequest/GHCJS.hs create mode 100644 servant-client/test/Servant/Client/PerformRequest/GHCJSSpec.hs create mode 100644 servant-client/test/Servant/Client/TestServer.hs create mode 100644 servant-client/test/Servant/Client/TestServer/GHC.hs create mode 100644 servant-client/test/Servant/Client/TestServer/GHCJS.hs create mode 100644 servant-client/test/Servant/Client/TestServer/Types.hs create mode 100755 servant-client/test/ghcjs/build-test-server.sh create mode 100755 servant-client/test/ghcjs/run-tests.sh create mode 100644 servant-client/test/ghcjs/stack-ghcjs.yaml create mode 100644 servant-client/test/ghcjs/testServer/package.yaml create mode 100644 servant-client/test/ghcjs/testServer/stack.yaml create mode 100644 servant-client/test/ghcjs/testServer/testServer.cabal create mode 100644 servant-client/test/ghcjs/testServer/testServer.hs diff --git a/.gitignore b/.gitignore index 163de4bd..354744cb 100644 --- a/.gitignore +++ b/.gitignore @@ -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 diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 044511c6..820886c9 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -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 diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index cb6837ce..cccec55a 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -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 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..7d886c57 --- /dev/null +++ b/servant-client/src/Servant/Client/PerformRequest/Base.hs @@ -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 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..1969c3bf --- /dev/null +++ b/servant-client/src/Servant/Client/PerformRequest/GHCJS.hs @@ -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 diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 52398637..7c9b5175 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 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) diff --git a/servant-client/test/Servant/Client/PerformRequest/GHCJSSpec.hs b/servant-client/test/Servant/Client/PerformRequest/GHCJSSpec.hs new file mode 100644 index 00000000..ea1b2b9e --- /dev/null +++ b/servant-client/test/Servant/Client/PerformRequest/GHCJSSpec.hs @@ -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 diff --git a/servant-client/test/Servant/Client/TestServer.hs b/servant-client/test/Servant/Client/TestServer.hs new file mode 100644 index 00000000..b1efb388 --- /dev/null +++ b/servant-client/test/Servant/Client/TestServer.hs @@ -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 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..fb706e97 --- /dev/null +++ b/servant-client/test/Servant/Client/TestServer/GHC.hs @@ -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) 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..5e9b27b4 --- /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 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 diff --git a/servant-client/test/Servant/Client/TestServer/Types.hs b/servant-client/test/Servant/Client/TestServer/Types.hs new file mode 100644 index 00000000..df6c3b78 --- /dev/null +++ b/servant-client/test/Servant/Client/TestServer/Types.hs @@ -0,0 +1,10 @@ + +module Servant.Client.TestServer.Types where + +import Network.Wai + +data TestServer + = TestServer { + testServerName :: String, + testServerApp :: Application + } diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 2263e9e2..e2e69f7d 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -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 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..083b7275 --- /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/testServer + +unset STACK_YAML +stack setup +stack build +cp $(stack exec which testServer) . diff --git a/servant-client/test/ghcjs/run-tests.sh b/servant-client/test/ghcjs/run-tests.sh new file mode 100755 index 00000000..e17b729f --- /dev/null +++ b/servant-client/test/ghcjs/run-tests.sh @@ -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 diff --git a/servant-client/test/ghcjs/stack-ghcjs.yaml b/servant-client/test/ghcjs/stack-ghcjs.yaml new file mode 100644 index 00000000..03b3828b --- /dev/null +++ b/servant-client/test/ghcjs/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-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 diff --git a/servant-client/test/ghcjs/testServer/package.yaml b/servant-client/test/ghcjs/testServer/package.yaml new file mode 100644 index 00000000..c5d6c3b9 --- /dev/null +++ b/servant-client/test/ghcjs/testServer/package.yaml @@ -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 diff --git a/servant-client/test/ghcjs/testServer/stack.yaml b/servant-client/test/ghcjs/testServer/stack.yaml new file mode 100644 index 00000000..f5005816 --- /dev/null +++ b/servant-client/test/ghcjs/testServer/stack.yaml @@ -0,0 +1,10 @@ +flags: {} +packages: +- location: ./. +- location: ../../../../ + subdirs: + - servant + - servant-client + - servant-server + extra-dep: true +resolver: lts-5.15 diff --git a/servant-client/test/ghcjs/testServer/testServer.cabal b/servant-client/test/ghcjs/testServer/testServer.cabal new file mode 100644 index 00000000..d004a023 --- /dev/null +++ b/servant-client/test/ghcjs/testServer/testServer.cabal @@ -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 diff --git a/servant-client/test/ghcjs/testServer/testServer.hs b/servant-client/test/ghcjs/testServer/testServer.hs new file mode 100644 index 00000000..29118094 --- /dev/null +++ b/servant-client/test/ghcjs/testServer/testServer.hs @@ -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