@@ -1,246 +0,0 @@
1−{-# LANGUAGE FlexibleInstances #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE QuasiQuotes #-}
4−{-# LANGUAGE TypeSynonymInstances #-}
5−module Reflex.Dom.Xhr.Foreign ( module Reflex.Dom.Xhr.Foreign
6− , XhrResponseType
7− ) where
8−
9−import Control.Concurrent.MVar
10−import Control.Exception.Base
11−import Control.Monad
12−import Data.Text (Text)
13−import qualified Data.Text as T
14−import GHCJS.DOM.File
15−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
16−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
17−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
18−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
19−import Graphics.UI.Gtk.WebKit.Types hiding (Text)
20−import Reflex.Dom.Xhr.Exception
21−import Reflex.Dom.Xhr.ResponseType
22−import System.Glib.FFI
23−
24−import Text.RawString.QQ
25−
26−data XMLHttpRequest
27− = XMLHttpRequest { xhrValue :: JSValueRef
28− , xhrContext :: JSContextRef --TODO: Get rid of this
29− }
30− deriving (Eq, Ord)
31−
32−class IsXhrPayload a where
33− xmlHttpRequestSend :: XMLHttpRequest -> a -> IO ()
34−
35−instance IsXhrPayload () where
36− xmlHttpRequestSend xhr _ = xmlHttpRequestSendPayload xhr Nothing
37−
38−instance IsXhrPayload Text where
39− xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . Just
40−
41−instance IsXhrPayload String where
42− xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . Just . T.pack
43−
44−instance IsXhrPayload File where
45− xmlHttpRequestSend = error "xmlHttpRequestSend{File}: not implemented"
46−
47−stringToJSValue :: JSContextRef -> Text -> IO JSValueRef
48−stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring (T.unpack s)
49−
50−fromResponseType :: XhrResponseType -> Text
51−fromResponseType XhrResponseType_Default = ""
52−fromResponseType XhrResponseType_ArrayBuffer = "arraybuffer"
53−fromResponseType XhrResponseType_Blob = "blob"
54−fromResponseType XhrResponseType_Text = "text"
55−
56−toResponseType :: Text -> Maybe XhrResponseType
57−toResponseType "" = Just XhrResponseType_Default
58−toResponseType "arraybuffer" = Just XhrResponseType_ArrayBuffer
59−toResponseType "blob" = Just XhrResponseType_Blob
60−toResponseType "text" = Just XhrResponseType_Text
61−toResponseType _ = Nothing
62−
63−xmlHttpRequestNew :: WebView -> IO XMLHttpRequest
64−xmlHttpRequestNew wv = withWebViewContext wv $ \jsContext -> do
65− xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()"
66− xhr' <- jsevaluatescript jsContext xhrScript nullPtr nullPtr 1 nullPtr
67− jsvalueprotect jsContext xhr'
68− return $ XMLHttpRequest xhr' jsContext
69−
70−xmlHttpRequestOpen :: XMLHttpRequest -> Text -> Text -> Bool -> Text -> Text -> IO ()
71−xmlHttpRequestOpen xhr method url async user password = do
72− let c = xhrContext xhr
73− method' <- stringToJSValue c method
74− url' <- stringToJSValue c url
75− async' <- jsvaluemakeboolean (xhrContext xhr) async
76− user' <- stringToJSValue c user
77− password' <- stringToJSValue c password
78− o <- toJSObject c [xhrValue xhr, method', url', async', user', password']
79− script <- jsstringcreatewithutf8cstring "this[0].open(this[1], this[2], this[3], this[4], this[5])"
80− _ <- jsevaluatescript c script o nullPtr 1 nullPtr
81− return ()
82−
83−xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> IO () -> IO ()
84−xmlHttpRequestOnreadystatechange xhr userCallback = do
85− let c = xhrContext xhr
86− fp <- wrapper $ \_ _ _ _ _ _ -> do
87− userCallback
88− jsvaluemakeundefined c
89− cb <- jsobjectmakefunctionwithcallback c nullPtr fp
90− o <- toJSObject c [xhrValue xhr, cb]
91− script <- jsstringcreatewithutf8cstring "this[0].onreadystatechange=this[1]"
92− _ <- jsevaluatescript c script o nullPtr 1 nullPtr
93− return ()
94−
95−xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word
96−xmlHttpRequestGetReadyState xhr = do
97− let c = xhrContext xhr
98− script <- jsstringcreatewithutf8cstring "this.readyState"
99− rs <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
100− d <- jsvaluetonumber c rs nullPtr
101− return $ truncate d
102−
103−xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType)
104−xmlHttpRequestGetResponseType xhr = do
105− script <- jsstringcreatewithutf8cstring "this.responseType"
106− rt <- jsevaluatescript (xhrContext xhr) script (xhrValue xhr) nullPtr 1 nullPtr
107− ms <- fromJSStringMaybe (xhrContext xhr) rt
108− return $ join $ fmap toResponseType ms
109−
110−xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)
111−xmlHttpRequestGetResponse xhr = do
112− let c = xhrContext xhr
113− mrt <- xmlHttpRequestGetResponseType xhr
114− script <- jsstringcreatewithutf8cstring "this.response"
115− t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
116− isNull <- jsvalueisnull c t
117− if isNull then return Nothing else case mrt of
118− Just XhrResponseType_ArrayBuffer -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer c t
119− Just XhrResponseType_Blob -> Just . XhrResponseBody_Blob . Blob . castForeignPtr <$> newForeignPtr_ t
120− Just XhrResponseType_Default -> fmap XhrResponseBody_Default <$> fromJSStringMaybe c t
121− Just XhrResponseType_Text -> fmap XhrResponseBody_Text <$> fromJSStringMaybe c t
122− _ -> return Nothing
123−
124−xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text)
125−xmlHttpRequestGetResponseText xhr = do
126− let c = xhrContext xhr
127− script <- jsstringcreatewithutf8cstring "this.responseText"
128− t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
129− fromJSStringMaybe c t
130−
131−xmlHttpRequestSendPayload :: XMLHttpRequest -> Maybe Text -> IO ()
132−xmlHttpRequestSendPayload xhr payload = do
133− let c = xhrContext xhr
134− result <- newEmptyMVar
135− let wrapper' x = wrapper $ \_ _ _ _ _ _ -> putMVar result x >> jsvaluemakeundefined c
136− bracket (wrapper' $ Just XhrException_Aborted) freeHaskellFunPtr $ \a -> do
137− onAbort <- jsobjectmakefunctionwithcallback c nullPtr a
138− bracket (wrapper' $ Just XhrException_Error) freeHaskellFunPtr $ \e -> do
139− onError <- jsobjectmakefunctionwithcallback c nullPtr e
140− bracket (wrapper' Nothing) freeHaskellFunPtr $ \l -> do
141− onLoad <- jsobjectmakefunctionwithcallback c nullPtr l
142− d <- case payload of
143− Nothing -> jsvaluemakeundefined c
144− Just payload' -> stringToJSValue c payload'
145− o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]
146− s <- jsstringcreatewithutf8cstring send
147− _ <- jsevaluatescript c s o nullPtr 1 nullPtr
148− takeMVar result >>= mapM_ throwIO
149− where
150− send = [r|
151− (function (xhr, d, onError, onAbort, onLoad) {
152− var clear;
153− var error = function () {
154− clear(); onError();
155− };
156− var abort = function () {
157− clear(); onAbort();
158− };
159− var load = function () {
160− clear(); onLoad();
161− };
162− clear = function () {
163− xhr.removeEventListener('error', error);
164− xhr.removeEventListener('abort', abort);
165− xhr.removeEventListener('load', load);
166− }
167− xhr.addEventListener('error', error);
168− xhr.addEventListener('abort', abort);
169− xhr.addEventListener('load', load);
170− if(d) {
171− xhr.send(d);
172− } else {
173− xhr.send();
174− }
175− })(this[0], this[1], this[2], this[3], this[4])
176− |]
177−
178−xmlHttpRequestSetRequestHeader :: XMLHttpRequest -> Text -> Text -> IO ()
179−xmlHttpRequestSetRequestHeader xhr header value = do
180− let c = xhrContext xhr
181− header' <- stringToJSValue c header
182− value' <- stringToJSValue c value
183− o <- toJSObject c [xhrValue xhr, header', value']
184− script <- jsstringcreatewithutf8cstring "this[0].setRequestHeader(this[1], this[2])"
185− _ <- jsevaluatescript c script o nullPtr 1 nullPtr
186− return ()
187−
188−xmlHttpRequestSetResponseType :: XMLHttpRequest -> Text -> IO ()
189−xmlHttpRequestSetResponseType xhr t = do
190− let c = xhrContext xhr
191− t' <- stringToJSValue c t
192− o <- toJSObject c [xhrValue xhr, t']
193− script <- jsstringcreatewithutf8cstring "this[0].responseType = this[1]"
194− _ <- jsevaluatescript c script o nullPtr 1 nullPtr
195− return ()
196−
197−xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word
198−xmlHttpRequestGetStatus xhr = do
199− let c = xhrContext xhr
200− script <- jsstringcreatewithutf8cstring "this.status"
201− s <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
202− d <- jsvaluetonumber c s nullPtr
203− return $ truncate d
204−
205−xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO Text
206−xmlHttpRequestGetStatusText xhr =
207− xmlAuxHttpRequestGetWithJS xhr "this.statusText"
208−
209−xmlHttpRequestSetWithCredentials :: XMLHttpRequest -> Bool -> IO ()
210−xmlHttpRequestSetWithCredentials xhr b = do
211− let c = xhrContext xhr
212− b' <- jsvaluemakeboolean c b
213− o <- toJSObject c [xhrValue xhr, b']
214− script <- jsstringcreatewithutf8cstring "this[0].withCredentials = this[1]"
215− _ <- jsevaluatescript c script o nullPtr 1 nullPtr
216− return ()
217−
218−xmlHttpRequestGetAllResponseHeaders :: XMLHttpRequest -> IO Text
219−xmlHttpRequestGetAllResponseHeaders xhr =
220− xmlAuxHttpRequestGetWithJS xhr "this.getAllResponseHeaders()"
221−
222−xmlHttpRequestGetResponseHeader :: XMLHttpRequest -> Text -> IO Text
223−xmlHttpRequestGetResponseHeader xhr hdr = do
224− let c = xhrContext xhr
225− t' <- stringToJSValue c hdr
226− o <- toJSObject c [xhrValue xhr, t']
227− script <- jsstringcreatewithutf8cstring "this[0].getResponseHeader(this[1])"
228− t <- jsevaluatescript c script o nullPtr 1 nullPtr
229− xmlAuxJsGetString c t
230−
231−xmlAuxHttpRequestGetWithJS :: XMLHttpRequest -> String -> IO Text
232−xmlAuxHttpRequestGetWithJS xhr jsScript = do
233− let c = xhrContext xhr
234− script <- jsstringcreatewithutf8cstring jsScript
235− t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
236− xmlAuxJsGetString c t
237−
238−xmlAuxJsGetString :: JSContextRef -> JSValueRef -> IO Text
239−xmlAuxJsGetString c t = do
240− j <- jsvaluetostringcopy c t nullPtr
241− l <- jsstringgetmaximumutf8cstringsize j
242− s <- allocaBytes (fromIntegral l) $ \ps -> do
243− _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
244− peekCString ps
245− return $ T.pack s
246−