Add servant-client-jsaddle
- servant-client-jsaddle: Remove some debug printing - Update .travis.yml with haskell-ci - servant-client-jsaddle: bump base bounds - Add libgirepository1.0-dev - servant-client-jsaddle: bump upper bound on containers - servant-client-jsaddle: relax upper bound on semigroupoids - servant-client-jsaddle: bump servant-client-core dependency - servant-client-jsaddle: fix compatibility - servant-client-jsaddle: import correct module - .travis.yml: run xvfb for headless GUI testing - Use ghcjs-dom instead of jsaddle-dom directly. - Also use ghcjs-dom in tests. - Ignore exceptions on send - they are handled in toResponse. - Apparently ghcjs-dom does use the same exception these days. - Got rid of obsolete comment. - Make sure response gets handled even in case of exception. - Update servant-client-jsaddle/servant-client-jsaddle.cabal Dependingon ghcjs-dom avoids the dependency on jsaddle-dom on ghcjs and have slightly better performance on ghcjs. Co-Authored-By: Herbert Valerio Riedel <hvr@gnu.org>
This commit is contained in:
Robert Hensing
Oleg Grenrus
parent
12e64fd3d2
commit
e14a14fb5c
15 changed files with 700 additions and 7 deletions
19
.travis.yml
19
.travis.yml
|
|
@ -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
|
||||||
|
|
|
||||||
2
Makefile
2
Makefile
|
|
@ -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 :
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
|
||||||
|
|
@ -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
BIN
screenshot.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 3.2 KiB |
4
servant-jsaddle/CHANGELOG.md
Normal file
4
servant-jsaddle/CHANGELOG.md
Normal file
|
|
@ -0,0 +1,4 @@
|
||||||
|
X.Y
|
||||||
|
----
|
||||||
|
|
||||||
|
Initial release
|
||||||
30
servant-jsaddle/LICENSE
Normal file
30
servant-jsaddle/LICENSE
Normal 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
15
servant-jsaddle/README.md
Normal 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
2
servant-jsaddle/Setup.hs
Normal file
|
|
@ -0,0 +1,2 @@
|
||||||
|
import Distribution.Simple
|
||||||
|
main = defaultMain
|
||||||
125
servant-jsaddle/servant-jsaddle.cabal
Normal file
125
servant-jsaddle/servant-jsaddle.cabal
Normal 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
|
||||||
311
servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs
Normal file
311
servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs
Normal 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
|
||||||
20
servant-jsaddle/src/Servant/Client/JSaddle.hs
Normal file
20
servant-jsaddle/src/Servant/Client/JSaddle.hs
Normal 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
|
||||||
163
servant-jsaddle/test/Servant/Client/JSaddleSpec.hs
Normal file
163
servant-jsaddle/test/Servant/Client/JSaddleSpec.hs
Normal 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
|
||||||
8
servant-jsaddle/test/Spec.hs
Normal file
8
servant-jsaddle/test/Spec.hs
Normal 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
|
||||||
Loading…
Reference in a new issue