@@ -0,0 +1,290 @@
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 GHCJS.Types
41+import JavaScript.Web.Location
42+import Network.HTTP.Types
43+import Network.HTTP.Media (renderHeader)
44+import Servant.Client.Core
45+
46+newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
47+
48+newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
49+
50+newtype ClientEnv
51+ = ClientEnv
52+ { baseUrl :: BaseUrl }
53+ deriving (Eq, Show)
54+
55+client :: HasClient ClientM api => Proxy api -> Client ClientM api
56+client api = api `clientIn` (Proxy :: Proxy ClientM)
57+
58+newtype ClientM a = ClientM
59+ { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
60+ deriving ( Functor, Applicative, Monad, MonadIO, Generic
61+ , MonadReader ClientEnv, MonadError ServantError, MonadThrow
62+ , MonadCatch)
63+
64+instance MonadBase IO ClientM where
65+ liftBase = ClientM . liftBase
66+
67+instance MonadBaseControl IO ClientM where
68+ type StM ClientM a = Either ServantError a
69+
70+ liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))
71+
72+ restoreM st = ClientM (restoreM st)
73+
74+-- | Try clients in order, last error is preserved.
75+instance Alt ClientM where
76+ a <!> b = a `catchError` const b
77+
78+instance RunClient ClientM where
79+ runRequest = performRequest
80+ throwServantError = throwError
81+ catchServantError = catchError
82+
83+instance ClientLike (ClientM a) (ClientM a) where
84+ mkClient = id
85+
86+runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ServantError a)
87+runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm
88+
89+runClientM :: ClientM a -> IO (Either ServantError a)
90+runClientM m = do
91+ curLoc <- getWindowLocation
92+
93+ jsStr_protocol <- getProtocol curLoc
94+ jsStr_port <- getPort curLoc
95+ jsStr_hostname <- getHostname curLoc
96+
97+ let protocol
98+ | jsStr_protocol == "https:" = Https
99+ | otherwise = Http
100+
101+ portStr :: String
102+ portStr = fromJSString $ jsval jsStr_port
103+
104+ port :: Int
105+ port | null portStr = case protocol of
106+ Http -> 80
107+ Https -> 443
108+ | otherwise = read portStr
109+
110+ hostname :: String
111+ hostname = fromJSString $ jsval jsStr_hostname
112+
113+ runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
114+
115+performRequest :: Request -> ClientM Response
116+performRequest req = do
117+ xhr <- liftIO initXhr
118+ burl <- asks baseUrl
119+ liftIO $ performXhr xhr burl req
120+ resp <- toResponse xhr
121+
122+ let status = statusCode (responseStatusCode resp)
123+ unless (status >= 200 && status < 300) $
124+ throwError $ FailureResponse resp
125+
126+ pure resp
127+
128+-- * initialization
129+
130+initXhr :: IO JSXMLHttpRequest
131+initXhr = do
132+ lib <- requireXMLHttpRequestClass
133+ newXMLHttpRequest lib
134+
135+foreign import javascript unsafe
136+ -- branching between node (for testing) and browsers
137+ "(function () {if (typeof require !== 'undefined') { return require('xhr2'); } else { return XMLHttpRequest; };})()"
138+ requireXMLHttpRequestClass :: IO JSXMLHttpRequestClass
139+
140+foreign import javascript unsafe "new $1()"
141+ newXMLHttpRequest :: JSXMLHttpRequestClass -> IO JSXMLHttpRequest
142+
143+-- * performing requests
144+-- Performs the xhr and blocks until the response was received
145+performXhr :: JSXMLHttpRequest -> BaseUrl -> Request -> IO ()
146+performXhr xhr burl request = do
147+
148+ waiter <- newEmptyMVar
149+
150+ bracket (acquire waiter) releaseCallback $ \_callback -> do
151+ t <- myThreadId
152+ s <- newStablePtr t
153+
154+ openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
155+ setHeaders xhr request
156+ sendXhr xhr (toBody request)
157+ takeMVar waiter
158+
159+ freeStablePtr s
160+ where
161+ acquire waiter = onReadyStateChange xhr $ do
162+ state <- readyState xhr
163+ case state of
164+ -- onReadyStateChange's callback can fire state 4
165+ -- (which means "request finished and response is ready")
166+ -- multiple times. By using tryPutMVar, only the first time
167+ -- state 4 is fired will cause an MVar to be put. Subsequent
168+ -- fires are ignored.
169+ 4 -> void $ tryPutMVar waiter ()
170+ _ -> return ()
171+
172+onReadyStateChange :: JSXMLHttpRequest -> IO () -> IO (Callback (IO ()))
173+onReadyStateChange xhr action = do
174+ callback <- asyncCallback action
175+ js_onReadyStateChange xhr callback
176+ return callback
177+foreign import javascript safe "$1.onreadystatechange = $2;"
178+ js_onReadyStateChange :: JSXMLHttpRequest -> Callback (IO ()) -> IO ()
179+
180+foreign import javascript unsafe "$1.readyState"
181+ readyState :: JSXMLHttpRequest -> IO Int
182+
183+openXhr :: JSXMLHttpRequest -> String -> String -> Bool -> IO ()
184+openXhr xhr method url =
185+ js_openXhr xhr (toJSString method) (toJSString url)
186+foreign import javascript unsafe "$1.open($2, $3, $4)"
187+ js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
188+
189+toUrl :: BaseUrl -> Request -> String
190+toUrl burl request =
191+ let pathS = cs $ toLazyByteString $ requestPath request
192+ queryS =
193+ cs $
194+ renderQuery True $
195+ toList $
196+ requestQueryString request
197+ in showBaseUrl burl ++ pathS ++ queryS
198+
199+setHeaders :: JSXMLHttpRequest -> Request -> IO ()
200+setHeaders xhr request = do
201+ forM_ (toList $ requestAccept request) $ \mediaType ->
202+ js_setRequestHeader
203+ xhr
204+ (toJSString "Accept")
205+ (toJSString $ cs $ renderHeader mediaType)
206+
207+ forM_ (requestBody request) $ \(_, mediaType) ->
208+ js_setRequestHeader
209+ xhr
210+ (toJSString "Content-Type")
211+ (toJSString $ cs $ renderHeader mediaType)
212+
213+ forM_ (toList $ requestHeaders request) $ \(key, value) ->
214+ js_setRequestHeader xhr (toJSString $ cs $ original key) (toJSString $ cs value)
215+
216+foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
217+ js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
218+
219+sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()
220+sendXhr xhr Nothing = js_sendXhr xhr
221+sendXhr xhr (Just body) =
222+ js_sendXhrWithBody xhr (toJSString body)
223+
224+foreign import javascript unsafe "$1.send()"
225+ js_sendXhr :: JSXMLHttpRequest -> IO ()
226+
227+foreign import javascript unsafe "$1.send($2)"
228+ js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
229+
230+toBody :: Request -> Maybe String
231+toBody request = case requestBody request of
232+ Nothing -> Nothing
233+ Just (RequestBodyLBS "", _) -> Nothing
234+ Just (RequestBodyLBS x, _) -> Just $ cs x
235+
236+-- * inspecting the xhr response
237+
238+-- This function is only supposed to handle 'ConnectionError's. Other
239+-- 'ServantError's are created in Servant.Client.Req.
240+toResponse :: JSXMLHttpRequest -> ClientM Response
241+toResponse xhr = do
242+ status <- liftIO $ getStatus xhr
243+ case status of
244+ 0 -> throwError $ ConnectionError "connection error"
245+ _ -> liftIO $ do
246+ statusText <- cs <$> getStatusText xhr
247+ headers <- parseHeaders <$> getAllResponseHeaders xhr
248+ responseText <- cs <$> getResponseText xhr
249+ pure Response
250+ { responseStatusCode = mkStatus status statusText
251+ , responseBody = responseText
252+ , responseHeaders = Seq.fromList headers
253+ , responseHttpVersion = http11 -- this is made up
254+ }
255+
256+foreign import javascript unsafe "$1.status"
257+ getStatus :: JSXMLHttpRequest -> IO Int
258+
259+getStatusText :: JSXMLHttpRequest -> IO String
260+getStatusText = fmap fromJSString . js_statusText
261+foreign import javascript unsafe "$1.statusText"
262+ js_statusText :: JSXMLHttpRequest -> IO JSVal
263+
264+getAllResponseHeaders :: JSXMLHttpRequest -> IO String
265+getAllResponseHeaders xhr =
266+ fromJSString <$> js_getAllResponseHeaders xhr
267+foreign import javascript unsafe "$1.getAllResponseHeaders()"
268+ js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
269+
270+getResponseText :: JSXMLHttpRequest -> IO String
271+getResponseText xhr = fromJSString <$> js_responseText xhr
272+foreign import javascript unsafe "$1.responseText"
273+ js_responseText :: JSXMLHttpRequest -> IO JSVal
274+
275+parseHeaders :: String -> ResponseHeaders
276+parseHeaders s =
277+ (first mk . first strip . second strip . parseHeader) <$>
278+ splitOn "\r\n" (cs s)
279+ where
280+ parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)
281+ parseHeader h = case BS.breakSubstring ":" (cs h) of
282+ (key, BS.drop 1 -> value) -> (key, value)
283+
284+ splitOn :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
285+ splitOn separator input = case BS.breakSubstring separator input of
286+ (prefix, "") -> [prefix]
287+ (prefix, rest) -> prefix : splitOn separator (BS.drop (BS.length separator) rest)
288+
289+ strip :: BS.ByteString -> BS.ByteString
290+ strip = BS.dropWhile isSpace . BS.reverse . BS.dropWhile isSpace . BS.reverse