git.iko.soy/typeable/servant
on master help sign in
WIP! Untested! Initial servant-client-ghcjs package
67f2285Falco Peijnenburg
servant-client-ghcjs/CHANGELOG.mdnew file+3
compare with master
unifiedsplit
@@ -0,0 +1,3 @@
1+0.11
2+----
3+Initial
servant-client-ghcjs/LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Zalora South East Asia Pte Ltd nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
servant-client-ghcjs/README.mdnew file+20
@@ -0,0 +1,20 @@
1+# servant-client-ghcjs
2+
3+![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
4+
5+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.
6+
7+## Example
8+
9+``` haskell
10+type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
11+ :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
12+
13+myApi :: Proxy MyApi
14+myApi = Proxy
15+
16+getAllBooks :: Manager -> BaseUrl -> ExceptT String IO [Book]
17+postNewBook :: Book -> Manager -> BaseUrl -> ExceptT String IO Book
18+-- 'client' allows you to produce operations to query an API from a client.
19+(getAllBooks :<|> postNewBook) = client myApi
20+```
servant-client-ghcjs/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
servant-client-ghcjs/servant-client-ghcjs.cabalnew file+54
@@ -0,0 +1,54 @@
1+name: servant-client-ghcjs
2+version: 0.11
3+synopsis: automatical derivation of querying functions for servant webservices for ghcjs
4+description:
5+ This library lets you automatically derive Haskell functions that
6+ let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
7+ .
8+ See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.
9+ .
10+ <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
11+license: BSD3
12+license-file: LICENSE
13+author: Servant Contributors
14+maintainer: haskell-servant-maintainers@googlegroups.com
15+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors
16+category: Servant, Web
17+build-type: Simple
18+cabal-version: >=1.10
19+tested-with: GHC >= 7.8
20+homepage: http://haskell-servant.readthedocs.org/
21+Bug-reports: http://github.com/haskell-servant/servant/issues
22+extra-source-files:
23+ CHANGELOG.md
24+ README.md
25+source-repository head
26+ type: git
27+ location: http://github.com/haskell-servant/servant.git
28+
29+library
30+ exposed-modules:
31+ Servant.Client.Ghcjs
32+ Servant.Client.Internal.XhrClient
33+ build-depends:
34+ base >= 4.7 && < 4.11
35+ , bytestring >= 0.10 && < 0.11
36+ , case-insensitive >= 1.2.0.0 && < 1.3.0.0
37+ , containers >= 0.5 && < 0.6
38+ , exceptions >= 0.8 && < 0.9
39+ , ghcjs-base
40+ , ghcjs-prim
41+ , http-types >= 0.8.6 && < 0.10
42+ , monad-control >= 1.0.0.4 && < 1.1
43+ , mtl >= 2.1 && < 2.3
44+ , semigroupoids >= 4.3 && < 5.3
45+ , servant-client-core == 0.11.*
46+ , string-conversions >= 0.3 && < 0.5
47+ , transformers >= 0.3 && < 0.6
48+ , transformers-base >= 0.4.4 && < 0.5
49+ hs-source-dirs: src
50+ default-language: Haskell2010
51+ ghc-options: -Wall
52+ if impl(ghc >= 8.0)
53+ ghc-options: -Wno-redundant-constraints
54+ include-dirs: include
servant-client-ghcjs/src/Servant/Client/Ghcjs.hsnew file+14
@@ -0,0 +1,14 @@
1+-- | This module provides 'client' which can automatically generate
2+-- querying functions for each endpoint just from the type representing your
3+-- API.
4+module Servant.Client.Ghcjs
5+ (
6+ client
7+ , GhcjsClientM
8+ , runGhcjsClientM
9+ , GhcjsClientEnv(..)
10+ , module Servant.Client.Core.Reexport
11+ ) where
12+
13+import Servant.Client.Internal.XhrClient
14+import Servant.Client.Core.Reexport
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hsnew file+241
@@ -0,0 +1,241 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE ViewPatterns #-}
11+
12+
13+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
14+
15+module Servant.Client.Internal.XhrClient where
16+
17+import Control.Arrow
18+import Data.ByteString.Builder (toLazyByteString)
19+import Control.Concurrent
20+import Control.Exception
21+import Control.Monad
22+import Control.Monad.Base (MonadBase (..))
23+import Control.Monad.Catch (MonadCatch, MonadThrow)
24+import Control.Monad.Error.Class (MonadError (..))
25+import Control.Monad.Reader
26+import Control.Monad.Trans.Control (MonadBaseControl (..))
27+import Control.Monad.Trans.Except
28+import qualified Data.ByteString.Char8 as BS
29+import Data.CaseInsensitive
30+import Data.Char
31+import Data.Foldable (toList)
32+import Data.Functor.Alt (Alt (..))
33+import Data.Proxy (Proxy (..))
34+import qualified Data.Sequence as Seq
35+import Data.String.Conversions
36+import Foreign.StablePtr
37+import GHC.Generics
38+import GHCJS.Foreign.Callback
39+import GHCJS.Prim
40+import Network.HTTP.Types
41+import Servant.Client.Core
42+
43+newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
44+
45+newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
46+
47+newtype GhcjsClientEnv
48+ = GhcjsClientEnv
49+ { baseUrl :: BaseUrl }
50+ deriving (Eq, Show)
51+
52+client :: HasClient GhcjsClientM api => Proxy api -> Client GhcjsClientM api
53+client api = api `clientIn` (Proxy :: Proxy GhcjsClientM)
54+
55+newtype GhcjsClientM a = GhcjsClientM
56+ { runGhcjsClientM' :: ReaderT GhcjsClientEnv (ExceptT ServantError IO) a }
57+ deriving ( Functor, Applicative, Monad, MonadIO, Generic
58+ , MonadReader GhcjsClientEnv, MonadError ServantError, MonadThrow
59+ , MonadCatch)
60+
61+instance MonadBase IO GhcjsClientM where
62+ liftBase = GhcjsClientM . liftBase
63+
64+instance MonadBaseControl IO GhcjsClientM where
65+ type StM GhcjsClientM a = Either ServantError a
66+
67+ liftBaseWith f = GhcjsClientM (liftBaseWith (\g -> f (g . runGhcjsClientM')))
68+
69+ restoreM st = GhcjsClientM (restoreM st)
70+
71+-- | Try clients in order, last error is preserved.
72+instance Alt GhcjsClientM where
73+ a <!> b = a `catchError` const b
74+
75+instance RunClient GhcjsClientM where
76+ runRequest = performRequest
77+ throwServantError = throwError
78+ catchServantError = catchError
79+
80+instance ClientLike (GhcjsClientM a) (GhcjsClientM a) where
81+ mkClient = id
82+
83+runGhcjsClientM :: GhcjsClientM a -> GhcjsClientEnv -> IO (Either ServantError a)
84+runGhcjsClientM cm env = runExceptT $ flip runReaderT env $ runGhcjsClientM' cm
85+
86+performRequest :: Request -> GhcjsClientM Response
87+performRequest req = do
88+ xhr <- liftIO initXhr
89+ burl <- asks baseUrl
90+ liftIO $ performXhr xhr burl req
91+ toResponse xhr
92+
93+-- * initialization
94+
95+initXhr :: IO JSXMLHttpRequest
96+initXhr = do
97+ lib <- requireXMLHttpRequestClass
98+ newXMLHttpRequest lib
99+
100+foreign import javascript unsafe
101+ -- branching between node (for testing) and browsers
102+ "(function () {if (typeof require !== 'undefined') { return require('xhr2'); } else { return XMLHttpRequest; };})()"
103+ requireXMLHttpRequestClass :: IO JSXMLHttpRequestClass
104+
105+foreign import javascript unsafe "new $1()"
106+ newXMLHttpRequest :: JSXMLHttpRequestClass -> IO JSXMLHttpRequest
107+
108+-- * performing requests
109+-- Performs the xhr and blocks until the response was received
110+performXhr :: JSXMLHttpRequest -> BaseUrl -> Request -> IO ()
111+performXhr xhr burl request = do
112+
113+ waiter <- newEmptyMVar
114+
115+ bracket (acquire waiter) releaseCallback $ \_callback -> do
116+ t <- myThreadId
117+ s <- newStablePtr t
118+
119+ openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
120+ setHeaders xhr $ toList $ requestHeaders request
121+ sendXhr xhr (toBody request)
122+ takeMVar waiter
123+
124+ freeStablePtr s
125+ where
126+ acquire waiter = onReadyStateChange xhr $ do
127+ state <- readyState xhr
128+ case state of
129+ -- onReadyStateChange's callback can fire state 4
130+ -- (which means "request finished and response is ready")
131+ -- multiple times. By using tryPutMVar, only the first time
132+ -- state 4 is fired will cause an MVar to be put. Subsequent
133+ -- fires are ignored.
134+ 4 -> void $ tryPutMVar waiter ()
135+ _ -> return ()
136+
137+onReadyStateChange :: JSXMLHttpRequest -> IO () -> IO (Callback (IO ()))
138+onReadyStateChange xhr action = do
139+ callback <- asyncCallback action
140+ js_onReadyStateChange xhr callback
141+ return callback
142+foreign import javascript safe "$1.onreadystatechange = $2;"
143+ js_onReadyStateChange :: JSXMLHttpRequest -> Callback (IO ()) -> IO ()
144+
145+foreign import javascript unsafe "$1.readyState"
146+ readyState :: JSXMLHttpRequest -> IO Int
147+
148+openXhr :: JSXMLHttpRequest -> String -> String -> Bool -> IO ()
149+openXhr xhr method url =
150+ js_openXhr xhr (toJSString method) (toJSString url)
151+foreign import javascript unsafe "$1.open($2, $3, $4)"
152+ js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
153+
154+toUrl :: BaseUrl -> Request -> String
155+toUrl burl request =
156+ let pathS = cs $ toLazyByteString $ requestPath request
157+ queryS =
158+ cs $
159+ renderQuery True $
160+ toList $
161+ requestQueryString request
162+ in showBaseUrl burl ++ pathS ++ queryS
163+
164+setHeaders :: JSXMLHttpRequest -> RequestHeaders -> IO ()
165+setHeaders xhr headers = forM_ headers $ \ (key, value) ->
166+ js_setRequestHeader xhr (toJSString $ cs $ original key) (toJSString $ cs value)
167+foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
168+ js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
169+
170+sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()
171+sendXhr xhr Nothing = js_sendXhr xhr
172+sendXhr xhr (Just body) =
173+ js_sendXhrWithBody xhr (toJSString body)
174+
175+foreign import javascript unsafe "$1.send()"
176+ js_sendXhr :: JSXMLHttpRequest -> IO ()
177+
178+foreign import javascript unsafe "$1.send($2)"
179+ js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
180+
181+toBody :: Request -> Maybe String
182+toBody request = case requestBody request of
183+ Nothing -> Nothing
184+ Just (RequestBodyLBS "", _) -> Nothing
185+ Just (RequestBodyLBS x, _) -> Just $ cs x
186+
187+-- * inspecting the xhr response
188+
189+-- This function is only supposed to handle 'ConnectionError's. Other
190+-- 'ServantError's are created in Servant.Client.Req.
191+toResponse :: JSXMLHttpRequest -> GhcjsClientM Response
192+toResponse xhr = do
193+ status <- liftIO $ getStatus xhr
194+ case status of
195+ 0 -> throwError $ ConnectionError "connection error"
196+ _ -> liftIO $ do
197+ statusText <- cs <$> getStatusText xhr
198+ headers <- parseHeaders <$> getAllResponseHeaders xhr
199+ responseText <- cs <$> getResponseText xhr
200+ pure Response
201+ { responseStatusCode = mkStatus status statusText
202+ , responseBody = responseText
203+ , responseHeaders = Seq.fromList headers
204+ , responseHttpVersion = http11 -- this is made up
205+ }
206+
207+foreign import javascript unsafe "$1.status"
208+ getStatus :: JSXMLHttpRequest -> IO Int
209+
210+getStatusText :: JSXMLHttpRequest -> IO String
211+getStatusText = fmap fromJSString . js_statusText
212+foreign import javascript unsafe "$1.statusText"
213+ js_statusText :: JSXMLHttpRequest -> IO JSVal
214+
215+getAllResponseHeaders :: JSXMLHttpRequest -> IO String
216+getAllResponseHeaders xhr =
217+ fromJSString <$> js_getAllResponseHeaders xhr
218+foreign import javascript unsafe "$1.getAllResponseHeaders()"
219+ js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
220+
221+getResponseText :: JSXMLHttpRequest -> IO String
222+getResponseText xhr = fromJSString <$> js_responseText xhr
223+foreign import javascript unsafe "$1.responseText"
224+ js_responseText :: JSXMLHttpRequest -> IO JSVal
225+
226+parseHeaders :: String -> ResponseHeaders
227+parseHeaders s =
228+ (first mk . first strip . second strip . parseHeader) <$>
229+ splitOn "\r\n" (cs s)
230+ where
231+ parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)
232+ parseHeader h = case BS.breakSubstring ":" (cs h) of
233+ (key, BS.drop 1 -> value) -> (key, value)
234+
235+ splitOn :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
236+ splitOn separator input = case BS.breakSubstring separator input of
237+ (prefix, "") -> [prefix]
238+ (prefix, rest) -> prefix : splitOn separator (BS.drop (BS.length separator) rest)
239+
240+ strip :: BS.ByteString -> BS.ByteString
241+ strip = BS.dropWhile isSpace . BS.reverse . BS.dropWhile isSpace . BS.reverse
servant-client-ghcjs/tinc.yamlnew file+5
@@ -0,0 +1,5 @@
1+dependencies:
2+ - name: servant
3+ path: ../servant
4+ - name: servant-server
5+ path: ../servant-server