Merge pull request #1216 from haskell-servant/servant-client-jsaddle

Add servant-jsaddle
This commit is contained in:
Oleg Grenrus 2019-09-08 10:59:01 +02:00 committed by GitHub
commit 6e3af85c93
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
15 changed files with 700 additions and 7 deletions

View file

@ -4,7 +4,7 @@
# #
# For more information, see https://github.com/haskell-CI/haskell-ci # For more information, see https://github.com/haskell-CI/haskell-ci
# #
# version: 0.5.20180907 # version: 0.5.20190908
# #
language: c language: c
dist: xenial dist: xenial
@ -14,6 +14,8 @@ git:
branches: branches:
only: only:
- master - master
addons:
google: stable
cache: cache:
directories: directories:
- $HOME/.cabal/packages - $HOME/.cabal/packages
@ -115,12 +117,14 @@ install:
echo " prefix: $CABALHOME" >> $CABALHOME/config echo " prefix: $CABALHOME" >> $CABALHOME/config
echo "repository hackage.haskell.org" >> $CABALHOME/config echo "repository hackage.haskell.org" >> $CABALHOME/config
echo " url: http://hackage.haskell.org/" >> $CABALHOME/config echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
- GHCJOBS=-j2
- | - |
echo "program-default-options" >> $CABALHOME/config echo "program-default-options" >> $CABALHOME/config
echo " ghc-options: -j2" >> $CABALHOME/config echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
- cat $CABALHOME/config - cat $CABALHOME/config
- rm -fv cabal.project cabal.project.local cabal.project.freeze - rm -fv cabal.project cabal.project.local cabal.project.freeze
- travis_retry ${CABAL} v2-update -v - travis_retry ${CABAL} v2-update -v
- if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 cabal-plan | color_cabal_output) ; fi
- if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 hspec-discover | color_cabal_output) ; fi - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 hspec-discover | color_cabal_output) ; fi
# Generate cabal.project # Generate cabal.project
- rm -rf cabal.project cabal.project.local cabal.project.freeze - rm -rf cabal.project cabal.project.local cabal.project.freeze
@ -128,6 +132,7 @@ install:
- | - |
echo "packages: servant" >> cabal.project echo "packages: servant" >> cabal.project
if ! $GHCJS ; then echo "packages: servant-client" >> cabal.project ; fi if ! $GHCJS ; then echo "packages: servant-client" >> cabal.project ; fi
echo "packages: servant-jsaddle" >> cabal.project
echo "packages: servant-client-core" >> cabal.project echo "packages: servant-client-core" >> cabal.project
if ! $GHCJS ; then echo "packages: servant-http-streams" >> cabal.project ; fi if ! $GHCJS ; then echo "packages: servant-http-streams" >> cabal.project ; fi
if ! $GHCJS ; then echo "packages: servant-docs" >> cabal.project ; fi if ! $GHCJS ; then echo "packages: servant-docs" >> cabal.project ; fi
@ -165,11 +170,12 @@ install:
echo "allow-newer: io-streams-1.5.1.0:network" >> cabal.project echo "allow-newer: io-streams-1.5.1.0:network" >> cabal.project
echo "allow-newer: openssl-streams-1.2.2.0:network" >> cabal.project echo "allow-newer: openssl-streams-1.2.2.0:network" >> cabal.project
echo "optimization: False" >> cabal.project echo "optimization: False" >> cabal.project
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-db-sqlite-simple|cookbook-file-upload|cookbook-generic|cookbook-https|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-db-sqlite-simple|cookbook-file-upload|cookbook-generic|cookbook-https|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-jsaddle|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
- cat cabal.project || true - cat cabal.project || true
- cat cabal.project.local || true - cat cabal.project.local || true
- if [ -f "servant/configure.ac" ]; then (cd "servant" && autoreconf -i); fi - if [ -f "servant/configure.ac" ]; then (cd "servant" && autoreconf -i); fi
- if [ -f "servant-client/configure.ac" ]; then (cd "servant-client" && autoreconf -i); fi - if [ -f "servant-client/configure.ac" ]; then (cd "servant-client" && autoreconf -i); fi
- if [ -f "servant-jsaddle/configure.ac" ]; then (cd "servant-jsaddle" && autoreconf -i); fi
- if [ -f "servant-client-core/configure.ac" ]; then (cd "servant-client-core" && autoreconf -i); fi - if [ -f "servant-client-core/configure.ac" ]; then (cd "servant-client-core" && autoreconf -i); fi
- if [ -f "servant-http-streams/configure.ac" ]; then (cd "servant-http-streams" && autoreconf -i); fi - if [ -f "servant-http-streams/configure.ac" ]; then (cd "servant-http-streams" && autoreconf -i); fi
- if [ -f "servant-docs/configure.ac" ]; then (cd "servant-docs" && autoreconf -i); fi - if [ -f "servant-docs/configure.ac" ]; then (cd "servant-docs" && autoreconf -i); fi
@ -209,6 +215,7 @@ script:
- find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
- PKGDIR_servant="$(find . -maxdepth 1 -type d -regex '.*/servant-[0-9.]*')" - PKGDIR_servant="$(find . -maxdepth 1 -type d -regex '.*/servant-[0-9.]*')"
- PKGDIR_servant_client="$(find . -maxdepth 1 -type d -regex '.*/servant-client-[0-9.]*')" - PKGDIR_servant_client="$(find . -maxdepth 1 -type d -regex '.*/servant-client-[0-9.]*')"
- PKGDIR_servant_jsaddle="$(find . -maxdepth 1 -type d -regex '.*/servant-jsaddle-[0-9.]*')"
- PKGDIR_servant_client_core="$(find . -maxdepth 1 -type d -regex '.*/servant-client-core-[0-9.]*')" - PKGDIR_servant_client_core="$(find . -maxdepth 1 -type d -regex '.*/servant-client-core-[0-9.]*')"
- PKGDIR_servant_http_streams="$(find . -maxdepth 1 -type d -regex '.*/servant-http-streams-[0-9.]*')" - PKGDIR_servant_http_streams="$(find . -maxdepth 1 -type d -regex '.*/servant-http-streams-[0-9.]*')"
- PKGDIR_servant_docs="$(find . -maxdepth 1 -type d -regex '.*/servant-docs-[0-9.]*')" - PKGDIR_servant_docs="$(find . -maxdepth 1 -type d -regex '.*/servant-docs-[0-9.]*')"
@ -237,6 +244,7 @@ script:
- | - |
echo "packages: ${PKGDIR_servant}" >> cabal.project echo "packages: ${PKGDIR_servant}" >> cabal.project
if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_client}" >> cabal.project ; fi if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_client}" >> cabal.project ; fi
echo "packages: ${PKGDIR_servant_jsaddle}" >> cabal.project
echo "packages: ${PKGDIR_servant_client_core}" >> cabal.project echo "packages: ${PKGDIR_servant_client_core}" >> cabal.project
if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_http_streams}" >> cabal.project ; fi if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_http_streams}" >> cabal.project ; fi
if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_docs}" >> cabal.project ; fi if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_docs}" >> cabal.project ; fi
@ -274,7 +282,7 @@ script:
echo "allow-newer: io-streams-1.5.1.0:network" >> cabal.project echo "allow-newer: io-streams-1.5.1.0:network" >> cabal.project
echo "allow-newer: openssl-streams-1.2.2.0:network" >> cabal.project echo "allow-newer: openssl-streams-1.2.2.0:network" >> cabal.project
echo "optimization: False" >> cabal.project echo "optimization: False" >> cabal.project
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-db-sqlite-simple|cookbook-file-upload|cookbook-generic|cookbook-https|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-db-sqlite-simple|cookbook-file-upload|cookbook-generic|cookbook-https|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-jsaddle|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
- cat cabal.project || true - cat cabal.project || true
- cat cabal.project.local || true - cat cabal.project.local || true
- echo -en 'travis_fold:end:unpack\\r' - echo -en 'travis_fold:end:unpack\\r'
@ -285,6 +293,7 @@ script:
- echo -en 'travis_fold:end:build-everything\\r' - echo -en 'travis_fold:end:build-everything\\r'
# Testing... # Testing...
- if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
- if $GHCJS ; then for testexe in $(cabal-plan list-bins '*:test:*' | awk '{ print $2 }'); do echo $testexe; nodejs ${testexe}.jsexe/all.js; done ; fi
# haddock... # haddock...
- echo 'haddock...' && echo -en 'travis_fold:start:haddock\\r' - echo 'haddock...' && echo -en 'travis_fold:start:haddock\\r'
- if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output ; fi - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output ; fi

View file

@ -9,7 +9,7 @@ really-all :
$(MAKE) build-ghc $(MAKE) build-ghc
$(MAKE) build-ghc HC=ghc-8.0.2 $(MAKE) build-ghc HC=ghc-8.0.2
$(MAKE) build-ghc HC=ghc-8.2.2 $(MAKE) build-ghc HC=ghc-8.2.2
$(MAKE) build-ghc HC=ghc-8.6.3 $(MAKE) build-ghc HC=ghc-8.6.5
$(MAKE) build-ghcjs $(MAKE) build-ghcjs
build-ghc : build-ghc :

View file

@ -3,7 +3,8 @@
packages: packages:
servant/ servant/
servant-client-core/ servant-client-core/
servant-client-ghcjs/ servant-jsaddle/
-- we need to tell cabal we are using GHCJS -- we need to tell cabal we are using GHCJS
compiler: ghcjs compiler: ghcjs
tests: True

View file

@ -1,6 +1,8 @@
folds: all-but-test folds: all-but-test
branches: master branches: master
jobs-selection: any jobs-selection: any
google-chrome: True
ghcjs-tests: True
-- https://github.com/haskell/cabal/issues/6176 -- https://github.com/haskell/cabal/issues/6176
ghcjs-tools: hspec-discover ghcjs-tools: hspec-discover

View file

@ -1,6 +1,7 @@
packages: packages:
servant/ servant/
servant-client/ servant-client/
servant-jsaddle/
servant-client-core/ servant-client-core/
servant-http-streams/ servant-http-streams/
servant-docs/ servant-docs/
@ -32,6 +33,8 @@ packages:
doc/cookbook/using-free-client doc/cookbook/using-free-client
-- doc/cookbook/open-id-connect -- doc/cookbook/open-id-connect
tests: True tests: True
optimization: False optimization: False
-- reorder-goals: True -- reorder-goals: True

BIN
screenshot.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 3.2 KiB

View file

@ -0,0 +1,4 @@
X.Y
----
Initial release

30
servant-jsaddle/LICENSE Normal file
View file

@ -0,0 +1,30 @@
Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Zalora South East Asia Pte Ltd nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

15
servant-jsaddle/README.md Normal file
View file

@ -0,0 +1,15 @@
# `servant-client-jsaddle`
This is a an implementation of the `servant-client-core` API on top of `jsaddle`, a framework that lets you write Haskell programs that compile to javascript to run in a browser or compile to native code that connects to a browser.
It is similar to `servant-client-ghcjs`, except it supports native compilation and native GHCi. It even reuses some of the logic from `servant-client-ghcjs`.
# Build
This package comes with a test suite that depends on `jsaddle-webkit2gtk`. You may want to skip that because of the heavy dependency footprint.
cabal new-build --allow-newer=aeson,http-types --disable-tests
# Usage
TBD. Similar to `servant-client` and `servant-client-ghcjs`.

2
servant-jsaddle/Setup.hs Normal file
View file

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

View file

@ -0,0 +1,125 @@
name: servant-jsaddle
version: 0.16
synopsis:
automatic derivation of querying functions for servant webservices for jsaddle
description:
This library lets you automatically derive Haskell functions that
let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
.
See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.
.
<https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
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
category: Servant, Web
build-type: Simple
cabal-version: >=1.10
tested-with:
GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5
, GHCJS ==8.4
homepage: http://haskell-servant.readthedocs.org/
bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files:
CHANGELOG.md
README.md
source-repository head
type: git
location: http://github.com/haskell-servant/servant.git
library
default-language: Haskell2010
hs-source-dirs: src
ghc-options: -Wall
exposed-modules:
Servant.Client.Internal.JSaddleXhrClient
Servant.Client.JSaddle
-- Bundled with GHC: Lower bound to not force re-installs
-- text and mtl are bundled starting with GHC-8.4
build-depends:
base >=4.9 && <4.13
, bytestring >=0.10.8.1 && <0.11
, containers >=0.5.7.1 && <0.7
, mtl >=2.2.2 && <2.3
, text >=1.2.3.0 && <1.3
, transformers >=0.5.2.0 && <0.6
if impl(ghcjs -any)
build-depends: ghcjs-base
-- Servant dependencies.
-- Strict dependency on `servant-client-core` as we re-export things.
build-depends: servant-client-core >=0.16 && <0.16.1
build-depends:
base-compat >=0.10.5 && <0.11
, case-insensitive >=1.2.0.0 && <1.3
, exceptions >=0.10.0 && <0.11
, ghcjs-dom
, http-media >=0.7.1.3 && <0.9
, http-types >=0.12.2 && <0.13
, jsaddle >=0.9.6.0 && <0.10
, monad-control >=1.0.2.3 && <1.1
, semigroupoids >=5.3.1 && <5.4
, string-conversions >=0.3 && <0.5
, transformers-base >=0.4.4 && <0.5
if impl(ghc >=8.0)
ghc-options: -Wno-redundant-constraints
test-suite spec
type: exitcode-stdio-1.0
ghc-options: -Wall
default-language: Haskell2010
hs-source-dirs: test
main-is: Spec.hs
if impl(ghcjs -any)
build-depends:
base
, servant-jsaddle
else
other-modules: Servant.Client.JSaddleSpec
-- Dependencies inherited from the library. No need to specify bounds.
build-depends:
base
, bytestring
, containers
, exceptions
, ghcjs-dom
, http-media
, http-types
, jsaddle
, mtl
, process
, semigroupoids
, servant
, servant-client-core
, servant-jsaddle
, servant-server
, string-conversions
, text
, wai
, wai-cors
, wai-extra
, warp
, websockets
-- Additonal dependencies
build-depends:
aeson
, hspec
, jsaddle-warp
, QuickCheck
build-tool-depends: hspec-discover:hspec-discover >=2.4.4 && <2.5

View file

@ -0,0 +1,311 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Servant.Client.Internal.JSaddleXhrClient where
import Prelude ()
import Prelude.Compat
import Control.Concurrent
(MVar, newEmptyMVar, takeMVar, tryPutMVar)
import Control.Exception
(Exception, toException)
import Control.Monad
(forM_, unless, void)
import Control.Monad.Catch
(MonadCatch, MonadThrow, catch)
import Control.Monad.Error.Class
(MonadError (..))
import Control.Monad.IO.Class
(MonadIO (..))
import Control.Monad.Reader
(MonadReader, ReaderT, asks, runReaderT)
import Control.Monad.Trans.Except
(ExceptT, runExceptT)
import Data.Bifunctor
(bimap, first, second)
import Data.ByteString.Builder
(toLazyByteString)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy as L
import Data.CaseInsensitive
(mk, original)
import Data.Char
(isSpace)
import Data.Foldable
(toList)
import Data.Functor.Alt
(Alt (..))
import Data.Proxy
(Proxy (..))
import qualified Data.Sequence as Seq
import Data.String.Conversions
(cs)
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import GHC.Generics
import qualified GHCJS.Buffer as Buffer
import qualified GHCJS.DOM
import qualified GHCJS.DOM.EventM as JSDOM
import qualified GHCJS.DOM.Location as Location
import GHCJS.DOM.Types
(DOM, DOMContext, askDOM, runDOM)
import qualified GHCJS.DOM.Types as JS
import qualified GHCJS.DOM.Window as Window
import qualified GHCJS.DOM.XMLHttpRequest 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
(ResponseHeaders, http11, mkStatus, renderQuery, statusCode)
import System.IO
(hPutStrLn, stderr)
import Servant.Client.Core
-- Note: assuming encoding UTF-8
data ClientEnv
= ClientEnv
{ baseUrl :: BaseUrl
-- | Modify the XMLHttpRequest at will, right before sending.
, fixUpXhr :: JS.XMLHttpRequest -> DOM ()
}
data JSaddleConnectionError = JSaddleConnectionError
deriving (Eq, Show)
instance Exception JSaddleConnectionError
-- | Default 'ClientEnv'
mkClientEnv :: BaseUrl -> ClientEnv
mkClientEnv burl = ClientEnv burl (const (pure ()))
instance Show ClientEnv where
showsPrec prec (ClientEnv burl _) =
showParen (prec >= 11)
( showString "ClientEnv {"
. showString "baseUrl = "
. showsPrec 0 burl
. showString ", fixUpXhr = <function>"
. showString "}"
)
client :: HasClient ClientM api => Proxy api -> Client ClientM api
client api = api `clientIn` (Proxy :: Proxy ClientM)
newtype ClientM a = ClientM
{ fromClientM :: ReaderT ClientEnv (ExceptT ClientError DOM) a }
deriving ( Functor, Applicative, Monad, MonadIO, Generic
, MonadReader ClientEnv, MonadError ClientError)
deriving instance MonadThrow DOM => MonadThrow ClientM
deriving instance MonadCatch DOM => MonadCatch ClientM
-- | Try clients in order, last error is preserved.
instance Alt ClientM where
a <!> b = a `catchError` const b
instance RunClient ClientM where
throwClientError = throwError
runRequest r = do
d <- ClientM askDOM
performRequest d r
runClientM :: ClientM a -> ClientEnv -> DOM (Either ClientError a)
runClientM cm env = runExceptT $ flip runReaderT env $ fromClientM cm
runClientM' :: ClientM a -> DOM (Either ClientError a)
runClientM' m = do
burl <- getDefaultBaseUrl
runClientM m (mkClientEnv burl)
getDefaultBaseUrl :: DOM BaseUrl
getDefaultBaseUrl = do
win <- GHCJS.DOM.currentWindow >>= \mw -> case mw of
Just x -> pure x
Nothing -> fail "Can not determine default base url without window."
curLoc <- Window.getLocation win
protocolStr <- Location.getProtocol curLoc
portStr <- Location.getPort curLoc
hostname <- Location.getHostname curLoc
let protocol
| (protocolStr :: JS.JSString) == "https:"
= Https
| otherwise = Http
port :: Int
port | null portStr = case protocol of
Http -> 80
Https -> 443
| otherwise = read portStr
pure (BaseUrl protocol hostname port "")
performRequest :: DOMContext -> Request -> ClientM Response
performRequest domc req = do
xhr <- JS.newXMLHttpRequest `runDOM` domc
burl <- asks baseUrl
fixUp <- asks fixUpXhr
performXhr xhr burl req fixUp `runDOM` domc
resp <- toResponse domc xhr
let status = statusCode (responseStatusCode resp)
unless (status >= 200 && status < 300) $
throwError $ mkFailureResponse burl req resp
pure resp
-- * performing requests
-- Performs the xhr and blocks until the response was received
performXhr :: JS.XMLHttpRequest -> BaseUrl -> Request -> (JS.XMLHttpRequest -> DOM ()) -> DOM ()
performXhr xhr burl request fixUp = do
let username, password :: Maybe JS.JSString
username = Nothing; password = Nothing
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
state <- JS.getReadyState xhr
case state of
-- onReadyStateChange's callback can fire state 4
-- (which means "request finished and response is ready")
-- multiple times. By using tryPutMVar, only the first time
-- state 4 is fired will cause an MVar to be put. Subsequent
-- fires are ignored.
4 -> void $ liftIO $ tryPutMVar waiter ()
_ -> return ()
sendXhr xhr (toBody request) `catch` handleXHRError waiter -- We handle any errors in `toResponse`.
liftIO $ takeMVar waiter
cleanup
where
handleXHRError :: MVar () -> JS.XHRError -> DOM ()
handleXHRError waiter e = do
liftIO $ hPutStrLn stderr $ "servant-client-jsaddle: exception in `sendXhr` (should get handled in response handling): " <> show e
void $ liftIO $ tryPutMVar waiter ()
toUrl :: BaseUrl -> Request -> JS.JSString
toUrl burl request =
let pathS = JS.toJSString $ decodeUtf8Lenient $ L.toStrict $ toLazyByteString $
requestPath request
queryS =
JS.toJSString $ decodeUtf8Lenient $
renderQuery True $
toList $
requestQueryString request
in JS.toJSString (showBaseUrl burl) <> pathS <> queryS :: JS.JSString
setHeaders :: JS.XMLHttpRequest -> Request -> DOM ()
setHeaders xhr request = do
forM_ (toList $ requestAccept request) $ \mediaType -> -- FIXME review
JS.setRequestHeader
xhr
("Accept" :: JS.JSString)
(decodeUtf8Lenient $ renderHeader mediaType)
forM_ (requestBody request) $ \(_, mediaType) ->
JS.setRequestHeader
xhr
("Content-Type" :: JS.JSString)
(decodeUtf8Lenient $ renderHeader mediaType)
forM_ (toList $ requestHeaders request) $ \(key, value) ->
JS.setRequestHeader xhr (decodeUtf8Lenient $ original key) (decodeUtf8Lenient value)
-- ArrayBufferView is a type that only exists in the spec and covers many concrete types.
castMutableArrayBufferToArrayBufferView :: ArrayBuffer.MutableArrayBuffer -> DOM JS.ArrayBufferView
castMutableArrayBufferToArrayBufferView x = JS.liftJSM $ do
JS.fromJSValUnchecked $ JS.pToJSVal x
mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError
mkFailureResponse burl request =
FailureResponse (bimap (const ()) f request)
where
f b = (burl, BSL.toStrict $ toLazyByteString b)
sendXhr :: JS.XMLHttpRequest -> Maybe L.ByteString -> DOM ()
sendXhr xhr Nothing = JS.send xhr
sendXhr xhr (Just body) = do
-- Reason for copy: hopefully offset will be 0 and length b == len
-- FIXME: use a typed array constructor that accepts offset and length and skip the copy
(b, _offset, _len) <- JSaddle.ghcjsPure $ Buffer.fromByteString $ BS.copy $ L.toStrict body
b' <- Buffer.thaw b
b'' <- JSaddle.ghcjsPure $ Buffer.getArrayBuffer b'
JS.sendArrayBuffer xhr =<< castMutableArrayBufferToArrayBufferView b''
toBody :: Request -> Maybe L.ByteString
toBody request = case requestBody request of
Nothing -> Nothing
Just (RequestBodyLBS "", _) -> Nothing
Just (RequestBodyLBS x, _) -> Just x
Just (RequestBodyBS "", _) -> Nothing
Just (RequestBodyBS x, _) -> Just $ L.fromStrict x
Just (RequestBodySource _, _) -> error "RequestBodySource isn't supported"
-- * inspecting the xhr response
-- This function is only supposed to handle 'ConnectionError's. Other
-- '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 $ toException JSaddleConnectionError
_ -> inDom $ do
statusText <- BS.pack <$> JS.getStatusText xhr
headers <- parseHeaders <$> JS.getAllResponseHeaders xhr
responseText <- maybe "" (L.fromStrict . BS.pack) <$> JS.getResponseText xhr -- FIXME: Text/Binary? Performance? Test?
pure Response
{ responseStatusCode = mkStatus (fromIntegral status) statusText
, responseBody = responseText
, responseHeaders = Seq.fromList headers
, responseHttpVersion = http11 -- this is made up
}
parseHeaders :: String -> ResponseHeaders
parseHeaders s =
(first mk . first strip . second strip . 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
decodeUtf8Lenient :: BS.ByteString -> JS.JSString
decodeUtf8Lenient = JS.toJSString . T.decodeUtf8With T.lenientDecode

View file

@ -0,0 +1,20 @@
-- | This module provides 'client' which can automatically generate
-- querying functions for each endpoint just from the type representing your
-- API.
module Servant.Client.JSaddle
(
client
, ClientM
, runClientM
, runClientM'
-- * Configuration
, ClientEnv(..)
, mkClientEnv
, getDefaultBaseUrl
, module Servant.Client.Core.Reexport
) where
import Servant.Client.Internal.JSaddleXhrClient
import Servant.Client.Core.Reexport

View file

@ -0,0 +1,163 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Client.JSaddleSpec where
import Control.Concurrent
(threadDelay)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
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 GHCJS.DOM
import qualified GHCJS.DOM.Window as Window
import Language.Javascript.JSaddle.Monad
(JSM)
import qualified Language.Javascript.JSaddle.Monad as JSaddle
import qualified Language.Javascript.JSaddle.Run as Run
import qualified Language.Javascript.JSaddle.WebSockets as WS
import qualified Network.HTTP.Types as Http
import qualified Network.Wai as Wai
import Network.Wai.Handler.Warp as Warp
import qualified System.Process as P
import Network.Wai.Middleware.AddHeaders
import Network.Wai.Middleware.Cors
(simpleCors)
import Network.WebSockets
(defaultConnectionOptions)
import Servant.API
import Servant.Client.JSaddle
import Servant.Server
import Test.Hspec
type TestApi = ReqBody '[OctetStream] ByteString :> Post '[JSON] TestResponse
testApi :: Proxy TestApi
testApi = Proxy
data TestResponse = TestResponse { byteList :: [Word8] }
deriving (Generic, ToJSON, FromJSON, Show, Eq)
testServer :: Server TestApi
testServer x = do
pure . TestResponse . B.unpack $ x
testClient :: Client ClientM TestApi
testClient = client testApi
-- WARNING: approximation!
jsaddleFinally :: JSM b -> JSM a -> JSM a
jsaddleFinally handler m = JSaddle.bracket (pure ()) (const handler) (const m)
-- jsaddleFinally handler m = JSaddle.catch (m <* handler) (\e -> handler >> throw (e :: SomeException))
close :: JSM ()
close = do
mw <- GHCJS.DOM.currentWindow
case mw of
Just w -> do
liftIO $ putStrLn "Closing window..."
Window.close w
Nothing -> liftIO $ putStrLn "Can't close the window!"
spec :: Spec
spec = do
describe "Servant.Client.JSaddle" $ do
it "Receive a properly encoded response" $ do
-- A mvar to tell promptly when we are done
done <- newEmptyMVar
-- How this work:
--
-- 1. we start server warp, which serves simple API
-- 2. we start client warp, which serves jsaddle running the 'action'
-- 3. we run google-chrome-stable to open jsaddle page and to run the test
let action :: Int -> JSM ()
action serverPort = do
liftIO $ threadDelay $ 500 * 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]
response <- flip runClientM clientEnv $ testClient (B.pack bytes)
liftIO $ print response
liftIO $ response `shouldBe` Right (TestResponse bytes)
-- we are done.
liftIO $ putMVar done ()
where
clientEnv = mkClientEnv BaseUrl
{ baseUrlScheme = Http
, baseUrlHost = "localhost"
, baseUrlPort = fromIntegral serverPort
, baseUrlPath = "/"
}
let serverApp :: IO Application
serverApp = pure $ logRequest $ addCors $ serve testApi testServer
Warp.testWithApplication serverApp $ \serverPort -> do
let clientApp :: IO Application
clientApp = WS.jsaddleOr defaultConnectionOptions (action serverPort >> Run.syncPoint) WS.jsaddleApp
Warp.testWithApplication (simpleCors <$> clientApp) $ \clientPort -> do
putStrLn $ "server http://localhost:" ++ show serverPort
putStrLn $ "client http://localhost:" ++ show clientPort
putStrLn $ "google-chrome-stable --headless --disable-gpu --screenshot http://localhost:" ++ show clientPort
-- threadDelay $ 1000 * 1000 * 1000
-- Run headless chrome
-- https://docs.travis-ci.com/user/gui-and-headless-browsers/#using-the-chrome-addon-in-the-headless-mode
-- https://developers.google.com/web/updates/2017/04/headless-chrome
hdl <- P.spawnProcess "google-chrome-stable"
[ "--headless"
, "--disable-gpu"
, "--remote-debugging-port=9222" -- TODO: bind to random port
, "http://localhost:" ++ show clientPort
]
-- wait for test to run.
takeMVar done
-- kill chrome
P.terminateProcess hdl
-------------------------------------------------------------------------------
-- Logger middleware
-------------------------------------------------------------------------------
logRequest :: Wai.Middleware
logRequest app request respond = do
putStrLn "Request"
print request
app request $ \response -> do
putStrLn "Response Headers"
mapM_ print (Wai.responseHeaders response)
respond response
-------------------------------------------------------------------------------
-- OPTIONS
-------------------------------------------------------------------------------
corsHeaders :: (IsString s1, IsString s2) => [(s1, s2)]
corsHeaders =
[ ("Access-Control-Allow-Origin", "*")
, ("Access-Control-Allow-Methods", "POST")
, ("Access-Control-Allow-Headers", "content-type")
]
addCors :: Wai.Middleware
addCors app request respond =
if Wai.requestMethod request == "OPTIONS"
then respond $ Wai.responseLBS Http.status200 corsHeaders ""
else addHeaders corsHeaders app request respond

View file

@ -0,0 +1,8 @@
{-# LANGUAGE CPP #-}
#ifdef __GHCJS__
module Main (main) where
main :: IO ()
main = return ()
#else
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
#endif