Add servant-client-jsaddle

servant-client-jsaddle/CHANGELOG.md

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

servant-client-jsaddle/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-jsaddle/README.md

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

servant-client-jsaddle/Setup.hs

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

servant-client-jsaddle/servant-client-jsaddle.cabal

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

servant-client-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs

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

servant-client-jsaddle/src/Servant/Client/JSaddle.hs

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

servant-client-jsaddle/test/Servant/Client/JsSpec.hs

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

servant-client-jsaddle/test/Spec.hs

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