WIP! Untested! Initial servant-client-ghcjs package

servant-client-ghcjs/CHANGELOG.md

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

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.

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
+```

servant-client-ghcjs/Setup.hs

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

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

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

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

servant-client-ghcjs/tinc.yaml

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