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