eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Update to 0.16 and replace jsaddle-webgtk with jsaddle-warp

Browse source
This commit is contained in:
Denis Redozubov 2019-05-15 18:02:24 +03:00
parent 0a237018de
commit 8a76df3a71
4 changed files with 61 additions and 56 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
.travis.yml
View file

@ -8,6 +8,8 @@
# #
language: c language: c
dist: xenial dist: xenial
# services:
# - xvfb
git: git:
# whether to recursively clone submodules # whether to recursively clone submodules
submodules: false submodules: false
@ -190,6 +192,7 @@ script:
echo 'packages: "servant-machines-*/*.cabal"' >> cabal.project echo 'packages: "servant-machines-*/*.cabal"' >> cabal.project
echo 'packages: "servant-conduit-*/*.cabal"' >> cabal.project echo 'packages: "servant-conduit-*/*.cabal"' >> cabal.project
echo 'packages: "servant-pipes-*/*.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-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-curl-mock-*/*.cabal"' >> cabal.project ; fi
if [ $HCNUMVER -eq 80404 ] || [ $HCNUMVER -eq 80604 ] ; then echo 'packages: "cookbook-basic-streaming-*/*.cabal"' >> cabal.project ; fi if [ $HCNUMVER -eq 80404 ] || [ $HCNUMVER -eq 80604 ] ; then echo 'packages: "cookbook-basic-streaming-*/*.cabal"' >> cabal.project ; fi

9
servant-client-jsaddle/servant-client-jsaddle.cabal
View file

@ -1,5 +1,5 @@
name: servant-client-jsaddle 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) synopsis: automatic derivation of querying functions for servant webservices for jsaddle (GHCJS, GHC + WebKit, GHC + websockets, etc)
description: description:
This library lets you automatically derive Haskell functions that This library lets you automatically derive Haskell functions that
@ -12,7 +12,7 @@ license: BSD3
license-file: LICENSE license-file: LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com 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 category: Servant, Web
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
@ -52,7 +52,8 @@ library
-- Servant dependencies. -- Servant dependencies.
-- Strict dependency on `servant-client-core` as we re-export things. -- Strict dependency on `servant-client-core` as we re-export things.
build-depends: 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. -- 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. -- Here can be exceptions if we really need features from the newer versions.
@ -96,7 +97,7 @@ test-suite spec
, http-media , http-media
, http-types , http-types
, jsaddle , jsaddle
, jsaddle-webkit2gtk , jsaddle-warp
, jsaddle-dom , jsaddle-dom
, monad-control , monad-control
, mtl , mtl

68
servant-client-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs
View file

@ -14,40 +14,42 @@
module Servant.Client.Internal.JSaddleXhrClient where module Servant.Client.Internal.JSaddleXhrClient where
import Control.Arrow
import Data.ByteString.Builder (toLazyByteString)
import Control.Concurrent import Control.Concurrent
import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.Catch (MonadCatch, MonadThrow)
import Control.Monad.Error.Class (MonadError (..)) import Control.Monad.Error.Class (MonadError (..))
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Data.Bifunctor
import Data.ByteString.Builder (toLazyByteString)
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Data.CaseInsensitive import Data.CaseInsensitive
import Data.Char import Data.Char
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.Functor.Alt (Alt (..)) import Data.Functor.Alt (Alt (..))
import Data.Proxy (Proxy (..)) import Data.Proxy (Proxy (..))
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Data.String.Conversions import Data.String.Conversions
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T import qualified Data.Text.Encoding.Error as T
import GHC.Generics 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 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.Media (renderHeader)
import Network.HTTP.Types
import Servant.Client.Core import Servant.Client.Core
-- Note: assuming encoding UTF-8 -- Note: assuming encoding UTF-8
data ClientEnv data ClientEnv
@ -75,9 +77,9 @@ client :: HasClient ClientM api => Proxy api -> Client ClientM api
client api = api `clientIn` (Proxy :: Proxy ClientM) client api = api `clientIn` (Proxy :: Proxy ClientM)
newtype ClientM a = 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 deriving ( Functor, Applicative, Monad, MonadIO, Generic
, MonadReader ClientEnv, MonadError ServantError) , MonadReader ClientEnv, MonadError ClientError)
deriving instance MonadThrow DOM => MonadThrow ClientM deriving instance MonadThrow DOM => MonadThrow ClientM
deriving instance MonadCatch DOM => MonadCatch ClientM deriving instance MonadCatch DOM => MonadCatch ClientM
@ -86,18 +88,15 @@ instance Alt ClientM where
a <!> b = a `catchError` const b a <!> b = a `catchError` const b
instance RunClient ClientM where instance RunClient ClientM where
throwServantError = throwError throwClientError = throwError
runRequest r = do runRequest r = do
d <- ClientM askDOM d <- ClientM askDOM
performRequest d r performRequest d r
instance ClientLike (ClientM a) (ClientM a) where runClientM :: ClientM a -> ClientEnv -> DOM (Either ClientError a)
mkClient = id
runClientM :: ClientM a -> ClientEnv -> DOM (Either ServantError a)
runClientM cm env = runExceptT $ flip runReaderT env $ fromClientM cm 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 runClientM' m = do
burl <- getDefaultBaseUrl burl <- getDefaultBaseUrl
runClientM m (mkClientEnv burl) runClientM m (mkClientEnv burl)
@ -135,8 +134,9 @@ performRequest domc req = do
resp <- toResponse domc xhr resp <- toResponse domc xhr
let status = statusCode (responseStatusCode resp) let status = statusCode (responseStatusCode resp)
unless (status >= 200 && status < 300) $ unless (status >= 200 && status < 300) $ do
throwError $ FailureResponse resp let f b = (burl, L.toStrict $ toLazyByteString b)
throwError $ FailureResponse (bimap (const ()) f req) resp
pure 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 JS.open xhr (decodeUtf8Lenient $ requestMethod request) (toUrl burl request) True username password
setHeaders xhr request setHeaders xhr request
fixUp xhr fixUp xhr
waiter <- liftIO $ newEmptyMVar waiter <- liftIO $ newEmptyMVar
cleanup <- JSDOM.on xhr JS.readyStateChange $ do cleanup <- JSDOM.on xhr JS.readyStateChange $ do
@ -166,11 +166,11 @@ performXhr xhr burl request fixUp = do
_ -> return () _ -> return ()
sendXhr xhr (toBody request) sendXhr xhr (toBody request)
liftIO $ takeMVar waiter liftIO $ takeMVar waiter
cleanup cleanup
toUrl :: BaseUrl -> Request -> JS.JSString toUrl :: BaseUrl -> Request -> JS.JSString
toUrl burl request = toUrl burl request =
let pathS = JS.toJSString $ decodeUtf8Lenient $ L.toStrict $ toLazyByteString $ let pathS = JS.toJSString $ decodeUtf8Lenient $ L.toStrict $ toLazyByteString $
@ -223,14 +223,14 @@ toBody request = case requestBody request of
-- * inspecting the xhr response -- * inspecting the xhr response
-- This function is only supposed to handle 'ConnectionError's. Other -- 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 :: DOMContext -> JS.XMLHttpRequest -> ClientM Response
toResponse domc xhr = do toResponse domc xhr = do
let inDom :: DOM a -> ClientM a let inDom :: DOM a -> ClientM a
inDom = flip runDOM domc inDom = flip runDOM domc
status <- inDom $ JS.getStatus xhr status <- inDom $ JS.getStatus xhr
case status of case status of
0 -> throwError $ ConnectionError "connection error" 0 -> throwError $ ConnectionError $ SomeException $ userError "connection error"
_ -> inDom $ do _ -> inDom $ do
statusText <- BS.pack <$> JS.getStatusText xhr statusText <- BS.pack <$> JS.getStatusText xhr
headers <- parseHeaders <$> JS.getAllResponseHeaders xhr headers <- parseHeaders <$> JS.getAllResponseHeaders xhr

37
servant-client-jsaddle/test/Servant/Client/JsSpec.hs
View file

@ -6,31 +6,32 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Servant.Client.JsSpec where module Servant.Client.JsSpec where
import Servant.API import Control.Concurrent
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.Monad.Trans import Control.Monad.Trans
import Data.Aeson import Data.Aeson
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Proxy
import Data.String
import Data.Word import Data.Word
import GHC.Generics 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
import qualified JSDOM.Window as Window import qualified JSDOM.Window as Window
import qualified Network.Wai as Wai import Language.Javascript.JSaddle.Monad (JSM)
import Network.Wai.Middleware.AddHeaders import qualified Language.Javascript.JSaddle.Monad as JSaddle
import qualified Language.Javascript.JSaddle.Warp as JW
import qualified Network.HTTP.Types as Http import qualified Network.HTTP.Types as Http
import Data.String import qualified Network.Wai as Wai
import System.IO 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 type TestApi = ReqBody '[OctetStream] ByteString :> Post '[JSON] TestResponse
testApi :: Proxy TestApi testApi :: Proxy TestApi
testApi = Proxy testApi = Proxy
@ -90,8 +91,8 @@ spec = do
, baseUrlPort = fromIntegral portNr , baseUrlPort = fromIntegral portNr
, baseUrlPath = "/" , baseUrlPath = "/"
} }
WK.run $ JSaddle.liftJSM $ jsaddleFinally close $ do JW.run 3072 $ jsaddleFinally close $ do
liftIO $ threadDelay $ 1000 * 1000 liftIO $ threadDelay $ 1000 * 1000
-- a mix of valid utf-8 and non-utf8 bytes -- a mix of valid utf-8 and non-utf8 bytes
let bytes = [0x01, 0xff, 0x02, 0xfe, 0x03, 0xfd, 0x00, 0x64, 0xc3, 0xbb, 0x68, 0xc3] let bytes = [0x01, 0xff, 0x02, 0xfe, 0x03, 0xfd, 0x00, 0x64, 0xc3, 0xbb, 0x68, 0xc3]