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
17
.travis.yml
17
.travis.yml
|
|
@ -4,7 +4,7 @@
|
|||
#
|
||||
# For more information, see https://github.com/haskell-CI/haskell-ci
|
||||
#
|
||||
# version: 0.5.20180907
|
||||
# version: 0.5.20190908
|
||||
#
|
||||
language: c
|
||||
dist: xenial
|
||||
|
|
@ -14,6 +14,8 @@ git:
|
|||
branches:
|
||||
only:
|
||||
- master
|
||||
addons:
|
||||
google: stable
|
||||
cache:
|
||||
directories:
|
||||
- $HOME/.cabal/packages
|
||||
|
|
@ -115,12 +117,14 @@ install:
|
|||
echo " prefix: $CABALHOME" >> $CABALHOME/config
|
||||
echo "repository hackage.haskell.org" >> $CABALHOME/config
|
||||
echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
|
||||
- GHCJOBS=-j2
|
||||
- |
|
||||
echo "program-default-options" >> $CABALHOME/config
|
||||
echo " ghc-options: -j2" >> $CABALHOME/config
|
||||
echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
|
||||
- cat $CABALHOME/config
|
||||
- rm -fv cabal.project cabal.project.local cabal.project.freeze
|
||||
- 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
|
||||
# Generate cabal.project
|
||||
- rm -rf cabal.project cabal.project.local cabal.project.freeze
|
||||
|
|
@ -128,6 +132,7 @@ install:
|
|||
- |
|
||||
echo "packages: servant" >> cabal.project
|
||||
if ! $GHCJS ; then echo "packages: servant-client" >> cabal.project ; fi
|
||||
echo "packages: servant-jsaddle" >> 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-docs" >> cabal.project ; fi
|
||||
|
|
@ -165,11 +170,12 @@ install:
|
|||
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 "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.local || true
|
||||
- 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-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-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
|
||||
|
|
@ -209,6 +215,7 @@ script:
|
|||
- find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
|
||||
- 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_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_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.]*')"
|
||||
|
|
@ -237,6 +244,7 @@ script:
|
|||
- |
|
||||
echo "packages: ${PKGDIR_servant}" >> cabal.project
|
||||
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
|
||||
if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_http_streams}" >> 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: openssl-streams-1.2.2.0:network" >> 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.local || true
|
||||
- echo -en 'travis_fold:end:unpack\\r'
|
||||
|
|
@ -285,6 +293,7 @@ script:
|
|||
- echo -en 'travis_fold:end:build-everything\\r'
|
||||
# Testing...
|
||||
- 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...
|
||||
- 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
|
||||
|
|
|
|||
2
Makefile
2
Makefile
|
|
@ -9,7 +9,7 @@ really-all :
|
|||
$(MAKE) build-ghc
|
||||
$(MAKE) build-ghc HC=ghc-8.0.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
|
||||
|
||||
build-ghc :
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
packages:
|
||||
servant/
|
||||
servant-client-core/
|
||||
servant-client-ghcjs/
|
||||
servant-jsaddle/
|
||||
|
||||
-- we need to tell cabal we are using GHCJS
|
||||
compiler: ghcjs
|
||||
tests: True
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
folds: all-but-test
|
||||
branches: master
|
||||
jobs-selection: any
|
||||
google-chrome: True
|
||||
ghcjs-tests: True
|
||||
|
||||
-- https://github.com/haskell/cabal/issues/6176
|
||||
ghcjs-tools: hspec-discover
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
packages:
|
||||
servant/
|
||||
servant-client/
|
||||
servant-jsaddle/
|
||||
servant-client-core/
|
||||
servant-http-streams/
|
||||
servant-docs/
|
||||
|
|
@ -32,6 +33,8 @@ packages:
|
|||
doc/cookbook/using-free-client
|
||||
-- doc/cookbook/open-id-connect
|
||||
|
||||
|
||||
|
||||
tests: True
|
||||
optimization: False
|
||||
-- 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