diff --git a/.travis.yml b/.travis.yml index 2e9d3d3f..f7f06057 100644 --- a/.travis.yml +++ b/.travis.yml @@ -8,6 +8,8 @@ # language: c dist: xenial +# services: +# - xvfb git: # whether to recursively clone submodules submodules: false @@ -190,6 +192,7 @@ script: echo 'packages: "servant-machines-*/*.cabal"' >> cabal.project echo 'packages: "servant-conduit-*/*.cabal"' >> cabal.project echo 'packages: "servant-pipes-*/*.cabal"' >> cabal.project + echo 'packages: "servant-client-jsaddle-*/*.cabal"' >> cabal.project if [ $HCNUMVER -eq 80404 ] || [ $HCNUMVER -eq 80604 ] ; then echo 'packages: "cookbook-basic-auth-*/*.cabal"' >> cabal.project ; fi if [ $HCNUMVER -eq 80404 ] || [ $HCNUMVER -eq 80604 ] ; then echo 'packages: "cookbook-curl-mock-*/*.cabal"' >> cabal.project ; fi if [ $HCNUMVER -eq 80404 ] || [ $HCNUMVER -eq 80604 ] ; then echo 'packages: "cookbook-basic-streaming-*/*.cabal"' >> cabal.project ; fi diff --git a/servant-client-jsaddle/servant-client-jsaddle.cabal b/servant-client-jsaddle/servant-client-jsaddle.cabal index e8744fc1..22fca837 100644 --- a/servant-client-jsaddle/servant-client-jsaddle.cabal +++ b/servant-client-jsaddle/servant-client-jsaddle.cabal @@ -1,5 +1,5 @@ name: servant-client-jsaddle -version: 0.13 +version: 0.16 synopsis: automatic derivation of querying functions for servant webservices for jsaddle (GHCJS, GHC + WebKit, GHC + websockets, etc) description: This library lets you automatically derive Haskell functions that @@ -12,7 +12,7 @@ license: BSD3 license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors +copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors category: Servant, Web build-type: Simple cabal-version: >=1.10 @@ -52,7 +52,8 @@ library -- Servant dependencies. -- Strict dependency on `servant-client-core` as we re-export things. build-depends: - servant-client-core == 0.15.* + servant == 0.16.* + , servant-client-core == 0.16.* -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. @@ -96,7 +97,7 @@ test-suite spec , http-media , http-types , jsaddle - , jsaddle-webkit2gtk + , jsaddle-warp , jsaddle-dom , monad-control , mtl diff --git a/servant-client-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs b/servant-client-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs index 4e2bdc16..2753ad90 100644 --- a/servant-client-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs +++ b/servant-client-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs @@ -14,40 +14,42 @@ module Servant.Client.Internal.JSaddleXhrClient where -import Control.Arrow -import Data.ByteString.Builder (toLazyByteString) import Control.Concurrent +import Control.Exception import Control.Monad -import Control.Monad.Catch (MonadCatch, MonadThrow) -import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.Error.Class (MonadError (..)) import Control.Monad.Reader import Control.Monad.Trans.Except +import Data.Bifunctor +import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as L import Data.CaseInsensitive import Data.Char -import Data.Foldable (toList) -import Data.Functor.Alt (Alt (..)) -import Data.Proxy (Proxy (..)) -import qualified Data.Sequence as Seq +import Data.Foldable (toList) +import Data.Functor.Alt (Alt (..)) +import Data.Proxy (Proxy (..)) +import qualified Data.Sequence as Seq import Data.String.Conversions import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T import GHC.Generics -import qualified JSDOM.Types as JS -import qualified JSDOM.Custom.XMLHttpRequest as JS -import qualified JSDOM.Generated.Window as Window -import qualified JSDOM.Generated.Location as Location -import qualified JSDOM -import JSDOM.Types (DOM, askDOM, runDOM, DOMContext) -import qualified JSDOM.EventM as JSDOM -import qualified Language.Javascript.JSaddle.Types as JSaddle -import qualified JavaScript.TypedArray.ArrayBuffer as ArrayBuffer import qualified GHCJS.Buffer as Buffer -import Network.HTTP.Types +import qualified JSDOM +import qualified JSDOM.Custom.XMLHttpRequest as JS +import qualified JSDOM.EventM as JSDOM +import qualified JSDOM.Generated.Location as Location +import qualified JSDOM.Generated.Window as Window +import JSDOM.Types (DOM, askDOM, runDOM, DOMContext) +import qualified JSDOM.Types as JS +import qualified JavaScript.TypedArray.ArrayBuffer as ArrayBuffer +import qualified Language.Javascript.JSaddle.Types as JSaddle import Network.HTTP.Media (renderHeader) +import Network.HTTP.Types import Servant.Client.Core + -- Note: assuming encoding UTF-8 data ClientEnv @@ -75,9 +77,9 @@ client :: HasClient ClientM api => Proxy api -> Client ClientM api client api = api `clientIn` (Proxy :: Proxy ClientM) newtype ClientM a = ClientM - { fromClientM :: ReaderT ClientEnv (ExceptT ServantError DOM) a } + { fromClientM :: ReaderT ClientEnv (ExceptT ClientError DOM) a } deriving ( Functor, Applicative, Monad, MonadIO, Generic - , MonadReader ClientEnv, MonadError ServantError) + , MonadReader ClientEnv, MonadError ClientError) deriving instance MonadThrow DOM => MonadThrow ClientM deriving instance MonadCatch DOM => MonadCatch ClientM @@ -86,18 +88,15 @@ instance Alt ClientM where a b = a `catchError` const b instance RunClient ClientM where - throwServantError = throwError + throwClientError = throwError runRequest r = do d <- ClientM askDOM performRequest d r -instance ClientLike (ClientM a) (ClientM a) where - mkClient = id - -runClientM :: ClientM a -> ClientEnv -> DOM (Either ServantError a) +runClientM :: ClientM a -> ClientEnv -> DOM (Either ClientError a) runClientM cm env = runExceptT $ flip runReaderT env $ fromClientM cm -runClientM' :: ClientM a -> DOM (Either ServantError a) +runClientM' :: ClientM a -> DOM (Either ClientError a) runClientM' m = do burl <- getDefaultBaseUrl runClientM m (mkClientEnv burl) @@ -135,8 +134,9 @@ performRequest domc req = do resp <- toResponse domc xhr let status = statusCode (responseStatusCode resp) - unless (status >= 200 && status < 300) $ - throwError $ FailureResponse resp + unless (status >= 200 && status < 300) $ do + let f b = (burl, L.toStrict $ toLazyByteString b) + throwError $ FailureResponse (bimap (const ()) f req) resp pure resp @@ -151,7 +151,7 @@ performXhr xhr burl request fixUp = do JS.open xhr (decodeUtf8Lenient $ requestMethod request) (toUrl burl request) True username password setHeaders xhr request fixUp xhr - + waiter <- liftIO $ newEmptyMVar cleanup <- JSDOM.on xhr JS.readyStateChange $ do @@ -166,11 +166,11 @@ performXhr xhr burl request fixUp = do _ -> return () sendXhr xhr (toBody request) - + liftIO $ takeMVar waiter - + cleanup - + toUrl :: BaseUrl -> Request -> JS.JSString toUrl burl request = let pathS = JS.toJSString $ decodeUtf8Lenient $ L.toStrict $ toLazyByteString $ @@ -223,14 +223,14 @@ toBody request = case requestBody request of -- * inspecting the xhr response -- This function is only supposed to handle 'ConnectionError's. Other --- 'ServantError's are created in Servant.Client.Req. +-- 'ClientError's are created in Servant.Client.Req. toResponse :: DOMContext -> JS.XMLHttpRequest -> ClientM Response toResponse domc xhr = do let inDom :: DOM a -> ClientM a inDom = flip runDOM domc status <- inDom $ JS.getStatus xhr case status of - 0 -> throwError $ ConnectionError "connection error" + 0 -> throwError $ ConnectionError $ SomeException $ userError "connection error" _ -> inDom $ do statusText <- BS.pack <$> JS.getStatusText xhr headers <- parseHeaders <$> JS.getAllResponseHeaders xhr diff --git a/servant-client-jsaddle/test/Servant/Client/JsSpec.hs b/servant-client-jsaddle/test/Servant/Client/JsSpec.hs index 9eb3dd1b..02c2db70 100644 --- a/servant-client-jsaddle/test/Servant/Client/JsSpec.hs +++ b/servant-client-jsaddle/test/Servant/Client/JsSpec.hs @@ -6,31 +6,32 @@ {-# LANGUAGE OverloadedStrings #-} module Servant.Client.JsSpec where -import Servant.API -import Servant.Server -import Network.Wai.Handler.Warp as Warp -import qualified Data.ByteString as B -import Data.ByteString(ByteString) -import Test.Hspec -import Data.Proxy +import Control.Concurrent import Control.Monad.Trans import Data.Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Proxy +import Data.String import Data.Word import GHC.Generics -import qualified Language.Javascript.JSaddle.WebKitGTK as WK -import qualified Language.Javascript.JSaddle.Monad as JSaddle -import Language.Javascript.JSaddle.Monad(JSM) -import Control.Concurrent -import Servant.Client.Js import qualified JSDOM import qualified JSDOM.Window as Window -import qualified Network.Wai as Wai -import Network.Wai.Middleware.AddHeaders +import Language.Javascript.JSaddle.Monad (JSM) +import qualified Language.Javascript.JSaddle.Monad as JSaddle +import qualified Language.Javascript.JSaddle.Warp as JW import qualified Network.HTTP.Types as Http -import Data.String -import System.IO +import qualified Network.Wai as Wai +import Network.Wai.Handler.Warp as Warp +import Network.Wai.Middleware.AddHeaders +import Servant.API +import Servant.Client.Core +import Servant.Client.Internal.JSaddleXhrClient +import Servant.Server +import Test.Hspec type TestApi = ReqBody '[OctetStream] ByteString :> Post '[JSON] TestResponse + testApi :: Proxy TestApi testApi = Proxy @@ -90,8 +91,8 @@ spec = do , baseUrlPort = fromIntegral portNr , baseUrlPath = "/" } - - WK.run $ JSaddle.liftJSM $ jsaddleFinally close $ do + + JW.run 3072 $ jsaddleFinally close $ do liftIO $ threadDelay $ 1000 * 1000 -- a mix of valid utf-8 and non-utf8 bytes let bytes = [0x01, 0xff, 0x02, 0xfe, 0x03, 0xfd, 0x00, 0x64, 0xc3, 0xbb, 0x68, 0xc3]