WIP! Untested! Initial servant-client-ghcjs package
This commit is contained in:
Falco Peijnenburg
parent
ff5502f4f7
commit
67f2285e30
|
|
@ -0,0 +1,3 @@
|
|||
0.11
|
||||
----
|
||||
Initial
|
||||
|
|
@ -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.
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
# servant-client-ghcjs
|
||||
|
||||
|
||||
|
||||
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
|
||||
```
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
|
|
@ -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 <http://hackage.haskell.org/package/servant servant> webservice.
|
||||
.
|
||||
See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.
|
||||
.
|
||||
<https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
|
||||
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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
dependencies:
|
||||
- name: servant
|
||||
path: ../servant
|
||||
- name: servant-server
|
||||
path: ../servant-server
|
||||
Loading…
Reference in New Issue