Update to 0.16 and replace jsaddle-webgtk with jsaddle-warp
This commit is contained in:
Denis Redozubov
parent
0a237018de
commit
8a76df3a71
4 changed files with 61 additions and 56 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
Loading…
Reference in a new issue