From 67f2285e304ac91402147dbcd4ce32db8669fcda Mon Sep 17 00:00:00 2001 From: Falco Peijnenburg Date: Sun, 24 Sep 2017 16:05:38 +0200 Subject: [PATCH 1/8] 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 From 8d1229f2d42895b83606cd243b59dd5a36f8ea7f Mon Sep 17 00:00:00 2001 From: Falco Peijnenburg Date: Tue, 26 Sep 2017 21:38:44 +0200 Subject: [PATCH 2/8] servant-client-ghcjs: Renamed GhcjsClientM to ClientM --- .../src/Servant/Client/Ghcjs.hs | 6 +-- .../src/Servant/Client/Internal/XhrClient.hs | 40 +++++++++---------- 2 files changed, 23 insertions(+), 23 deletions(-) diff --git a/servant-client-ghcjs/src/Servant/Client/Ghcjs.hs b/servant-client-ghcjs/src/Servant/Client/Ghcjs.hs index b3e7e66b..08dbb0c2 100644 --- a/servant-client-ghcjs/src/Servant/Client/Ghcjs.hs +++ b/servant-client-ghcjs/src/Servant/Client/Ghcjs.hs @@ -4,9 +4,9 @@ module Servant.Client.Ghcjs ( client - , GhcjsClientM - , runGhcjsClientM - , GhcjsClientEnv(..) + , ClientM + , runClientM + , ClientEnv(..) , module Servant.Client.Core.Reexport ) where diff --git a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs index b1122ec6..e9601015 100644 --- a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs +++ b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs @@ -44,46 +44,46 @@ newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal -newtype GhcjsClientEnv - = GhcjsClientEnv +newtype ClientEnv + = ClientEnv { baseUrl :: BaseUrl } deriving (Eq, Show) -client :: HasClient GhcjsClientM api => Proxy api -> Client GhcjsClientM api -client api = api `clientIn` (Proxy :: Proxy GhcjsClientM) +client :: HasClient ClientM api => Proxy api -> Client ClientM api +client api = api `clientIn` (Proxy :: Proxy ClientM) -newtype GhcjsClientM a = GhcjsClientM - { runGhcjsClientM' :: ReaderT GhcjsClientEnv (ExceptT ServantError IO) a } +newtype ClientM a = ClientM + { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a } deriving ( Functor, Applicative, Monad, MonadIO, Generic - , MonadReader GhcjsClientEnv, MonadError ServantError, MonadThrow + , MonadReader ClientEnv, MonadError ServantError, MonadThrow , MonadCatch) -instance MonadBase IO GhcjsClientM where - liftBase = GhcjsClientM . liftBase +instance MonadBase IO ClientM where + liftBase = ClientM . liftBase -instance MonadBaseControl IO GhcjsClientM where - type StM GhcjsClientM a = Either ServantError a +instance MonadBaseControl IO ClientM where + type StM ClientM a = Either ServantError a - liftBaseWith f = GhcjsClientM (liftBaseWith (\g -> f (g . runGhcjsClientM'))) + liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM'))) - restoreM st = GhcjsClientM (restoreM st) + restoreM st = ClientM (restoreM st) -- | Try clients in order, last error is preserved. -instance Alt GhcjsClientM where +instance Alt ClientM where a b = a `catchError` const b -instance RunClient GhcjsClientM where +instance RunClient ClientM where runRequest = performRequest throwServantError = throwError catchServantError = catchError -instance ClientLike (GhcjsClientM a) (GhcjsClientM a) where +instance ClientLike (ClientM a) (ClientM a) where mkClient = id -runGhcjsClientM :: GhcjsClientM a -> GhcjsClientEnv -> IO (Either ServantError a) -runGhcjsClientM cm env = runExceptT $ flip runReaderT env $ runGhcjsClientM' cm +runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) +runClientM cm env = runExceptT $ flip runReaderT env $ runClientM' cm -performRequest :: Request -> GhcjsClientM Response +performRequest :: Request -> ClientM Response performRequest req = do xhr <- liftIO initXhr burl <- asks baseUrl @@ -188,7 +188,7 @@ toBody request = case requestBody request of -- This function is only supposed to handle 'ConnectionError's. Other -- 'ServantError's are created in Servant.Client.Req. -toResponse :: JSXMLHttpRequest -> GhcjsClientM Response +toResponse :: JSXMLHttpRequest -> ClientM Response toResponse xhr = do status <- liftIO $ getStatus xhr case status of From 7b38e77b00107e91ae24a855b367391cbd283d1c Mon Sep 17 00:00:00 2001 From: Falco Peijnenburg Date: Tue, 26 Sep 2017 22:32:19 +0200 Subject: [PATCH 3/8] servant-client-ghcjs: Version bounds for ghcjs-base and ghcjs-prim --- servant-client-ghcjs/servant-client-ghcjs.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-client-ghcjs/servant-client-ghcjs.cabal b/servant-client-ghcjs/servant-client-ghcjs.cabal index d498b146..1fdd1336 100644 --- a/servant-client-ghcjs/servant-client-ghcjs.cabal +++ b/servant-client-ghcjs/servant-client-ghcjs.cabal @@ -36,8 +36,8 @@ library , case-insensitive >= 1.2.0.0 && < 1.3.0.0 , containers >= 0.5 && < 0.6 , exceptions >= 0.8 && < 0.9 - , ghcjs-base - , ghcjs-prim + , ghcjs-base >= 0.2.0.0 && < 0.3.0.0 + , ghcjs-prim >= 0.1.0.0 && < 0.2.0.0 , http-types >= 0.8.6 && < 0.10 , monad-control >= 1.0.0.4 && < 1.1 , mtl >= 2.1 && < 2.3 From 74bde0a73d1ea6a00e606c3a852f4f553336083a Mon Sep 17 00:00:00 2001 From: Falco Peijnenburg Date: Wed, 4 Oct 2017 23:54:46 +0200 Subject: [PATCH 4/8] servant-client-ghcjs: Fixed Accept and Content-Type headers not being set --- .../servant-client-ghcjs.cabal | 2 +- .../src/Servant/Client/Internal/XhrClient.hs | 23 +++++++++++++++---- 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/servant-client-ghcjs/servant-client-ghcjs.cabal b/servant-client-ghcjs/servant-client-ghcjs.cabal index 1fdd1336..cd5550bb 100644 --- a/servant-client-ghcjs/servant-client-ghcjs.cabal +++ b/servant-client-ghcjs/servant-client-ghcjs.cabal @@ -38,6 +38,7 @@ library , exceptions >= 0.8 && < 0.9 , ghcjs-base >= 0.2.0.0 && < 0.3.0.0 , ghcjs-prim >= 0.1.0.0 && < 0.2.0.0 + , http-media >= 0.6.2 && < 0.8 , http-types >= 0.8.6 && < 0.10 , monad-control >= 1.0.0.4 && < 1.1 , mtl >= 2.1 && < 2.3 @@ -51,4 +52,3 @@ library 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/Internal/XhrClient.hs b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs index e9601015..030aebf7 100644 --- a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs +++ b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs @@ -38,6 +38,7 @@ import GHC.Generics import GHCJS.Foreign.Callback import GHCJS.Prim import Network.HTTP.Types +import Network.HTTP.Media (renderHeader) import Servant.Client.Core newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal @@ -117,7 +118,7 @@ performXhr xhr burl request = do s <- newStablePtr t openXhr xhr (cs $ requestMethod request) (toUrl burl request) True - setHeaders xhr $ toList $ requestHeaders request + setHeaders xhr request sendXhr xhr (toBody request) takeMVar waiter @@ -161,9 +162,23 @@ toUrl burl request = 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) +setHeaders :: JSXMLHttpRequest -> Request -> IO () +setHeaders xhr request = do + forM_ (toList $ requestAccept request) $ \mediaType -> + js_setRequestHeader + xhr + (toJSString "Accept") + (toJSString $ cs $ renderHeader mediaType) + + forM_ (requestBody request) $ \(_, mediaType) -> + js_setRequestHeader + xhr + (toJSString "Content-Type") + (toJSString $ cs $ renderHeader mediaType) + + forM_ (toList $ requestHeaders request) $ \(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 () From 911be50df29ea469fd07409e99df3675c764c7e5 Mon Sep 17 00:00:00 2001 From: Falco Peijnenburg Date: Sun, 8 Oct 2017 19:47:44 +0200 Subject: [PATCH 5/8] servant-client-ghcjs: Fixed not throwing FailureResponse --- .../src/Servant/Client/Internal/XhrClient.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs index 030aebf7..d1212a99 100644 --- a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs +++ b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs @@ -89,7 +89,13 @@ performRequest req = do xhr <- liftIO initXhr burl <- asks baseUrl liftIO $ performXhr xhr burl req - toResponse xhr + resp <- toResponse xhr + + let status = statusCode (responseStatusCode resp) + unless (status >= 200 && status < 300) $ + throwError $ FailureResponse resp + + pure resp -- * initialization From 3f905ea41cc91eac9c1a69b291760ca41c15f696 Mon Sep 17 00:00:00 2001 From: Falco Peijnenburg Date: Sat, 21 Oct 2017 21:27:57 +0200 Subject: [PATCH 6/8] servant-client-ghcjs: Default runClientM doesn't accept ClientEnv, runClientMOrigin does. CORS are rare. Most requests by far will be to the origin that served the javascript. --- .../src/Servant/Client/Internal/XhrClient.hs | 32 +++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) diff --git a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs index d1212a99..8cb77d22 100644 --- a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs +++ b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs @@ -37,6 +37,8 @@ import Foreign.StablePtr import GHC.Generics import GHCJS.Foreign.Callback import GHCJS.Prim +import GHCJS.Types +import JavaScript.Web.Location import Network.HTTP.Types import Network.HTTP.Media (renderHeader) import Servant.Client.Core @@ -81,8 +83,34 @@ instance RunClient ClientM where instance ClientLike (ClientM a) (ClientM a) where mkClient = id -runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) -runClientM cm env = runExceptT $ flip runReaderT env $ runClientM' cm +runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ServantError a) +runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm + +runClientM :: ClientM a -> IO (Either ServantError a) +runClientM m = do + curLoc <- getWindowLocation + + jsStr_protocol <- getProtocol curLoc + jsStr_port <- getPort curLoc + jsStr_hostname <- getHostname curLoc + + let protocol + | jsStr_protocol == "https:" = Https + | otherwise = Http + + portStr :: String + portStr = fromJSString $ jsval jsStr_port + + port :: Int + port | null portStr = case protocol of + Http -> 80 + Https -> 443 + | otherwise = read portStr + + hostname :: String + hostname = fromJSString $ jsval jsStr_hostname + + runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port "")) performRequest :: Request -> ClientM Response performRequest req = do From bd5286471800c383f75ea785ba5877a8989b5fc8 Mon Sep 17 00:00:00 2001 From: Falco Peijnenburg Date: Sat, 21 Oct 2017 23:02:03 +0200 Subject: [PATCH 7/8] servant-client-ghcjs: README --- servant-client-ghcjs/README.md | 180 ++++++++++++++++++++++++++++++--- 1 file changed, 168 insertions(+), 12 deletions(-) diff --git a/servant-client-ghcjs/README.md b/servant-client-ghcjs/README.md index 1825c17d..5fc38646 100644 --- a/servant-client-ghcjs/README.md +++ b/servant-client-ghcjs/README.md @@ -1,20 +1,176 @@ # servant-client-ghcjs -![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) +Type safe querying of servant APIs from the browser. -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. +`servant-client-ghcjs` is much like `servant-client`, as both packages allow you to generate functions that query the endpoints of your servant API. Both packages should feel the same in usage. The big difference lies in how they perform the actual requests. `servant-client` (indirectly) uses your operating system's socket mechanisms, whereas `servant-client-ghcjs` uses your browser's [XHR](https://developer.mozilla.org/en-US/docs/Web/API/XMLHttpRequest/Using_XMLHttpRequest) mechanisms to send requests. -## Example +This guide assumes knowledge of servant. Reading its [documentation](haskell-servant.readthedocs.io) is recommended if you're new to the subject. -``` haskell -type MyApi = "books" :> Get '[JSON] [Book] -- GET /books - :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books +## Using servant-client-ghcjs +`servant-client-ghcjs` should feel familiar if you've worked with `servant-client`. -myApi :: Proxy MyApi -myApi = Proxy +Take the following API (taken from the [Querying an API](http://haskell-servant.readthedocs.io/en/stable/tutorial/Client.html) section in the servant documentation) -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 +```haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeOperators #-} + +module Main where + +import "aeson" Data.Aeson +import "base" Data.Proxy +import "base" GHC.Generics +import "servant" Servant.API -- To define the API itself +import "servant-client-ghcjs" Servant.Client.Ghcjs -- To generate client functions + +type API = + "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position + :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage + :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email + + +-- Data types used in the API + +data Position = Position + { xCoord :: Int + , yCoord :: Int + } deriving (Show, Generic) + +instance FromJSON Position + +newtype HelloMessage = HelloMessage { msg :: String } + deriving (Show, Generic) + +instance FromJSON HelloMessage + +data ClientInfo = ClientInfo + { clientName :: String + , clientEmail :: String + , clientAge :: Int + , clientInterestedIn :: [String] + } deriving Generic + +instance ToJSON ClientInfo + +data Email = Email + { from :: String + , to :: String + , subject :: String + , body :: String + } deriving (Show, Generic) + +instance FromJSON Email +``` + +Client functions are generated with the `client` function, like with `servant-client`: + +```haskell +position :: Int + -> Int + -> ClientM Position + +hello :: Maybe String + -> ClientM HelloMessage + +marketing :: ClientInfo + -> ClientM Email + +api :: Proxy API +api = Proxy + +position :<|> hello :<|> marketing = client api +``` + +To run these requests, they only need to be given to `runClientM`. The type of which is as follows: + +```haskell +runClientM :: ClientM a -> IO (Either ServantError a) +``` + +The requests can then be run as follows: + +```haskell +main :: IO () +main = do + ePos <- runClientM $ position 10 20 + print ePos + + eHelloMessage <- runClientM $ hello (Just "Servant") + print eHelloMessage + + eEmail <- runClientM $ marketing ClientInfo + { clientName = "Servant" + , clientEmail = "servant@example.com" + , clientAge = 3 + , clientInterestedIn = ["servant", "haskell", "type safety", "web apps"] + } + print eEmail +``` + +`runClientM` requires no URL, as it assumes that all requests are meant for the server that served the web page on which the code is being run. It is however possible to call REST APIs from other locations with [CORS](https://developer.mozilla.org/en-US/docs/Web/HTTP/CORS) using `runClientMOrigin`: + +```haskell +runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ServantError a) +``` + +Where `ClientEnv` holds a `BaseURL` that tells servant where to send the request to. + +# Common client functions +Specifically in big applications it can be desirable to have client functions that work for both `servant-client` *and* `servant-client-ghcjs`. Luckily, the common bits of those two packages live in a parent package, called `servant-client-core`. This package holds the tools to create generic client functions. Generating clients this way is a bit different, though, as the client functions need to be generic in the monad `m` that runs the actual requests. + +In the example below, the client functions are put in a data type called `APIClient`, which has `m` as a type parameter. The lowercase `apiClient` constructs this data type, demanding that `m` is indeed a monad that can run requests. + +```haskell +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +... +import "servant-client-core" Servant.Client.Core + +... + +data APIClient m = APIClient + { position :: Int -> Int -> m Position + , hello :: Maybe String -> m HelloMessage + , marketing :: ClientInfo -> m Email + } + +apiClient + :: forall m + . RunClient m + => APIClient m +apiClient = APIClient { .. } + where + position + :<|> hello + :<|> marketing = Proxy @API `clientIn` Proxy @m +``` + +The call site changes slightly too, as the functions now need to be taken from `apiClient`: + +```haskell +import "servant-client-ghcjs" Servant.Client.Ghcjs + +main :: IO () +main = do + ePos <- runClientM $ position apiClient 10 20 + print ePos +``` + +Here's how the requests would be performed in regular `servant-client`: + +```haskell +import "servant-client" Servant.Client +import "http-client" Network.HTTP.Client ( newManager, defaultManagerSettings ) + +main :: IO () +main = do + mgr <- newManager defaultManagerSettings + let clientBaseUrl = BaseUrl Http "www.example.com" 80 "" + ePos <- runClientM (position apiClient 10 20) $ ClientEnv mgr clientBaseUrl + print ePos ``` From e3a11dbcdb53be7b58e4a35a373786c316516658 Mon Sep 17 00:00:00 2001 From: Falco Peijnenburg Date: Tue, 24 Oct 2017 21:02:13 +0200 Subject: [PATCH 8/8] servant-client-ghcjs: Fixed up README --- servant-client-ghcjs/README.md | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/servant-client-ghcjs/README.md b/servant-client-ghcjs/README.md index 5fc38646..bc27d9b0 100644 --- a/servant-client-ghcjs/README.md +++ b/servant-client-ghcjs/README.md @@ -4,7 +4,7 @@ Type safe querying of servant APIs from the browser. `servant-client-ghcjs` is much like `servant-client`, as both packages allow you to generate functions that query the endpoints of your servant API. Both packages should feel the same in usage. The big difference lies in how they perform the actual requests. `servant-client` (indirectly) uses your operating system's socket mechanisms, whereas `servant-client-ghcjs` uses your browser's [XHR](https://developer.mozilla.org/en-US/docs/Web/API/XMLHttpRequest/Using_XMLHttpRequest) mechanisms to send requests. -This guide assumes knowledge of servant. Reading its [documentation](haskell-servant.readthedocs.io) is recommended if you're new to the subject. +This guide assumes knowledge of servant. Reading its [documentation](http://haskell-servant.readthedocs.io) is recommended if you're new to the subject. ## Using servant-client-ghcjs `servant-client-ghcjs` should feel familiar if you've worked with `servant-client`. @@ -14,16 +14,15 @@ Take the following API (taken from the [Querying an API](http://haskell-servant. ```haskell {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeOperators #-} module Main where -import "aeson" Data.Aeson -import "base" Data.Proxy -import "base" GHC.Generics -import "servant" Servant.API -- To define the API itself -import "servant-client-ghcjs" Servant.Client.Ghcjs -- To generate client functions +import Data.Aeson +import Data.Proxy +import GHC.Generics +import Servant.API -- From the 'servant' package, to define the API itself +import Servant.Client.Ghcjs -- To generate client functions type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position @@ -129,7 +128,7 @@ In the example below, the client functions are put in a data type called `APICli {-# LANGUAGE TypeApplications #-} ... -import "servant-client-core" Servant.Client.Core +import Servant.Client.Core -- From the 'servant-client-core' package ... @@ -153,7 +152,7 @@ apiClient = APIClient { .. } The call site changes slightly too, as the functions now need to be taken from `apiClient`: ```haskell -import "servant-client-ghcjs" Servant.Client.Ghcjs +import Servant.Client.Ghcjs main :: IO () main = do @@ -161,11 +160,11 @@ main = do print ePos ``` -Here's how the requests would be performed in regular `servant-client`: +Here's how the requests would be performed using the regular `servant-client` package: ```haskell -import "servant-client" Servant.Client -import "http-client" Network.HTTP.Client ( newManager, defaultManagerSettings ) +import Servant.Client +import Network.HTTP.Client ( newManager, defaultManagerSettings ) main :: IO () main = do