diff --git a/.travis.yml b/.travis.yml index fca08a0c..5801d4b4 100644 --- a/.travis.yml +++ b/.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 "program-default-options" >> $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 diff --git a/Makefile b/Makefile index 70ad462e..34180491 100644 --- a/Makefile +++ b/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 : diff --git a/cabal.ghcjs.project b/cabal.ghcjs.project index dd68a573..d7f2c49f 100644 --- a/cabal.ghcjs.project +++ b/cabal.ghcjs.project @@ -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 diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 293b347e..023c5323 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -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 diff --git a/cabal.project b/cabal.project index c4420197..ef926b01 100644 --- a/cabal.project +++ b/cabal.project @@ -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 diff --git a/screenshot.png b/screenshot.png new file mode 100644 index 00000000..c5350203 Binary files /dev/null and b/screenshot.png differ diff --git a/servant-jsaddle/CHANGELOG.md b/servant-jsaddle/CHANGELOG.md new file mode 100644 index 00000000..53231096 --- /dev/null +++ b/servant-jsaddle/CHANGELOG.md @@ -0,0 +1,4 @@ +X.Y +---- + +Initial release diff --git a/servant-jsaddle/LICENSE b/servant-jsaddle/LICENSE new file mode 100644 index 00000000..9717a9ce --- /dev/null +++ b/servant-jsaddle/LICENSE @@ -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. diff --git a/servant-jsaddle/README.md b/servant-jsaddle/README.md new file mode 100644 index 00000000..ada9aeef --- /dev/null +++ b/servant-jsaddle/README.md @@ -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`. diff --git a/servant-jsaddle/Setup.hs b/servant-jsaddle/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/servant-jsaddle/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-jsaddle/servant-jsaddle.cabal b/servant-jsaddle/servant-jsaddle.cabal new file mode 100644 index 00000000..c9904056 --- /dev/null +++ b/servant-jsaddle/servant-jsaddle.cabal @@ -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 webservice. + . + See . + . + + +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 diff --git a/servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs b/servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs new file mode 100644 index 00000000..e219ff2e --- /dev/null +++ b/servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs @@ -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 = " + . 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 diff --git a/servant-jsaddle/src/Servant/Client/JSaddle.hs b/servant-jsaddle/src/Servant/Client/JSaddle.hs new file mode 100644 index 00000000..f3a65ce1 --- /dev/null +++ b/servant-jsaddle/src/Servant/Client/JSaddle.hs @@ -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 diff --git a/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs b/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs new file mode 100644 index 00000000..759fbebe --- /dev/null +++ b/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs @@ -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 diff --git a/servant-jsaddle/test/Spec.hs b/servant-jsaddle/test/Spec.hs new file mode 100644 index 00000000..394ef87e --- /dev/null +++ b/servant-jsaddle/test/Spec.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} +#ifdef __GHCJS__ +module Main (main) where +main :: IO () +main = return () +#else +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +#endif