git.iko.soy/reflex-dom
on develop help sign in
Make Xhr work in webkit
82dcb94Ali Abrar
default.nix+5−2
compare with develop
unifiedsplit
@@ -1,6 +1,7 @@
1{ mkDerivation, dependent-map, ghcjs-dom, lens
1{ mkDerivation, dependent-map, ghcjs-dom, lens
2, mtl, reflex, safe, text, these
2, mtl, reflex, safe, text, these
3−, transformers, data-default, semigroups
3+, transformers, data-default, semigroups, aeson
4+, c2hs, ghc, webkit-javascriptcore
4}:
5}:
5
6
6mkDerivation {
7mkDerivation {
@@ -19,6 +20,8 @@ mkDerivation {
19 text
20 text
20 data-default
21 data-default
21 semigroups
22 semigroups
22− ];
23+ aeson
24+ ] ++ (if (ghc.pname or null) == "ghcjs" then [ ] else [ webkit-javascriptcore ]);
25+ buildTools = if (ghc.pname or null) == "ghcjs" then [ ] else [ c2hs ];
23 license = null;
26 license = null;
24}
27}
reflex-dom.cabal+14−2
@@ -28,13 +28,22 @@ library
28 text,
28 text,
29 bytestring,
29 bytestring,
30 data-default,
30 data-default,
31− semigroups
31+ semigroups,
32+ aeson
32
33
33 if impl(ghcjs)
34 if impl(ghcjs)
35+ hs-source-dirs: src-ghcjs
34 cpp-options: -D__GHCJS__
36 cpp-options: -D__GHCJS__
35 build-depends:
37 build-depends:
36− aeson,
37 ghcjs-base
38 ghcjs-base
39+ else
40+ hs-source-dirs: src-ghc
41+ build-tools: c2hs
42+ build-depends:
43+ glib >=0.13.0.0 && <0.14,
44+ gtk >=0.13.0.0 && <0.14,
45+ webkit >=0.13.0.0 && <0.14,
46+ webkit-javascriptcore
38
47
39 exposed-modules:
48 exposed-modules:
40 Reflex.Dom
49 Reflex.Dom
@@ -44,6 +53,9 @@ library
44 Reflex.Dom.Widget.Basic
53 Reflex.Dom.Widget.Basic
45 Reflex.Dom.Widget.Input
54 Reflex.Dom.Widget.Input
46 Reflex.Dom.Xhr
55 Reflex.Dom.Xhr
56+ other-modules:
57+ Reflex.Dom.Internal.Foreign
58+ Reflex.Dom.Xhr.Foreign
47
59
48 other-extensions: TemplateHaskell
60 other-extensions: TemplateHaskell
49 ghc-prof-options: -fprof-auto
61 ghc-prof-options: -fprof-auto
src-ghc/Reflex/Dom/Internal/Foreign.hsnew file+56
@@ -0,0 +1,56 @@
1+module Reflex.Dom.Internal.Foreign where
2+
3+import GHCJS.DOM hiding (runWebGUI)
4+import Control.Concurrent
5+import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get)
6+import GHCJS.DOM.Navigator
7+import GHCJS.DOM.DOMWindow
8+import Graphics.UI.Gtk hiding (Widget)
9+import Graphics.UI.Gtk.WebKit.WebView
10+import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget, unWidget)
11+import Graphics.UI.Gtk.WebKit.WebSettings
12+import Graphics.UI.Gtk.WebKit.WebFrame
13+import Data.List
14+
15+makeDefaultWebView :: String -> (WebView -> IO ()) -> IO ()
16+makeDefaultWebView userAgentKey main = do
17+ _ <- initGUI
18+ window <- windowNew
19+ _ <- timeoutAddFull (yield >> return True) priorityHigh 10
20+ windowSetDefaultSize window 900 600
21+ windowSetPosition window WinPosCenter
22+ scrollWin <- scrolledWindowNew Nothing Nothing
23+ webView <- webViewNew
24+ settings <- webViewGetWebSettings webView
25+ userAgent <- settings `get` webSettingsUserAgent
26+ settings `set` [ webSettingsUserAgent := userAgent ++ " " ++ userAgentKey
27+ , webSettingsEnableUniversalAccessFromFileUris := True
28+ ]
29+ webViewSetWebSettings webView settings
30+ window `containerAdd` scrollWin
31+ scrollWin `containerAdd` webView
32+ _ <- on window objectDestroy . liftIO $ mainQuit
33+ widgetShowAll window
34+ _ <- webView `on` loadFinished $ \_ -> do
35+ main webView
36+ wf <- webViewGetMainFrame webView
37+ webFrameLoadString wf "" Nothing "file:///"
38+ main webView
39+ mainGUI
40+
41+runWebGUI :: (WebView -> IO ()) -> IO ()
42+runWebGUI = runWebGUI' "GHCJS"
43+
44+runWebGUI' :: String -> (WebView -> IO ()) -> IO ()
45+runWebGUI' userAgentKey main = do
46+ -- Are we in a java script inside some kind of browser
47+ mbWindow <- currentWindow
48+ case mbWindow of
49+ Just window -> do
50+ -- Check if we are running in javascript inside the the native version
51+ Just n <- domWindowGetNavigator window
52+ agent <- navigatorGetUserAgent n
53+ unless ((" " ++ userAgentKey) `isSuffixOf` agent) $ main (castToWebView window)
54+ Nothing -> do
55+ makeDefaultWebView userAgentKey main
56+
src-ghc/Reflex/Dom/Xhr/Foreign.hsnew file+136
@@ -0,0 +1,136 @@
1+{-# LANGUAGE ForeignFunctionInterface #-}
2+module Reflex.Dom.Xhr.Foreign where
3+
4+import Control.Lens.Indexed
5+import qualified Data.Text as T
6+import Data.Text (Text)
7+import System.Glib.FFI
8+import Graphics.UI.Gtk.WebKit.WebView
9+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
10+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
11+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
12+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
13+import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
14+
15+data XMLHttpRequest = XMLHttpRequest JSValueRef JSContextRef deriving (Eq, Ord)
16+
17+xhrContext :: XMLHttpRequest -> JSContextRef
18+xhrContext (XMLHttpRequest _ c) = c
19+
20+xhrValue :: XMLHttpRequest -> JSValueRef
21+xhrValue (XMLHttpRequest v _) = v
22+
23+toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef
24+toJSObject ctx args = do
25+ o <- jsobjectmake ctx nullPtr nullPtr
26+ iforM_ args $ \n a -> do
27+ prop <- jsstringcreatewithutf8cstring $ show n
28+ jsobjectsetproperty ctx o prop a 1 nullPtr
29+ return o
30+
31+toResponseType :: a -> a
32+toResponseType = id
33+
34+responseTextToText :: Maybe String -> Maybe Text
35+responseTextToText = fmap T.pack
36+
37+stringToJSValue :: JSContextRef -> String -> IO JSValueRef
38+stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s
39+
40+xmlHttpRequestNew :: WebView -> IO XMLHttpRequest
41+xmlHttpRequestNew wv = do
42+ --wv <- readIORef globalWebViewRef
43+ wf <- webViewGetMainFrame wv
44+ jsContext <- webFrameGetGlobalContext wf
45+ xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()"
46+ xhr' <- jsevaluatescript jsContext xhrScript nullPtr nullPtr 1 nullPtr
47+ jsvalueprotect jsContext xhr'
48+ return $ XMLHttpRequest xhr' jsContext
49+
50+xmlHttpRequestOpen :: XMLHttpRequest -> String -> String -> Bool -> String -> String -> IO ()
51+xmlHttpRequestOpen xhr method url async user password = do
52+ let c = xhrContext xhr
53+ method' <- stringToJSValue c method
54+ url' <- stringToJSValue c url
55+ async' <- jsvaluemakeboolean (xhrContext xhr) async
56+ user' <- stringToJSValue c user
57+ password' <- stringToJSValue c password
58+ o <- toJSObject c [xhrValue xhr, method', url', async', user', password']
59+ script <- jsstringcreatewithutf8cstring "this[0].open(this[1], this[2], this[3], this[4], this[5])"
60+ _ <- jsevaluatescript c script o nullPtr 1 nullPtr
61+ return ()
62+
63+foreign import ccall "wrapper"
64+ wrapper :: (Ptr OpaqueJSContext -> Ptr OpaqueJSValue -> Ptr OpaqueJSValue -> CULong -> Ptr JSValueRef -> Ptr JSValueRef -> IO (Ptr OpaqueJSValue)) -> IO (FunPtr (Ptr OpaqueJSContext -> Ptr OpaqueJSValue -> Ptr OpaqueJSValue -> CULong -> Ptr JSValueRef -> Ptr JSValueRef -> IO (Ptr OpaqueJSValue)))
65+
66+xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> IO () -> IO ()
67+xmlHttpRequestOnreadystatechange xhr userCallback = do
68+ let c = xhrContext xhr
69+ fp <- wrapper $ \_ _ _ _ _ _ -> do
70+ userCallback
71+ jsvaluemakeundefined c
72+ cb <- jsobjectmakefunctionwithcallback c nullPtr fp
73+ o <- toJSObject c [xhrValue xhr, cb]
74+ script <- jsstringcreatewithutf8cstring "this[0].onreadystatechange=this[1]"
75+ _ <- jsevaluatescript c script o nullPtr 1 nullPtr
76+ return ()
77+
78+xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word
79+xmlHttpRequestGetReadyState xhr = do
80+ let c = xhrContext xhr
81+ script <- jsstringcreatewithutf8cstring "this.readyState"
82+ rs <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
83+ d <- jsvaluetonumber c rs nullPtr
84+ return $ truncate d
85+
86+xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe String)
87+xmlHttpRequestGetResponseText xhr = do
88+ let c = xhrContext xhr
89+ script <- jsstringcreatewithutf8cstring "this.responseText"
90+ t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
91+ isNull <- jsvalueisnull c t
92+ case isNull of
93+ True -> return Nothing
94+ False -> do
95+ j <- jsvaluetostringcopy c t nullPtr
96+ l <- jsstringgetmaximumutf8cstringsize j
97+ s <- allocaBytes (fromIntegral l) $ \ps -> do
98+ _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
99+ peekCString ps
100+ return $ Just s
101+
102+xmlHttpRequestSend :: XMLHttpRequest -> Maybe String -> IO ()
103+xmlHttpRequestSend xhr payload = do
104+ let c = xhrContext xhr
105+ (o,s) <- case payload of
106+ Nothing -> do
107+ o <- toJSObject c [xhrValue xhr]
108+ s <- jsstringcreatewithutf8cstring "this[0].send();"
109+ return (o,s)
110+ Just payload' -> do
111+ d <- stringToJSValue c payload'
112+ o <- toJSObject c [xhrValue xhr, d]
113+ s <- jsstringcreatewithutf8cstring "this[0].send(this[1])"
114+ return (o,s)
115+ _ <- jsevaluatescript c s o nullPtr 1 nullPtr
116+ return ()
117+
118+xmlHttpRequestSetRequestHeader :: XMLHttpRequest -> String -> String -> IO ()
119+xmlHttpRequestSetRequestHeader xhr header value = do
120+ let c = xhrContext xhr
121+ header' <- stringToJSValue c header
122+ value' <- stringToJSValue c value
123+ o <- toJSObject c [xhrValue xhr, header', value']
124+ script <- jsstringcreatewithutf8cstring "this[0].setRequestHeader(this[1], this[2])"
125+ _ <- jsevaluatescript c script o nullPtr 1 nullPtr
126+ return ()
127+
128+xmlHttpRequestSetResponseType :: XMLHttpRequest -> String -> IO ()
129+xmlHttpRequestSetResponseType xhr t = do
130+ let c = xhrContext xhr
131+ t' <- stringToJSValue c t
132+ o <- toJSObject c [xhrValue xhr, t']
133+ script <- jsstringcreatewithutf8cstring "this[0].responseType = this[1]"
134+ _ <- jsevaluatescript c script o nullPtr 1 nullPtr
135+ return ()
136+
src-ghcjs/Reflex/Dom/Internal/Foreign.hsnew file+4
@@ -0,0 +1,4 @@
1+module Reflex.Dom.Internal.Foreign (runWebGUI) where
2+
3+import GHCJS.DOM
4+
src-ghcjs/Reflex/Dom/Xhr/Foreign.hsnew file+394
@@ -0,0 +1,394 @@
1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}
2+
3+module Reflex.Dom.Xhr.Foreign where
4+
5+import GHCJS.Types
6+import GHCJS.Foreign
7+import GHCJS.Marshal
8+import qualified Data.Text as T
9+import Data.Text (Text)
10+import GHCJS.DOM.Types hiding (Text)
11+import Control.Applicative ((<$>))
12+import GHCJS.DOM.EventM
13+import GHCJS.DOM
14+
15+prepareWebView :: WebView -> IO ()
16+prepareWebView _ = return ()
17+
18+foreign import javascript unsafe "h$isInstanceOf $1 $2"
19+ typeInstanceIsA' :: JSRef a -> JSRef GType -> Bool
20+
21+typeInstanceIsA :: JSRef a -> GType -> Bool
22+typeInstanceIsA o (GType t) = typeInstanceIsA' o t
23+
24+castTo :: (GObjectClass obj, GObjectClass obj') => GType -> String
25+ -> (obj -> obj')
26+castTo gtype objTypeName obj =
27+ case toGObject obj of
28+ gobj@(GObject objRef)
29+ | typeInstanceIsA objRef gtype
30+ -> unsafeCastGObject gobj
31+ | otherwise -> error $ "Cannot cast object to " ++ objTypeName
32+
33+
34+newtype XMLHttpRequest = XMLHttpRequest (JSRef XMLHttpRequest) deriving (Eq)
35+
36+unXMLHttpRequest :: XMLHttpRequest -> JSRef XMLHttpRequest
37+unXMLHttpRequest (XMLHttpRequest o) = o
38+
39+instance ToJSRef XMLHttpRequest where
40+ toJSRef = return . unXMLHttpRequest
41+ {-# INLINE toJSRef #-}
42+
43+instance FromJSRef XMLHttpRequest where
44+ fromJSRef = return . fmap XMLHttpRequest . maybeJSNull
45+ {-# INLINE fromJSRef #-}
46+
47+class GObjectClass o => IsXMLHttpRequest o
48+toXMLHttpRequest :: IsXMLHttpRequest o => o -> XMLHttpRequest
49+toXMLHttpRequest = unsafeCastGObject . toGObject
50+
51+instance IsXMLHttpRequest XMLHttpRequest
52+instance GObjectClass XMLHttpRequest where
53+ toGObject = GObject . castRef . unXMLHttpRequest
54+ unsafeCastGObject = XMLHttpRequest . castRef . unGObject
55+
56+castToXMLHttpRequest :: GObjectClass obj => obj -> XMLHttpRequest
57+castToXMLHttpRequest = castTo gTypeXMLHttpRequest "XMLHttpRequest"
58+
59+foreign import javascript unsafe "window[\"XMLHttpRequest\"]" gTypeXMLHttpRequest' :: JSRef GType
60+gTypeXMLHttpRequest :: GType
61+gTypeXMLHttpRequest = GType gTypeXMLHttpRequest'
62+
63+
64+newtype XMLHttpRequestUpload = XMLHttpRequestUpload (JSRef XMLHttpRequestUpload) deriving (Eq)
65+
66+unXMLHttpRequestUpload :: XMLHttpRequestUpload -> JSRef XMLHttpRequestUpload
67+unXMLHttpRequestUpload (XMLHttpRequestUpload o) = o
68+
69+instance ToJSRef XMLHttpRequestUpload where
70+ toJSRef = return . unXMLHttpRequestUpload
71+ {-# INLINE toJSRef #-}
72+
73+instance FromJSRef XMLHttpRequestUpload where
74+ fromJSRef = return . fmap XMLHttpRequestUpload . maybeJSNull
75+ {-# INLINE fromJSRef #-}
76+
77+class GObjectClass o => IsXMLHttpRequestUpload o
78+toXMLHttpRequestUpload :: IsXMLHttpRequestUpload o => o -> XMLHttpRequestUpload
79+toXMLHttpRequestUpload = unsafeCastGObject . toGObject
80+
81+instance IsXMLHttpRequestUpload XMLHttpRequestUpload
82+instance GObjectClass XMLHttpRequestUpload where
83+ toGObject = GObject . castRef . unXMLHttpRequestUpload
84+ unsafeCastGObject = XMLHttpRequestUpload . castRef . unGObject
85+
86+castToXMLHttpRequestUpload :: GObjectClass obj => obj -> XMLHttpRequestUpload
87+castToXMLHttpRequestUpload = castTo gTypeXMLHttpRequestUpload "XMLHttpRequestUpload"
88+
89+foreign import javascript unsafe "window[\"XMLHttpRequestUpload\"]" gTypeXMLHttpRequestUpload' :: JSRef GType
90+gTypeXMLHttpRequestUpload :: GType
91+gTypeXMLHttpRequestUpload = GType gTypeXMLHttpRequestUpload'
92+
93+foreign import javascript unsafe "new XMLHttpRequest()"
94+ ghcjs_dom_xml_http_request_new ::
95+ IO (JSRef XMLHttpRequest)
96+
97+xmlHttpRequestNew :: a -> IO XMLHttpRequest
98+xmlHttpRequestNew _ = XMLHttpRequest <$> ghcjs_dom_xml_http_request_new
99+
100+foreign import javascript unsafe "$1[\"open\"]($2, $3, $4, $5, $6)"
101+ ghcjs_dom_xml_http_request_open ::
102+ JSRef XMLHttpRequest -> JSString -> JSString -> JSBool -> JSString -> JSString -> IO ()
103+
104+xmlHttpRequestOpen ::
105+ (IsXMLHttpRequest self, ToJSString method, ToJSString url, ToJSString user, ToJSString password) =>
106+ self -> method -> url -> Bool -> user -> password -> IO ()
107+xmlHttpRequestOpen self method url async user password
108+ = ghcjs_dom_xml_http_request_open
109+ (unXMLHttpRequest (toXMLHttpRequest self))
110+ (toJSString method)
111+ (toJSString url)
112+ (toJSBool async)
113+ (toJSString user)
114+ (toJSString password)
115+
116+foreign import javascript unsafe "($2===null)?$1[\"send\"]():$1[\"send\"]($2)"
117+ ghcjs_dom_xml_http_request_send ::
118+ JSRef XMLHttpRequest -> JSString -> IO ()
119+
120+xmlHttpRequestSend ::
121+ (IsXMLHttpRequest self, ToJSString payload) =>
122+ self -> Maybe payload -> IO ()
123+xmlHttpRequestSend self payload
124+ = ghcjs_dom_xml_http_request_send
125+ (unXMLHttpRequest (toXMLHttpRequest self))
126+ (case payload of
127+ Just p -> toJSString p
128+ Nothing -> jsNull)
129+
130+
131+foreign import javascript unsafe "$1[\"setRequestHeader\"]($2, $3)"
132+ ghcjs_dom_xml_http_request_set_request_header ::
133+ JSRef XMLHttpRequest -> JSString -> JSString -> IO ()
134+
135+xmlHttpRequestSetRequestHeader ::
136+ (IsXMLHttpRequest self, ToJSString header, ToJSString value) =>
137+ self -> header -> value -> IO ()
138+xmlHttpRequestSetRequestHeader self header value
139+ = ghcjs_dom_xml_http_request_set_request_header
140+ (unXMLHttpRequest (toXMLHttpRequest self))
141+ (toJSString header)
142+ (toJSString value)
143+
144+foreign import javascript unsafe "$1[\"abort\"]()"
145+ ghcjs_dom_xml_http_request_abort :: JSRef XMLHttpRequest -> IO ()
146+
147+xmlHttpRequestAbort :: (IsXMLHttpRequest self) => self -> IO ()
148+xmlHttpRequestAbort self
149+ = ghcjs_dom_xml_http_request_abort
150+ (unXMLHttpRequest (toXMLHttpRequest self))
151+
152+foreign import javascript unsafe "$1[\"getAllResponseHeaders\"]()"
153+ ghcjs_dom_xml_http_request_get_all_response_headers ::
154+ JSRef XMLHttpRequest -> IO JSString
155+
156+xmlHttpRequestGetAllResponseHeaders ::
157+ (IsXMLHttpRequest self, FromJSString result) =>
158+ self -> IO result
159+xmlHttpRequestGetAllResponseHeaders self
160+ = fromJSString <$>
161+ (ghcjs_dom_xml_http_request_get_all_response_headers
162+ (unXMLHttpRequest (toXMLHttpRequest self)))
163+
164+foreign import javascript unsafe "$1[\"getResponseHeader\"]($2)"
165+ ghcjs_dom_xml_http_request_get_response_header ::
166+ JSRef XMLHttpRequest -> JSString -> IO JSString
167+
168+xmlHttpRequestGetResponseHeader ::
169+ (IsXMLHttpRequest self, ToJSString header, FromJSString result) =>
170+ self -> header -> IO result
171+xmlHttpRequestGetResponseHeader self header
172+ = fromJSString <$>
173+ (ghcjs_dom_xml_http_request_get_response_header
174+ (unXMLHttpRequest (toXMLHttpRequest self))
175+ (toJSString header))
176+
177+foreign import javascript unsafe "$1[\"overrideMimeType\"]($2)"
178+ ghcjs_dom_xml_http_request_override_mime_type ::
179+ JSRef XMLHttpRequest -> JSString -> IO ()
180+
181+xmlHttpRequestOverrideMimeType ::
182+ (IsXMLHttpRequest self, ToJSString override) =>
183+ self -> override -> IO ()
184+xmlHttpRequestOverrideMimeType self override
185+ = ghcjs_dom_xml_http_request_override_mime_type
186+ (unXMLHttpRequest (toXMLHttpRequest self))
187+ (toJSString override)
188+
189+foreign import javascript unsafe
190+ "($1[\"dispatchEvent\"]($2) ? 1 : 0)"
191+ ghcjs_dom_xml_http_request_dispatch_event ::
192+ JSRef XMLHttpRequest -> JSRef Event -> IO Bool
193+
194+xmlHttpRequestDispatchEvent ::
195+ (IsXMLHttpRequest self, IsEvent evt) =>
196+ self -> Maybe evt -> IO Bool
197+xmlHttpRequestDispatchEvent self evt
198+ = ghcjs_dom_xml_http_request_dispatch_event
199+ (unXMLHttpRequest (toXMLHttpRequest self))
200+ (maybe jsNull (unEvent . toEvent) evt)
201+
202+cUNSENT :: Integer
203+cUNSENT = 0
204+
205+cOPENED :: Integer
206+cOPENED = 1
207+
208+cHEADERS_RECEIVED :: Integer
209+cHEADERS_RECEIVED = 2
210+
211+cLOADING :: Integer
212+cLOADING = 3
213+
214+cDONE :: Integer
215+cDONE = 4
216+
217+xmlHttpRequestOnabort ::
218+ (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
219+xmlHttpRequestOnabort = (connect "abort")
220+
221+xmlHttpRequestOnerror ::
222+ (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
223+xmlHttpRequestOnerror = (connect "error")
224+
225+xmlHttpRequestOnload ::
226+ (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
227+xmlHttpRequestOnload = (connect "load")
228+
229+xmlHttpRequestOnloadend ::
230+ (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
231+xmlHttpRequestOnloadend = (connect "loadend")
232+
233+xmlHttpRequestOnloadstart ::
234+ (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
235+xmlHttpRequestOnloadstart = (connect "loadstart")
236+
237+xmlHttpRequestOnprogress ::
238+ (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
239+xmlHttpRequestOnprogress = (connect "progress")
240+
241+xmlHttpRequestOntimeout ::
242+ (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
243+xmlHttpRequestOntimeout = (connect "timeout")
244+
245+xmlHttpRequestOnreadystatechange ::
246+ (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
247+xmlHttpRequestOnreadystatechange = (connect "readystatechange")
248+
249+foreign import javascript unsafe "$1[\"timeout\"] = $2;"
250+ ghcjs_dom_xml_http_request_set_timeout ::
251+ JSRef XMLHttpRequest -> Word -> IO ()
252+
253+xmlHttpRequestSetTimeout ::
254+ (IsXMLHttpRequest self) => self -> Word -> IO ()
255+xmlHttpRequestSetTimeout self val
256+ = ghcjs_dom_xml_http_request_set_timeout
257+ (unXMLHttpRequest (toXMLHttpRequest self))
258+ val
259+
260+foreign import javascript unsafe "$1[\"timeout\"]"
261+ ghcjs_dom_xml_http_request_get_timeout ::
262+ JSRef XMLHttpRequest -> IO Word
263+
264+xmlHttpRequestGetTimeout ::
265+ (IsXMLHttpRequest self) => self -> IO Word
266+xmlHttpRequestGetTimeout self
267+ = ghcjs_dom_xml_http_request_get_timeout
268+ (unXMLHttpRequest (toXMLHttpRequest self))
269+
270+foreign import javascript unsafe "$1[\"readyState\"]"
271+ ghcjs_dom_xml_http_request_get_ready_state ::
272+ JSRef XMLHttpRequest -> IO Word
273+
274+xmlHttpRequestGetReadyState ::
275+ (IsXMLHttpRequest self) => self -> IO Word
276+xmlHttpRequestGetReadyState self
277+ = ghcjs_dom_xml_http_request_get_ready_state
278+ (unXMLHttpRequest (toXMLHttpRequest self))
279+
280+foreign import javascript unsafe "$1[\"withCredentials\"] = $2;"
281+ ghcjs_dom_xml_http_request_set_with_credentials ::
282+ JSRef XMLHttpRequest -> Bool -> IO ()
283+
284+xmlHttpRequestSetWithCredentials ::
285+ (IsXMLHttpRequest self) => self -> Bool -> IO ()
286+xmlHttpRequestSetWithCredentials self val
287+ = ghcjs_dom_xml_http_request_set_with_credentials
288+ (unXMLHttpRequest (toXMLHttpRequest self))
289+ val
290+
291+foreign import javascript unsafe
292+ "($1[\"withCredentials\"] ? 1 : 0)"
293+ ghcjs_dom_xml_http_request_get_with_credentials ::
294+ JSRef XMLHttpRequest -> IO Bool
295+
296+xmlHttpRequestGetWithCredentials ::
297+ (IsXMLHttpRequest self) => self -> IO Bool
298+xmlHttpRequestGetWithCredentials self
299+ = ghcjs_dom_xml_http_request_get_with_credentials
300+ (unXMLHttpRequest (toXMLHttpRequest self))
301+
302+foreign import javascript unsafe "$1[\"upload\"]"
303+ ghcjs_dom_xml_http_request_get_upload ::
304+ JSRef XMLHttpRequest -> IO (JSRef XMLHttpRequestUpload)
305+
306+xmlHttpRequestGetUpload ::
307+ (IsXMLHttpRequest self) => self -> IO (Maybe XMLHttpRequestUpload)
308+xmlHttpRequestGetUpload self
309+ = fmap XMLHttpRequestUpload . maybeJSNull <$>
310+ (ghcjs_dom_xml_http_request_get_upload
311+ (unXMLHttpRequest (toXMLHttpRequest self)))
312+
313+foreign import javascript unsafe "$1[\"responseText\"]"
314+ ghcjs_dom_xml_http_request_get_response_text ::
315+ JSRef XMLHttpRequest -> IO JSString
316+
317+xmlHttpRequestGetResponseText ::
318+ (IsXMLHttpRequest self, FromJSString result) => self -> IO (Maybe result)
319+xmlHttpRequestGetResponseText self
320+ = fmap fromJSString . maybeJSNull <$>
321+ (ghcjs_dom_xml_http_request_get_response_text
322+ (unXMLHttpRequest (toXMLHttpRequest self)))
323+
324+responseTextToText :: (Maybe JSString) -> Maybe Text
325+responseTextToText r = fmap (T.pack . fromJSString) r
326+
327+foreign import javascript unsafe "$1[\"responseXML\"]"
328+ ghcjs_dom_xml_http_request_get_response_xml ::
329+ JSRef XMLHttpRequest -> IO (JSRef Document)
330+
331+xmlHttpRequestGetResponseXML ::
332+ (IsXMLHttpRequest self) => self -> IO (Maybe Document)
333+xmlHttpRequestGetResponseXML self
334+ = fmap Document . maybeJSNull <$>
335+ (ghcjs_dom_xml_http_request_get_response_xml
336+ (unXMLHttpRequest (toXMLHttpRequest self)))
337+
338+foreign import javascript unsafe "$1[\"responseType\"] = $2;"
339+ ghcjs_dom_xml_http_request_set_response_type ::
340+ JSRef XMLHttpRequest -> JSString -> IO ()
341+
342+xmlHttpRequestSetResponseType ::
343+ (IsXMLHttpRequest self, ToJSString val) => self -> val -> IO ()
344+xmlHttpRequestSetResponseType self val
345+ = ghcjs_dom_xml_http_request_set_response_type
346+ (unXMLHttpRequest (toXMLHttpRequest self))
347+ (toJSString val)
348+
349+toResponseType :: (ToJSString a) => a -> JSString
350+toResponseType = toJSString
351+
352+foreign import javascript unsafe "$1[\"responseType\"]"
353+ ghcjs_dom_xml_http_request_get_response_type ::
354+ JSRef XMLHttpRequest -> IO JSString
355+
356+xmlHttpRequestGetResponseType ::
357+ (IsXMLHttpRequest self, FromJSString result) => self -> IO result
358+xmlHttpRequestGetResponseType self
359+ = fromJSString <$>
360+ (ghcjs_dom_xml_http_request_get_response_type
361+ (unXMLHttpRequest (toXMLHttpRequest self)))
362+
363+foreign import javascript unsafe "$1[\"status\"]"
364+ ghcjs_dom_xml_http_request_get_status ::
365+ JSRef XMLHttpRequest -> IO Word
366+
367+xmlHttpRequestGetStatus ::
368+ (IsXMLHttpRequest self) => self -> IO Word
369+xmlHttpRequestGetStatus self
370+ = ghcjs_dom_xml_http_request_get_status
371+ (unXMLHttpRequest (toXMLHttpRequest self))
372+
373+foreign import javascript unsafe "$1[\"statusText\"]"
374+ ghcjs_dom_xml_http_request_get_status_text ::
375+ JSRef XMLHttpRequest -> IO JSString
376+
377+xmlHttpRequestGetStatusText ::
378+ (IsXMLHttpRequest self, FromJSString result) => self -> IO result
379+xmlHttpRequestGetStatusText self
380+ = fromJSString <$>
381+ (ghcjs_dom_xml_http_request_get_status_text
382+ (unXMLHttpRequest (toXMLHttpRequest self)))
383+
384+foreign import javascript unsafe "$1[\"responseURL\"]"
385+ ghcjs_dom_xml_http_request_get_response_url ::
386+ JSRef XMLHttpRequest -> IO JSString
387+
388+xmlHttpRequestGetResponseURL ::
389+ (IsXMLHttpRequest self, FromJSString result) => self -> IO result
390+xmlHttpRequestGetResponseURL self
391+ = fromJSString <$>
392+ (ghcjs_dom_xml_http_request_get_response_url
393+ (unXMLHttpRequest (toXMLHttpRequest self)))
394+
src/Reflex/Dom/Class.hs+11−1
@@ -15,6 +15,7 @@ import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence)
15import Control.Monad.State hiding (mapM, mapM_, forM, forM_, sequence)
15import Control.Monad.State hiding (mapM, mapM_, forM, forM_, sequence)
16import Data.Dependent.Sum (DSum (..))
16import Data.Dependent.Sum (DSum (..))
17import GHCJS.DOM.Types hiding (Event)
17import GHCJS.DOM.Types hiding (Event)
18+import GHCJS.DOM (WebView)
18
19
19-- | Alias for Data.Map.singleton
20-- | Alias for Data.Map.singleton
20(=:) :: k -> a -> Map k a
21(=:) :: k -> a -> Map k a
@@ -27,7 +28,7 @@ keycodeEscape :: Int
27keycodeEscape = 27
28keycodeEscape = 27
28
29
29class ( Reflex t, MonadHold t m, MonadIO m, Functor m, MonadReflexCreateTrigger t m
30class ( Reflex t, MonadHold t m, MonadIO m, Functor m, MonadReflexCreateTrigger t m
30− , HasDocument m
31+ , HasDocument m, HasWebView m, HasWebView (WidgetHost m)
31 , MonadIO (WidgetHost m), MonadIO (GuiAction m), Functor (WidgetHost m), MonadSample t (WidgetHost m)
32 , MonadIO (WidgetHost m), MonadIO (GuiAction m), Functor (WidgetHost m), MonadSample t (WidgetHost m)
32 , HasPostGui t (GuiAction m) (WidgetHost m), HasPostGui t (GuiAction m) m, MonadRef m, MonadRef (WidgetHost m)
33 , HasPostGui t (GuiAction m) (WidgetHost m), HasPostGui t (GuiAction m) m, MonadRef m, MonadRef (WidgetHost m)
33 , Ref m ~ Ref IO, Ref (WidgetHost m) ~ Ref IO --TODO: Eliminate this reliance on IO
34 , Ref m ~ Ref IO, Ref (WidgetHost m) ~ Ref IO --TODO: Eliminate this reliance on IO
@@ -52,6 +53,15 @@ instance HasDocument m => HasDocument (ReaderT r m) where
52instance HasDocument m => HasDocument (StateT r m) where
53instance HasDocument m => HasDocument (StateT r m) where
53 askDocument = lift askDocument
54 askDocument = lift askDocument
54
55
56+class Monad m => HasWebView m where
57+ askWebView :: m WebView
58+
59+instance HasWebView m => HasWebView (ReaderT r m) where
60+ askWebView = lift askWebView
61+
62+instance HasWebView m => HasWebView (StateT r m) where
63+ askWebView = lift askWebView
64+
55class (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h m | m -> t h where
65class (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h m | m -> t h where
56 askPostGui :: m (h () -> IO ())
66 askPostGui :: m (h () -> IO ())
57 askRunWithActions :: m ([DSum (EventTrigger t)] -> h ())
67 askRunWithActions :: m ([DSum (EventTrigger t)] -> h ())
src/Reflex/Dom/Internal.hs+19−10
@@ -1,11 +1,12 @@
1−{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, ConstraintKinds #-}
1+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, ConstraintKinds, CPP #-}
2module Reflex.Dom.Internal where
2module Reflex.Dom.Internal where
3
3
4import Prelude hiding (mapM, mapM_, concat, sequence, sequence_)
4import Prelude hiding (mapM, mapM_, concat, sequence, sequence_)
5
5
6+import Reflex.Dom.Internal.Foreign
6import Reflex.Dom.Class
7import Reflex.Dom.Class
7
8
8−import GHCJS.DOM
9+import GHCJS.DOM hiding (runWebGUI)
9import GHCJS.DOM.Types hiding (Widget, unWidget, Event)
10import GHCJS.DOM.Types hiding (Widget, unWidget, Event)
10import GHCJS.DOM.Node
11import GHCJS.DOM.Node
11import GHCJS.DOM.HTMLElement
12import GHCJS.DOM.HTMLElement
@@ -17,7 +18,7 @@ import Control.Lens
17import Control.Monad hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
18import Control.Monad hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
18import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
19import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
19import Control.Monad.Ref
20import Control.Monad.Ref
20−import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
21+import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get)
21import Control.Concurrent
22import Control.Concurrent
22import Data.ByteString (ByteString)
23import Data.ByteString (ByteString)
23import Data.Dependent.Sum (DSum (..))
24import Data.Dependent.Sum (DSum (..))
@@ -26,11 +27,13 @@ import Data.Traversable
26import qualified Data.Text as T
27import qualified Data.Text as T
27import Data.Text.Encoding
28import Data.Text.Encoding
28import Data.Monoid ((<>))
29import Data.Monoid ((<>))
30+import Reflex.Dom.Xhr.Foreign
29
31
30data GuiEnv t h
32data GuiEnv t h
31 = GuiEnv { _guiEnvDocument :: !HTMLDocument
33 = GuiEnv { _guiEnvDocument :: !HTMLDocument
32 , _guiEnvPostGui :: !(h () -> IO ())
34 , _guiEnvPostGui :: !(h () -> IO ())
33 , _guiEnvRunWithActions :: !([DSum (EventTrigger t)] -> h ())
35 , _guiEnvRunWithActions :: !([DSum (EventTrigger t)] -> h ())
36+ , _guiEnvWebView :: !WebView
34 }
37 }
35
38
36--TODO: Poorly named
39--TODO: Poorly named
@@ -79,6 +82,12 @@ instance Monad m => HasDocument (Gui t h m) where
79instance HasDocument m => HasDocument (Widget t m) where
82instance HasDocument m => HasDocument (Widget t m) where
80 askDocument = lift askDocument
83 askDocument = lift askDocument
81
84
85+instance Monad m => HasWebView (Gui t h m) where
86+ askWebView = Gui $ view guiEnvWebView
87+
88+instance HasWebView m => HasWebView (Widget t m) where
89+ askWebView = lift askWebView
90+
82instance (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h (Gui t h m) where
91instance (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h (Gui t h m) where
83 askPostGui = Gui $ view guiEnvPostGui
92 askPostGui = Gui $ view guiEnvPostGui
84 askRunWithActions = Gui $ view guiEnvRunWithActions
93 askRunWithActions = Gui $ view guiEnvRunWithActions
@@ -159,15 +168,15 @@ mainWidget :: Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> IO
159mainWidget w = runWebGUI $ \webView -> do
168mainWidget w = runWebGUI $ \webView -> do
160 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
169 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
161 Just body <- documentGetBody doc
170 Just body <- documentGetBody doc
162− attachWidget body w
171+ attachWidget body w webView
163
172
164mainWidgetWithHead :: Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> IO ()
173mainWidgetWithHead :: Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> IO ()
165mainWidgetWithHead h b = runWebGUI $ \webView -> do
174mainWidgetWithHead h b = runWebGUI $ \webView -> do
166 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
175 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
167 Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc
176 Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc
168− attachWidget headElement h
177+ attachWidget headElement h webView
169 Just body <- documentGetBody doc
178 Just body <- documentGetBody doc
170− attachWidget body b
179+ attachWidget body b webView
171
180
172mainWidgetWithCss :: ByteString -> Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> IO ()
181mainWidgetWithCss :: ByteString -> Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> IO ()
173mainWidgetWithCss css w = runWebGUI $ \webView -> do
182mainWidgetWithCss css w = runWebGUI $ \webView -> do
@@ -175,13 +184,13 @@ mainWidgetWithCss css w = runWebGUI $ \webView -> do
175 Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc
184 Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc
176 htmlElementSetInnerHTML headElement $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
185 htmlElementSetInnerHTML headElement $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
177 Just body <- documentGetBody doc
186 Just body <- documentGetBody doc
178− attachWidget body w
187+ attachWidget body w webView
179
188
180−attachWidget :: (IsHTMLElement e) => e -> Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) a -> IO a
189+attachWidget :: (IsHTMLElement e) => e -> Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) a -> WebView -> IO a
181−attachWidget rootElement w = runSpiderHost $ do --TODO: It seems to re-run this handler if the URL changes, even if it's only the fragment
190+attachWidget rootElement w wv = runSpiderHost $ do --TODO: It seems to re-run this handler if the URL changes, even if it's only the fragment
182 Just doc <- liftM (fmap castToHTMLDocument) $ liftIO $ nodeGetOwnerDocument rootElement
191 Just doc <- liftM (fmap castToHTMLDocument) $ liftIO $ nodeGetOwnerDocument rootElement
183 frames <- liftIO newChan
192 frames <- liftIO newChan
184− rec let guiEnv = GuiEnv doc (writeChan frames . runSpiderHost) runWithActions :: GuiEnv Spider SpiderHost
193+ rec let guiEnv = GuiEnv doc (writeChan frames . runSpiderHost) runWithActions wv :: GuiEnv Spider SpiderHost
185 runWithActions dm = do
194 runWithActions dm = do
186 voidActionNeeded <- fireEventsAndRead dm $ do
195 voidActionNeeded <- fireEventsAndRead dm $ do
187 sequence =<< readEvent voidActionHandle
196 sequence =<< readEvent voidActionHandle
src/Reflex/Dom/Widget/Basic.hs+3
@@ -428,6 +428,9 @@ elClass elementTag c child = elAttr elementTag ("class" =: c) child
428list :: (MonadWidget t m, Ord k) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
428list :: (MonadWidget t m, Ord k) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
429list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
429list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
430
430
431+simpleList :: MonadWidget t m => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
432+simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<< mapDyn (Map.fromList . zip [(1::Int)..]) xs
433+
431elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
434elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
432elDynHtml' elementTag html = do
435elDynHtml' elementTag html = do
433 e <- buildEmptyElement elementTag (Map.empty :: Map String String)
436 e <- buildEmptyElement elementTag (Map.empty :: Map String String)
src/Reflex/Dom/Xhr.hs+38−45
@@ -1,7 +1,4 @@
1−{-# LANGUAGE CPP #-}
2module Reflex.Dom.Xhr where
1module Reflex.Dom.Xhr where
3−
4−#ifdef __GHCJS__
5import Control.Concurrent
2import Control.Concurrent
6import Control.Lens
3import Control.Lens
7import Control.Monad
4import Control.Monad
@@ -14,11 +11,9 @@ import qualified Data.Map as Map
14import Data.Maybe
11import Data.Maybe
15import Data.Text (Text)
12import Data.Text (Text)
16import Data.Text.Encoding
13import Data.Text.Encoding
17−import GHCJS.Foreign
18−import GHCJS.Types
19−import GHCJS.DOM.XMLHttpRequest
20import Reflex
14import Reflex
21import Reflex.Dom.Class
15import Reflex.Dom.Class
16+import Reflex.Dom.Xhr.Foreign
22
17
23data XhrRequest
18data XhrRequest
24 = XhrRequest { _xhrRequest_method :: String
19 = XhrRequest { _xhrRequest_method :: String
@@ -35,7 +30,7 @@ data XhrRequestConfig
35 }
30 }
36
31
37data XhrResponse
32data XhrResponse
38− = XhrResponse { _xhrResponse_body :: Maybe JSString
33+ = XhrResponse { _xhrResponse_body :: Maybe Text
39 }
34 }
40
35
41instance Default XhrRequestConfig where
36instance Default XhrRequestConfig where
@@ -49,44 +44,46 @@ instance Default XhrRequestConfig where
49xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest
44xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest
50xhrRequest = XhrRequest
45xhrRequest = XhrRequest
51
46
52−newXMLHttpRequest :: XhrRequest -> (XhrResponse -> IO a) -> IO XMLHttpRequest
47+newXMLHttpRequest :: (HasWebView m, MonadIO m) => XhrRequest -> (XhrResponse -> IO a) -> m XMLHttpRequest
53newXMLHttpRequest req cb = do
48newXMLHttpRequest req cb = do
49+ wv <- askWebView
50+ liftIO $ do
54− xhr <- xmlHttpRequestNew
51+ xhr <- xmlHttpRequestNew wv
55− let c = _xhrRequest_config req
52+ let c = _xhrRequest_config req
56− xmlHttpRequestOpen
53+ xmlHttpRequestOpen
57− xhr
54+ xhr
58− (_xhrRequest_method req)
55+ (_xhrRequest_method req)
59− (_xhrRequest_url req)
56+ (_xhrRequest_url req)
60− True
57+ True
61− (fromMaybe "" $ _xhrRequestConfig_user c)
58+ (fromMaybe "" $ _xhrRequestConfig_user c)
62− (fromMaybe "" $ _xhrRequestConfig_password c)
59+ (fromMaybe "" $ _xhrRequestConfig_password c)
63− iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr
60+ iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr
64− maybe (return ()) (xmlHttpRequestSetResponseType xhr . toJSString) (_xhrRequestConfig_responseType c)
61+ maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) (_xhrRequestConfig_responseType c)
65− _ <- xmlHttpRequestOnreadystatechange xhr $ do
62+ _ <- xmlHttpRequestOnreadystatechange xhr $ do
66− readyState <- liftIO $ xmlHttpRequestGetReadyState xhr
63+ readyState <- liftIO $ xmlHttpRequestGetReadyState xhr
67− if readyState == 4
64+ if readyState == 4
68− then do
65+ then do
69− r <- liftIO $ xmlHttpRequestGetResponseText xhr
66+ r <- liftIO $ xmlHttpRequestGetResponseText xhr
70− _ <- liftIO $ cb $ XhrResponse r
67+ _ <- liftIO $ cb $ XhrResponse $ responseTextToText r
71− return ()
68+ return ()
72− else return ()
69+ else return ()
73− _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
70+ _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
74− return xhr
71+ return xhr
75
72
76−performRequestAsync :: MonadWidget t m => Event t XhrRequest -> m (Event t XhrResponse)
73+performRequestAsync :: (MonadWidget t m) => Event t XhrRequest -> m (Event t XhrResponse)
77performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do
74performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do
78− _ <- liftIO $ newXMLHttpRequest r cb
75+ _ <- newXMLHttpRequest r cb
79 return ()
76 return ()
80
77
81−performRequestsAsync :: (Traversable f, MonadWidget t m) => Event t (f XhrRequest) -> m (Event t (f XhrResponse))
78+--performRequestsAsync :: (Traversable f, MonadWidget t m) => Event t (f XhrRequest) -> m (Event t (f XhrResponse))
82−performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
79+--performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
83− _ <- liftIO $ do
80+-- _ <- liftIO $ do
84− resps <- forM rs $ \r -> do
81+-- resps <- forM rs $ \r -> do
85− resp <- newEmptyMVar
82+-- resp <- newEmptyMVar
86− _ <- newXMLHttpRequest r $ putMVar resp
83+-- _ <- newXMLHttpRequest r $ putMVar resp
87− return resp
84+-- return resp
88− forkIO $ cb =<< forM resps takeMVar
85+-- forkIO $ cb =<< forM resps takeMVar
89− return ()
86+-- return ()
90
87
91getAndDecode :: (FromJSON a, MonadWidget t m) => Event t String -> m (Event t (Maybe a))
88getAndDecode :: (FromJSON a, MonadWidget t m) => Event t String -> m (Event t (Maybe a))
92getAndDecode url = do
89getAndDecode url = do
@@ -101,10 +98,6 @@ getMay f e = do
101decodeText :: FromJSON a => Text -> Maybe a
98decodeText :: FromJSON a => Text -> Maybe a
102decodeText = decode . BL.fromStrict . encodeUtf8
99decodeText = decode . BL.fromStrict . encodeUtf8
103
100
104−decodeJSString :: FromJSON a => JSString -> Maybe a
105−decodeJSString = decodeText . fromJSString
106−
107decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
101decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
108−decodeXhrResponse = join . fmap decodeJSString . _xhrResponse_body
102+decodeXhrResponse = join . fmap decodeText . _xhrResponse_body
109
103
110−#endif