eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Add servant-client-jsaddle

Browse source
This commit is contained in:
Robert Hensing 2018-07-28 14:40:25 +02:00 committed by Denis Redozubov
parent 48df41065f
commit 3348665a88
9 changed files with 540 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
servant-client-jsaddle/CHANGELOG.md Normal file
View file

@ -0,0 +1,3 @@
0.13
----
First version

30
servant-client-jsaddle/LICENSE Normal file
View file

@ -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.

15
servant-client-jsaddle/README.md Normal file
View file

@ -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`.

2
servant-client-jsaddle/Setup.hs Normal file
View file

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

103
servant-client-jsaddle/servant-client-jsaddle.cabal Normal file
View file

@ -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 <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.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

263
servant-client-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs Normal file
View file

@ -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 = <function>"
. 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

20
servant-client-jsaddle/src/Servant/Client/JSaddle.hs Normal file
View file

@ -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

103
servant-client-jsaddle/test/Servant/Client/JsSpec.hs Normal file
View file

@ -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)

1
servant-client-jsaddle/test/Spec.hs Normal file
View file

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}