Remove servant-jssadle (moved to own repository)
This commit is contained in:
Oleg Grenrus
parent
831f46ab78
commit
21e6000b09
11 changed files with 0 additions and 726 deletions
24
.travis.yml
24
.travis.yml
|
|
@ -157,18 +157,6 @@ 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: io-streams-1.5.1.0:primitive" >> cabal.project
|
echo "allow-newer: io-streams-1.5.1.0:primitive" >> 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 "allow-newer: jsaddle-0.9.6.0:lens" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-0.9.6.0:primitive" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-0.9.6.0:time" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.1:base" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.1:base-compat" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.1:Cabal" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.1:lens" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.2:base" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.2:base-compat" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.2:Cabal" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.2:lens" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-warp-0.9.6.0:time" >> 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-file-upload|cookbook-generic|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-file-upload|cookbook-generic|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"
|
||||||
- cat cabal.project || true
|
- cat cabal.project || true
|
||||||
|
|
@ -271,18 +259,6 @@ 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: io-streams-1.5.1.0:primitive" >> cabal.project
|
echo "allow-newer: io-streams-1.5.1.0:primitive" >> 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 "allow-newer: jsaddle-0.9.6.0:lens" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-0.9.6.0:primitive" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-0.9.6.0:time" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.1:base" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.1:base-compat" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.1:Cabal" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.1:lens" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.2:base" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.2:base-compat" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.2:Cabal" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-dom-0.9.3.2:lens" >> cabal.project
|
|
||||||
echo "allow-newer: jsaddle-warp-0.9.6.0:time" >> 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-file-upload|cookbook-generic|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-file-upload|cookbook-generic|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"
|
||||||
- cat cabal.project || true
|
- cat cabal.project || true
|
||||||
|
|
|
||||||
|
|
@ -61,20 +61,6 @@ allow-newer: openssl-streams-1.2.2.0:network
|
||||||
-- https://github.com/nurpax/sqlite-simple/issues/74
|
-- https://github.com/nurpax/sqlite-simple/issues/74
|
||||||
constraints: sqlite-simple < 0
|
constraints: sqlite-simple < 0
|
||||||
|
|
||||||
-- jsaddle
|
|
||||||
allow-newer: jsaddle-0.9.6.0:lens
|
|
||||||
allow-newer: jsaddle-0.9.6.0:primitive
|
|
||||||
allow-newer: jsaddle-0.9.6.0:time
|
|
||||||
allow-newer: jsaddle-dom-0.9.3.1:base
|
|
||||||
allow-newer: jsaddle-dom-0.9.3.1:base-compat
|
|
||||||
allow-newer: jsaddle-dom-0.9.3.1:Cabal
|
|
||||||
allow-newer: jsaddle-dom-0.9.3.1:lens
|
|
||||||
allow-newer: jsaddle-dom-0.9.3.2:base
|
|
||||||
allow-newer: jsaddle-dom-0.9.3.2:base-compat
|
|
||||||
allow-newer: jsaddle-dom-0.9.3.2:Cabal
|
|
||||||
allow-newer: jsaddle-dom-0.9.3.2:lens
|
|
||||||
allow-newer: jsaddle-warp-0.9.6.0:time
|
|
||||||
|
|
||||||
constraints: base-compat ^>=0.11
|
constraints: base-compat ^>=0.11
|
||||||
|
|
||||||
-- needed for doctests
|
-- needed for doctests
|
||||||
|
|
|
||||||
|
|
@ -1,4 +0,0 @@
|
||||||
X.Y
|
|
||||||
----
|
|
||||||
|
|
||||||
Initial release
|
|
||||||
|
|
@ -1,30 +0,0 @@
|
||||||
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.
|
|
||||||
|
|
@ -1,15 +0,0 @@
|
||||||
# `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`.
|
|
||||||
|
|
@ -1,2 +0,0 @@
|
||||||
import Distribution.Simple
|
|
||||||
main = defaultMain
|
|
||||||
|
|
@ -1,125 +0,0 @@
|
||||||
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 || ==8.8.1
|
|
||||||
, 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.14
|
|
||||||
, 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.12
|
|
||||||
, case-insensitive >=1.2.0.0 && <1.3
|
|
||||||
, exceptions >=0.10.0 && <0.11
|
|
||||||
, ghcjs-dom >=0.9.4.0 && <0.10
|
|
||||||
, 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.6.0 && <2.8
|
|
||||||
|
|
@ -1,311 +0,0 @@
|
||||||
{-# 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
|
|
||||||
|
|
@ -1,20 +0,0 @@
|
||||||
-- | 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
|
|
||||||
|
|
@ -1,173 +0,0 @@
|
||||||
{-# 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.Exception
|
|
||||||
(handle, throwIO)
|
|
||||||
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 Network.Wai.Middleware.AddHeaders
|
|
||||||
import Network.Wai.Middleware.Cors
|
|
||||||
(simpleCors)
|
|
||||||
import Network.WebSockets
|
|
||||||
(defaultConnectionOptions)
|
|
||||||
import qualified Network.WebSockets as WS
|
|
||||||
import Servant.API
|
|
||||||
import Servant.Client.JSaddle
|
|
||||||
import Servant.Server
|
|
||||||
import qualified System.Process as P
|
|
||||||
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
|
|
||||||
|
|
||||||
let handler :: WS.ConnectionException -> IO ()
|
|
||||||
handler WS.ConnectionClosed = return ()
|
|
||||||
handler e = throwIO e
|
|
||||||
|
|
||||||
handle handler $ Warp.testWithApplication serverApp $ \serverPort -> do
|
|
||||||
threadDelay $ 500 * 1000
|
|
||||||
|
|
||||||
let clientApp :: IO Application
|
|
||||||
clientApp = WS.jsaddleOr defaultConnectionOptions (action serverPort >> Run.syncPoint) WS.jsaddleApp
|
|
||||||
|
|
||||||
Warp.testWithApplication (simpleCors <$> clientApp) $ \clientPort -> do
|
|
||||||
threadDelay $ 500 * 1000
|
|
||||||
|
|
||||||
putStrLn $ "server http://localhost:" ++ show serverPort
|
|
||||||
putStrLn $ "client http://localhost:" ++ show clientPort
|
|
||||||
putStrLn $ "google-chrome-stable --headless --disable-gpu --screenshot http://localhost:" ++ show clientPort
|
|
||||||
|
|
||||||
|
|
||||||
-- 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
|
|
||||||
|
|
@ -1,8 +0,0 @@
|
||||||
{-# 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