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

Merge pull request #818 from LumiGuide/feat-client-ghcjs

Browse Source 
servant-client-ghcjs
This commit is contained in:
Oleg Grenrus 2017-12-03 17:19:15 +02:00 committed by GitHub
commit 13986429ef
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
8 changed files with 573 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
servant-client-ghcjs/CHANGELOG.md Normal file
View File

@ -0,0 +1,3 @@
0.11
----
Initial

30
servant-client-ghcjs/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.

175
servant-client-ghcjs/README.md Normal file
View File

@ -0,0 +1,175 @@
# servant-client-ghcjs
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](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`.
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)
```haskell
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
module Main where
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
:<|> "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 -- From the 'servant-client-core' package
...
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
main :: IO ()
main = do
ePos <- runClientM $ position apiClient 10 20
print ePos
```
Here's how the requests would be performed using the regular `servant-client` package:
```haskell
import Servant.Client
import 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
```

2
servant-client-ghcjs/Setup.hs Normal file
View File

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

54
servant-client-ghcjs/servant-client-ghcjs.cabal Normal file
View File

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

14
servant-client-ghcjs/src/Servant/Client/Ghcjs.hs Normal file
View File

@ -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
, ClientM
, runClientM
, ClientEnv(..)
, module Servant.Client.Core.Reexport
) where
import Servant.Client.Internal.XhrClient
import Servant.Client.Core.Reexport

290
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs Normal file
View File

@ -0,0 +1,290 @@
{-# 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 GHCJS.Types
import JavaScript.Web.Location
import Network.HTTP.Types
import Network.HTTP.Media (renderHeader)
import Servant.Client.Core
newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
newtype ClientEnv
= ClientEnv
{ baseUrl :: BaseUrl }
deriving (Eq, Show)
client :: HasClient ClientM api => Proxy api -> Client ClientM api
client api = api `clientIn` (Proxy :: Proxy ClientM)
newtype ClientM a = ClientM
{ runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
deriving ( Functor, Applicative, Monad, MonadIO, Generic
, MonadReader ClientEnv, MonadError ServantError, MonadThrow
, MonadCatch)
instance MonadBase IO ClientM where
liftBase = ClientM . liftBase
instance MonadBaseControl IO ClientM where
type StM ClientM a = Either ServantError a
liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))
restoreM st = ClientM (restoreM st)
-- | Try clients in order, last error is preserved.
instance Alt ClientM where
a <!> b = a `catchError` const b
instance RunClient ClientM where
runRequest = performRequest
throwServantError = throwError
catchServantError = catchError
instance ClientLike (ClientM a) (ClientM a) where
mkClient = id
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
xhr <- liftIO initXhr
burl <- asks baseUrl
liftIO $ performXhr xhr burl req
resp <- toResponse xhr
let status = statusCode (responseStatusCode resp)
unless (status >= 200 && status < 300) $
throwError $ FailureResponse resp
pure resp
-- * 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 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 -> 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 ()
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 -> ClientM 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

5
servant-client-ghcjs/tinc.yaml Normal file
View File

@ -0,0 +1,5 @@
dependencies:
- name: servant
path: ../servant
- name: servant-server
path: ../servant-server