From 3348665a88c7916c48ba823d2695f358ceea61b7 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Sat, 28 Jul 2018 14:40:25 +0200 Subject: [PATCH] Add servant-client-jsaddle --- servant-client-jsaddle/CHANGELOG.md | 3 + servant-client-jsaddle/LICENSE | 30 ++ servant-client-jsaddle/README.md | 15 + servant-client-jsaddle/Setup.hs | 2 + .../servant-client-jsaddle.cabal | 103 +++++++ .../Client/Internal/JSaddleXhrClient.hs | 263 ++++++++++++++++++ .../src/Servant/Client/JSaddle.hs | 20 ++ .../test/Servant/Client/JsSpec.hs | 103 +++++++ servant-client-jsaddle/test/Spec.hs | 1 + 9 files changed, 540 insertions(+) create mode 100644 servant-client-jsaddle/CHANGELOG.md create mode 100644 servant-client-jsaddle/LICENSE create mode 100644 servant-client-jsaddle/README.md create mode 100644 servant-client-jsaddle/Setup.hs create mode 100644 servant-client-jsaddle/servant-client-jsaddle.cabal create mode 100644 servant-client-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs create mode 100644 servant-client-jsaddle/src/Servant/Client/JSaddle.hs create mode 100644 servant-client-jsaddle/test/Servant/Client/JsSpec.hs create mode 100644 servant-client-jsaddle/test/Spec.hs diff --git a/servant-client-jsaddle/CHANGELOG.md b/servant-client-jsaddle/CHANGELOG.md new file mode 100644 index 00000000..247389d6 --- /dev/null +++ b/servant-client-jsaddle/CHANGELOG.md @@ -0,0 +1,3 @@ +0.13 +---- +First version diff --git a/servant-client-jsaddle/LICENSE b/servant-client-jsaddle/LICENSE new file mode 100644 index 00000000..9717a9ce --- /dev/null +++ b/servant-client-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-client-jsaddle/README.md b/servant-client-jsaddle/README.md new file mode 100644 index 00000000..ada9aeef --- /dev/null +++ b/servant-client-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-client-jsaddle/Setup.hs b/servant-client-jsaddle/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/servant-client-jsaddle/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-client-jsaddle/servant-client-jsaddle.cabal b/servant-client-jsaddle/servant-client-jsaddle.cabal new file mode 100644 index 00000000..5be33301 --- /dev/null +++ b/servant-client-jsaddle/servant-client-jsaddle.cabal @@ -0,0 +1,103 @@ +name: servant-client-jsaddle +version: 0.13 +synopsis: automatic derivation of querying functions for servant webservices for jsaddle (GHCJS, GHC + WebKit, GHC + websockets, etc) +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 >= 7.8 +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 + exposed-modules: + Servant.Client.JSaddle + Servant.Client.Internal.JSaddleXhrClient + build-depends: + base >= 4.7 && < 4.11 + , bytestring >= 0.10 && < 0.11 + , case-insensitive >= 1.2.0.0 && < 1.3.0.0 + , containers >= 0.5 && < 0.6 + , exceptions >= 0.8 && < 0.11 + , http-media + , http-types + , jsaddle + , jsaddle-dom + , monad-control >= 1.0.0.4 && < 1.1 + , mtl >= 2.1 && < 2.3 + , semigroupoids >= 4.3 && < 5.3 + , servant-client-core == 0.13.* + , string-conversions >= 0.3 && < 0.5 + , text + , transformers >= 0.3 && < 0.6 + , transformers-base >= 0.4.4 && < 0.5 + if impl(ghcjs) + build-depends: ghcjs-base + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + 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 + other-modules: + Servant.Client.JsSpec + + -- Dependencies inherited from the library. No need to specify bounds. + build-depends: + base + , aeson + , bytestring + , case-insensitive + , containers + , exceptions + , http-media + , http-types + , jsaddle + , jsaddle-webkit2gtk + , jsaddle-dom + , monad-control + , mtl + , semigroupoids + , servant + , servant-client-core + , servant-client-jsaddle + , servant-server + , string-conversions + , text + , transformers + , transformers-base + , wai + , wai-extra + , warp + + -- Additonal dependencies + build-depends: + hspec + , QuickCheck + + build-tool-depends: + hspec-discover:hspec-discover >=2.4.4 && <2.5 diff --git a/servant-client-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs b/servant-client-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs new file mode 100644 index 00000000..4e2bdc16 --- /dev/null +++ b/servant-client-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.Client.Internal.JSaddleXhrClient where + +import Control.Arrow +import Data.ByteString.Builder (toLazyByteString) +import Control.Concurrent +import Control.Monad +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.Reader +import Control.Monad.Trans.Except +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as L +import Data.CaseInsensitive +import Data.Char +import Data.Foldable (toList) +import Data.Functor.Alt (Alt (..)) +import Data.Proxy (Proxy (..)) +import qualified Data.Sequence as Seq +import Data.String.Conversions +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import GHC.Generics +import qualified JSDOM.Types as JS +import qualified JSDOM.Custom.XMLHttpRequest as JS +import qualified JSDOM.Generated.Window as Window +import qualified JSDOM.Generated.Location as Location +import qualified JSDOM +import JSDOM.Types (DOM, askDOM, runDOM, DOMContext) +import qualified JSDOM.EventM as JSDOM +import qualified Language.Javascript.JSaddle.Types as JSaddle +import qualified JavaScript.TypedArray.ArrayBuffer as ArrayBuffer +import qualified GHCJS.Buffer as Buffer +import Network.HTTP.Types +import Network.HTTP.Media (renderHeader) +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 () + } + +-- | 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 ServantError DOM) a } + deriving ( Functor, Applicative, Monad, MonadIO, Generic + , MonadReader ClientEnv, MonadError ServantError) +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 + throwServantError = throwError + runRequest r = do + d <- ClientM askDOM + performRequest d r + +instance ClientLike (ClientM a) (ClientM a) where + mkClient = id + +runClientM :: ClientM a -> ClientEnv -> DOM (Either ServantError a) +runClientM cm env = runExceptT $ flip runReaderT env $ fromClientM cm + +runClientM' :: ClientM a -> DOM (Either ServantError a) +runClientM' m = do + burl <- getDefaultBaseUrl + runClientM m (mkClientEnv burl) + +getDefaultBaseUrl :: DOM BaseUrl +getDefaultBaseUrl = do + win <- JSDOM.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 $ FailureResponse 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) + + liftIO $ takeMVar waiter + + cleanup + +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 + +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 + +-- * inspecting the xhr response + +-- This function is only supposed to handle 'ConnectionError's. Other +-- 'ServantError'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 "connection error" + _ -> 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-client-jsaddle/src/Servant/Client/JSaddle.hs b/servant-client-jsaddle/src/Servant/Client/JSaddle.hs new file mode 100644 index 00000000..f3a65ce1 --- /dev/null +++ b/servant-client-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-client-jsaddle/test/Servant/Client/JsSpec.hs b/servant-client-jsaddle/test/Servant/Client/JsSpec.hs new file mode 100644 index 00000000..26a79d2b --- /dev/null +++ b/servant-client-jsaddle/test/Servant/Client/JsSpec.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +module Servant.Client.JsSpec where + +import Servant.API +import Servant.Server +import Network.Wai.Handler.Warp as Warp +import qualified Data.ByteString as B +import Data.ByteString(ByteString) +import Test.Hspec +import Data.Proxy +import Control.Monad.Trans +import Data.Aeson +import Data.Word +import GHC.Generics +import qualified Language.Javascript.JSaddle.WebKitGTK as WK +import qualified Language.Javascript.JSaddle.Monad as JSaddle +import Language.Javascript.JSaddle.Monad(JSM) +import Control.Concurrent +import Servant.Client.Js +import qualified JSDOM +import qualified JSDOM.Window as Window +import qualified Network.Wai as Wai +import Network.Wai.Middleware.AddHeaders +import qualified Network.HTTP.Types as Http +import Data.String +import System.IO + +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 + liftIO $ putStrLn "Hello tehre" + liftIO $ print x + liftIO $ hFlush stdout + 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 <- JSDOM.currentWindow + case mw of + Just w -> do + liftIO $ putStrLn "Closing window..." + Window.close w + Nothing -> liftIO $ putStrLn "Can't close the window!" + +logRequest :: Wai.Middleware +logRequest app request respond = do + putStrLn "Request" + print request + app request (\response -> do + putStrLn "Response Headers" + print `mapM_` (Wai.responseHeaders response) + respond response) + +corsHeaders :: (IsString s1, IsString s2) => [(s1, s2)] +corsHeaders = [ ("Access-Control-Allow-Origin", "null") + , ("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 + + +spec :: Spec +spec = do + describe "Servant.Client.Js" $ do + it "Receive a properly encoded response" $ do + Warp.testWithApplication (pure $ logRequest $ addCors $ serve testApi testServer) $ \portNr -> do + let clientEnv = mkClientEnv BaseUrl { baseUrlScheme = Http + , baseUrlHost = "localhost" + , baseUrlPort = fromIntegral portNr + , baseUrlPath = "/" + } + + WK.run $ JSaddle.liftJSM $ jsaddleFinally close $ do + liftIO $ threadDelay $ 1000 * 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 $ do + testClient (B.pack bytes) + liftIO $ response `shouldBe` Right (TestResponse bytes) diff --git a/servant-client-jsaddle/test/Spec.hs b/servant-client-jsaddle/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-client-jsaddle/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}