From 67f2285e304ac91402147dbcd4ce32db8669fcda Mon Sep 17 00:00:00 2001 From: Falco Peijnenburg Date: Sun, 24 Sep 2017 16:05:38 +0200 Subject: [PATCH] WIP! Untested! Initial servant-client-ghcjs package --- servant-client-ghcjs/CHANGELOG.md | 3 + servant-client-ghcjs/LICENSE | 30 +++ servant-client-ghcjs/README.md | 20 ++ servant-client-ghcjs/Setup.hs | 2 + .../servant-client-ghcjs.cabal | 54 ++++ .../src/Servant/Client/Ghcjs.hs | 14 + .../src/Servant/Client/Internal/XhrClient.hs | 241 ++++++++++++++++++ servant-client-ghcjs/tinc.yaml | 5 + 8 files changed, 369 insertions(+) create mode 100644 servant-client-ghcjs/CHANGELOG.md create mode 100644 servant-client-ghcjs/LICENSE create mode 100644 servant-client-ghcjs/README.md create mode 100644 servant-client-ghcjs/Setup.hs create mode 100644 servant-client-ghcjs/servant-client-ghcjs.cabal create mode 100644 servant-client-ghcjs/src/Servant/Client/Ghcjs.hs create mode 100644 servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs create mode 100644 servant-client-ghcjs/tinc.yaml diff --git a/servant-client-ghcjs/CHANGELOG.md b/servant-client-ghcjs/CHANGELOG.md new file mode 100644 index 00000000..b5e7a115 --- /dev/null +++ b/servant-client-ghcjs/CHANGELOG.md @@ -0,0 +1,3 @@ +0.11 +---- +Initial diff --git a/servant-client-ghcjs/LICENSE b/servant-client-ghcjs/LICENSE new file mode 100644 index 00000000..9717a9ce --- /dev/null +++ b/servant-client-ghcjs/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-ghcjs/README.md b/servant-client-ghcjs/README.md new file mode 100644 index 00000000..1825c17d --- /dev/null +++ b/servant-client-ghcjs/README.md @@ -0,0 +1,20 @@ +# servant-client-ghcjs + +![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) + +This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice. This library is specifically for ghcjs, as opposed to servant-client. + +## Example + +``` haskell +type MyApi = "books" :> Get '[JSON] [Book] -- GET /books + :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books + +myApi :: Proxy MyApi +myApi = Proxy + +getAllBooks :: Manager -> BaseUrl -> ExceptT String IO [Book] +postNewBook :: Book -> Manager -> BaseUrl -> ExceptT String IO Book +-- 'client' allows you to produce operations to query an API from a client. +(getAllBooks :<|> postNewBook) = client myApi +``` diff --git a/servant-client-ghcjs/Setup.hs b/servant-client-ghcjs/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/servant-client-ghcjs/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-client-ghcjs/servant-client-ghcjs.cabal b/servant-client-ghcjs/servant-client-ghcjs.cabal new file mode 100644 index 00000000..d498b146 --- /dev/null +++ b/servant-client-ghcjs/servant-client-ghcjs.cabal @@ -0,0 +1,54 @@ +name: servant-client-ghcjs +version: 0.11 +synopsis: automatical derivation of querying functions for servant webservices for ghcjs +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.Ghcjs + Servant.Client.Internal.XhrClient + 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.9 + , ghcjs-base + , ghcjs-prim + , http-types >= 0.8.6 && < 0.10 + , monad-control >= 1.0.0.4 && < 1.1 + , mtl >= 2.1 && < 2.3 + , semigroupoids >= 4.3 && < 5.3 + , servant-client-core == 0.11.* + , string-conversions >= 0.3 && < 0.5 + , transformers >= 0.3 && < 0.6 + , transformers-base >= 0.4.4 && < 0.5 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints + include-dirs: include diff --git a/servant-client-ghcjs/src/Servant/Client/Ghcjs.hs b/servant-client-ghcjs/src/Servant/Client/Ghcjs.hs new file mode 100644 index 00000000..b3e7e66b --- /dev/null +++ b/servant-client-ghcjs/src/Servant/Client/Ghcjs.hs @@ -0,0 +1,14 @@ +-- | This module provides 'client' which can automatically generate +-- querying functions for each endpoint just from the type representing your +-- API. +module Servant.Client.Ghcjs + ( + client + , GhcjsClientM + , runGhcjsClientM + , GhcjsClientEnv(..) + , module Servant.Client.Core.Reexport + ) where + +import Servant.Client.Internal.XhrClient +import Servant.Client.Core.Reexport diff --git a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs new file mode 100644 index 00000000..b1122ec6 --- /dev/null +++ b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + + +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.Client.Internal.XhrClient where + +import Control.Arrow +import Data.ByteString.Builder (toLazyByteString) +import Control.Concurrent +import Control.Exception +import Control.Monad +import Control.Monad.Base (MonadBase (..)) +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.Reader +import Control.Monad.Trans.Control (MonadBaseControl (..)) +import Control.Monad.Trans.Except +import qualified Data.ByteString.Char8 as BS +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 Foreign.StablePtr +import GHC.Generics +import GHCJS.Foreign.Callback +import GHCJS.Prim +import Network.HTTP.Types +import Servant.Client.Core + +newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal + +newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal + +newtype GhcjsClientEnv + = GhcjsClientEnv + { baseUrl :: BaseUrl } + deriving (Eq, Show) + +client :: HasClient GhcjsClientM api => Proxy api -> Client GhcjsClientM api +client api = api `clientIn` (Proxy :: Proxy GhcjsClientM) + +newtype GhcjsClientM a = GhcjsClientM + { runGhcjsClientM' :: ReaderT GhcjsClientEnv (ExceptT ServantError IO) a } + deriving ( Functor, Applicative, Monad, MonadIO, Generic + , MonadReader GhcjsClientEnv, MonadError ServantError, MonadThrow + , MonadCatch) + +instance MonadBase IO GhcjsClientM where + liftBase = GhcjsClientM . liftBase + +instance MonadBaseControl IO GhcjsClientM where + type StM GhcjsClientM a = Either ServantError a + + liftBaseWith f = GhcjsClientM (liftBaseWith (\g -> f (g . runGhcjsClientM'))) + + restoreM st = GhcjsClientM (restoreM st) + +-- | Try clients in order, last error is preserved. +instance Alt GhcjsClientM where + a b = a `catchError` const b + +instance RunClient GhcjsClientM where + runRequest = performRequest + throwServantError = throwError + catchServantError = catchError + +instance ClientLike (GhcjsClientM a) (GhcjsClientM a) where + mkClient = id + +runGhcjsClientM :: GhcjsClientM a -> GhcjsClientEnv -> IO (Either ServantError a) +runGhcjsClientM cm env = runExceptT $ flip runReaderT env $ runGhcjsClientM' cm + +performRequest :: Request -> GhcjsClientM Response +performRequest req = do + xhr <- liftIO initXhr + burl <- asks baseUrl + liftIO $ performXhr xhr burl req + toResponse xhr + +-- * initialization + +initXhr :: IO JSXMLHttpRequest +initXhr = do + lib <- requireXMLHttpRequestClass + newXMLHttpRequest lib + +foreign import javascript unsafe + -- branching between node (for testing) and browsers + "(function () {if (typeof require !== 'undefined') { return require('xhr2'); } else { return XMLHttpRequest; };})()" + requireXMLHttpRequestClass :: IO JSXMLHttpRequestClass + +foreign import javascript unsafe "new $1()" + newXMLHttpRequest :: JSXMLHttpRequestClass -> IO JSXMLHttpRequest + +-- * performing requests +-- Performs the xhr and blocks until the response was received +performXhr :: JSXMLHttpRequest -> BaseUrl -> Request -> IO () +performXhr xhr burl request = do + + waiter <- newEmptyMVar + + bracket (acquire waiter) releaseCallback $ \_callback -> do + t <- myThreadId + s <- newStablePtr t + + openXhr xhr (cs $ requestMethod request) (toUrl burl request) True + setHeaders xhr $ toList $ requestHeaders request + sendXhr xhr (toBody request) + takeMVar waiter + + freeStablePtr s + where + acquire waiter = onReadyStateChange xhr $ do + state <- readyState 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 $ tryPutMVar waiter () + _ -> return () + +onReadyStateChange :: JSXMLHttpRequest -> IO () -> IO (Callback (IO ())) +onReadyStateChange xhr action = do + callback <- asyncCallback action + js_onReadyStateChange xhr callback + return callback +foreign import javascript safe "$1.onreadystatechange = $2;" + js_onReadyStateChange :: JSXMLHttpRequest -> Callback (IO ()) -> IO () + +foreign import javascript unsafe "$1.readyState" + readyState :: JSXMLHttpRequest -> IO Int + +openXhr :: JSXMLHttpRequest -> String -> String -> Bool -> IO () +openXhr xhr method url = + js_openXhr xhr (toJSString method) (toJSString url) +foreign import javascript unsafe "$1.open($2, $3, $4)" + js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO () + +toUrl :: BaseUrl -> Request -> String +toUrl burl request = + let pathS = cs $ toLazyByteString $ requestPath request + queryS = + cs $ + renderQuery True $ + toList $ + requestQueryString request + in showBaseUrl burl ++ pathS ++ queryS + +setHeaders :: JSXMLHttpRequest -> RequestHeaders -> IO () +setHeaders xhr headers = forM_ headers $ \ (key, value) -> + js_setRequestHeader xhr (toJSString $ cs $ original key) (toJSString $ cs value) +foreign import javascript unsafe "$1.setRequestHeader($2, $3)" + js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO () + +sendXhr :: JSXMLHttpRequest -> Maybe String -> IO () +sendXhr xhr Nothing = js_sendXhr xhr +sendXhr xhr (Just body) = + js_sendXhrWithBody xhr (toJSString body) + +foreign import javascript unsafe "$1.send()" + js_sendXhr :: JSXMLHttpRequest -> IO () + +foreign import javascript unsafe "$1.send($2)" + js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO () + +toBody :: Request -> Maybe String +toBody request = case requestBody request of + Nothing -> Nothing + Just (RequestBodyLBS "", _) -> Nothing + Just (RequestBodyLBS x, _) -> Just $ cs x + +-- * inspecting the xhr response + +-- This function is only supposed to handle 'ConnectionError's. Other +-- 'ServantError's are created in Servant.Client.Req. +toResponse :: JSXMLHttpRequest -> GhcjsClientM Response +toResponse xhr = do + status <- liftIO $ getStatus xhr + case status of + 0 -> throwError $ ConnectionError "connection error" + _ -> liftIO $ do + statusText <- cs <$> getStatusText xhr + headers <- parseHeaders <$> getAllResponseHeaders xhr + responseText <- cs <$> getResponseText xhr + pure Response + { responseStatusCode = mkStatus status statusText + , responseBody = responseText + , responseHeaders = Seq.fromList headers + , responseHttpVersion = http11 -- this is made up + } + +foreign import javascript unsafe "$1.status" + getStatus :: JSXMLHttpRequest -> IO Int + +getStatusText :: JSXMLHttpRequest -> IO String +getStatusText = fmap fromJSString . js_statusText +foreign import javascript unsafe "$1.statusText" + js_statusText :: JSXMLHttpRequest -> IO JSVal + +getAllResponseHeaders :: JSXMLHttpRequest -> IO String +getAllResponseHeaders xhr = + fromJSString <$> js_getAllResponseHeaders xhr +foreign import javascript unsafe "$1.getAllResponseHeaders()" + js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal + +getResponseText :: JSXMLHttpRequest -> IO String +getResponseText xhr = fromJSString <$> js_responseText xhr +foreign import javascript unsafe "$1.responseText" + js_responseText :: JSXMLHttpRequest -> IO JSVal + +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 diff --git a/servant-client-ghcjs/tinc.yaml b/servant-client-ghcjs/tinc.yaml new file mode 100644 index 00000000..ec6d448f --- /dev/null +++ b/servant-client-ghcjs/tinc.yaml @@ -0,0 +1,5 @@ +dependencies: + - name: servant + path: ../servant + - name: servant-server + path: ../servant-server