diff --git a/.travis.yml b/.travis.yml index 272e8f08..4f839a90 100644 --- a/.travis.yml +++ b/.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:primitive" >> 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 - "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 @@ -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:primitive" >> 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 - "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 diff --git a/cabal.project b/cabal.project index 11c22cb4..4f29900b 100644 --- a/cabal.project +++ b/cabal.project @@ -61,20 +61,6 @@ allow-newer: openssl-streams-1.2.2.0:network -- https://github.com/nurpax/sqlite-simple/issues/74 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 -- needed for doctests diff --git a/servant-jsaddle/CHANGELOG.md b/servant-jsaddle/CHANGELOG.md deleted file mode 100644 index 53231096..00000000 --- a/servant-jsaddle/CHANGELOG.md +++ /dev/null @@ -1,4 +0,0 @@ -X.Y ----- - -Initial release diff --git a/servant-jsaddle/LICENSE b/servant-jsaddle/LICENSE deleted file mode 100644 index 9717a9ce..00000000 --- a/servant-jsaddle/LICENSE +++ /dev/null @@ -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. diff --git a/servant-jsaddle/README.md b/servant-jsaddle/README.md deleted file mode 100644 index ada9aeef..00000000 --- a/servant-jsaddle/README.md +++ /dev/null @@ -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`. diff --git a/servant-jsaddle/Setup.hs b/servant-jsaddle/Setup.hs deleted file mode 100644 index 44671092..00000000 --- a/servant-jsaddle/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/servant-jsaddle/servant-jsaddle.cabal b/servant-jsaddle/servant-jsaddle.cabal deleted file mode 100644 index 4ff54b6d..00000000 --- a/servant-jsaddle/servant-jsaddle.cabal +++ /dev/null @@ -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 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 || ==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 diff --git a/servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs b/servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs deleted file mode 100644 index e219ff2e..00000000 --- a/servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs +++ /dev/null @@ -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 = " - . 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 deleted file mode 100644 index f3a65ce1..00000000 --- a/servant-jsaddle/src/Servant/Client/JSaddle.hs +++ /dev/null @@ -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 diff --git a/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs b/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs deleted file mode 100644 index 55c29fbf..00000000 --- a/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs +++ /dev/null @@ -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 diff --git a/servant-jsaddle/test/Spec.hs b/servant-jsaddle/test/Spec.hs deleted file mode 100644 index 394ef87e..00000000 --- a/servant-jsaddle/test/Spec.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE CPP #-} -#ifdef __GHCJS__ -module Main (main) where -main :: IO () -main = return () -#else -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} -#endif