git.iko.soy/reflex-dom
on develop help sign in
Make Xhr work in webkit
commit82dcb9478a271c75056db2cb0b2735a7da4e205b authorAli Abrar <aliabrar@gmail.com> dateWed 25 Mar 2015, 15:59 (12 years ago) parent517b1e0
10 files changed+680−60
compare with develop
unifiedsplit
default.nix+5−2 reflex-dom.cabal+14−2 src-ghc/Reflex/Dom/Internal/Foreign.hs+56 src-ghc/Reflex/Dom/Xhr/Foreign.hs+136 src-ghcjs/Reflex/Dom/Internal/Foreign.hs+4 src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+394 src/Reflex/Dom/Class.hs+11−1 src/Reflex/Dom/Internal.hs+19−10 src/Reflex/Dom/Widget/Basic.hs+3 src/Reflex/Dom/Xhr.hs+38−45
default.nix+5−2
@@ -1,6 +1,7 @@
11{ mkDerivation, dependent-map, ghcjs-dom, lens
22, mtl, reflex, safe, text, these
3−, transformers, data-default, semigroups
3+, transformers, data-default, semigroups, aeson
4+, c2hs, ghc, webkit-javascriptcore
45}:
56
67mkDerivation {
@@ -19,6 +20,8 @@ mkDerivation {
1920 text
2021 data-default
2122 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 ];
2326 license = null;
2427}
reflex-dom.cabal+14−2
@@ -28,13 +28,22 @@ library
2828 text,
2929 bytestring,
3030 data-default,
31− semigroups
31+ semigroups,
32+ aeson
3233
3334 if impl(ghcjs)
35+ hs-source-dirs: src-ghcjs
3436 cpp-options: -D__GHCJS__
3537 build-depends:
36− aeson,
3738 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
3847
3948 exposed-modules:
4049 Reflex.Dom
@@ -44,6 +53,9 @@ library
4453 Reflex.Dom.Widget.Basic
4554 Reflex.Dom.Widget.Input
4655 Reflex.Dom.Xhr
56+ other-modules:
57+ Reflex.Dom.Internal.Foreign
58+ Reflex.Dom.Xhr.Foreign
4759
4860 other-extensions: TemplateHaskell
4961 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)
1515import Control.Monad.State hiding (mapM, mapM_, forM, forM_, sequence)
1616import Data.Dependent.Sum (DSum (..))
1717import GHCJS.DOM.Types hiding (Event)
18+import GHCJS.DOM (WebView)
1819
1920-- | Alias for Data.Map.singleton
2021(=:) :: k -> a -> Map k a
@@ -27,7 +28,7 @@ keycodeEscape :: Int
2728keycodeEscape = 27
2829
2930class ( Reflex t, MonadHold t m, MonadIO m, Functor m, MonadReflexCreateTrigger t m
30− , HasDocument m
31+ , HasDocument m, HasWebView m, HasWebView (WidgetHost m)
3132 , MonadIO (WidgetHost m), MonadIO (GuiAction m), Functor (WidgetHost m), MonadSample t (WidgetHost m)
3233 , HasPostGui t (GuiAction m) (WidgetHost m), HasPostGui t (GuiAction m) m, MonadRef m, MonadRef (WidgetHost m)
3334 , 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
5253instance HasDocument m => HasDocument (StateT r m) where
5354 askDocument = lift askDocument
5455
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+
5565class (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h m | m -> t h where
5666 askPostGui :: m (h () -> IO ())
5767 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 #-}
22module Reflex.Dom.Internal where
33
44import Prelude hiding (mapM, mapM_, concat, sequence, sequence_)
55
6+import Reflex.Dom.Internal.Foreign
67import Reflex.Dom.Class
78
8−import GHCJS.DOM
9+import GHCJS.DOM hiding (runWebGUI)
910import GHCJS.DOM.Types hiding (Widget, unWidget, Event)
1011import GHCJS.DOM.Node
1112import GHCJS.DOM.HTMLElement
@@ -17,7 +18,7 @@ import Control.Lens
1718import Control.Monad hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
1819import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
1920import 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)
2122import Control.Concurrent
2223import Data.ByteString (ByteString)
2324import Data.Dependent.Sum (DSum (..))
@@ -26,11 +27,13 @@ import Data.Traversable
2627import qualified Data.Text as T
2728import Data.Text.Encoding
2829import Data.Monoid ((<>))
30+import Reflex.Dom.Xhr.Foreign
2931
3032data GuiEnv t h
3133 = GuiEnv { _guiEnvDocument :: !HTMLDocument
3234 , _guiEnvPostGui :: !(h () -> IO ())
3335 , _guiEnvRunWithActions :: !([DSum (EventTrigger t)] -> h ())
36+ , _guiEnvWebView :: !WebView
3437 }
3538
3639--TODO: Poorly named
@@ -79,6 +82,12 @@ instance Monad m => HasDocument (Gui t h m) where
7982instance HasDocument m => HasDocument (Widget t m) where
8083 askDocument = lift askDocument
8184
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+
8291instance (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h (Gui t h m) where
8392 askPostGui = Gui $ view guiEnvPostGui
8493 askRunWithActions = Gui $ view guiEnvRunWithActions
@@ -159,15 +168,15 @@ mainWidget :: Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> IO
159168mainWidget w = runWebGUI $ \webView -> do
160169 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
161170 Just body <- documentGetBody doc
162− attachWidget body w
171+ attachWidget body w webView
163172
164173mainWidgetWithHead :: Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> IO ()
165174mainWidgetWithHead h b = runWebGUI $ \webView -> do
166175 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
167176 Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc
168− attachWidget headElement h
177+ attachWidget headElement h webView
169178 Just body <- documentGetBody doc
170− attachWidget body b
179+ attachWidget body b webView
171180
172181mainWidgetWithCss :: ByteString -> Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) () -> IO ()
173182mainWidgetWithCss css w = runWebGUI $ \webView -> do
@@ -175,13 +184,13 @@ mainWidgetWithCss css w = runWebGUI $ \webView -> do
175184 Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc
176185 htmlElementSetInnerHTML headElement $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
177186 Just body <- documentGetBody doc
178− attachWidget body w
187+ attachWidget body w webView
179188
180−attachWidget :: (IsHTMLElement e) => e -> Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) a -> 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
189+attachWidget :: (IsHTMLElement e) => e -> Widget Spider (Gui Spider SpiderHost (HostFrame Spider)) a -> WebView -> IO a
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
182191 Just doc <- liftM (fmap castToHTMLDocument) $ liftIO $ nodeGetOwnerDocument rootElement
183192 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
185194 runWithActions dm = do
186195 voidActionNeeded <- fireEventsAndRead dm $ do
187196 sequence =<< readEvent voidActionHandle
src/Reflex/Dom/Widget/Basic.hs+3
@@ -428,6 +428,9 @@ elClass elementTag c child = elAttr elementTag ("class" =: c) child
428428list :: (MonadWidget t m, Ord k) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
429429list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
430430
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+
431434elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
432435elDynHtml' elementTag html = do
433436 e <- buildEmptyElement elementTag (Map.empty :: Map String String)
src/Reflex/Dom/Xhr.hs+38−45
@@ -1,7 +1,4 @@
1−{-# LANGUAGE CPP #-}
21module Reflex.Dom.Xhr where
3−
4−#ifdef __GHCJS__
52import Control.Concurrent
63import Control.Lens
74import Control.Monad
@@ -14,11 +11,9 @@ import qualified Data.Map as Map
1411import Data.Maybe
1512import Data.Text (Text)
1613import Data.Text.Encoding
17−import GHCJS.Foreign
18−import GHCJS.Types
19−import GHCJS.DOM.XMLHttpRequest
2014import Reflex
2115import Reflex.Dom.Class
16+import Reflex.Dom.Xhr.Foreign
2217
2318data XhrRequest
2419 = XhrRequest { _xhrRequest_method :: String
@@ -35,7 +30,7 @@ data XhrRequestConfig
3530 }
3631
3732data XhrResponse
38− = XhrResponse { _xhrResponse_body :: Maybe JSString
33+ = XhrResponse { _xhrResponse_body :: Maybe Text
3934 }
4035
4136instance Default XhrRequestConfig where
@@ -49,44 +44,46 @@ instance Default XhrRequestConfig where
4944xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest
5045xhrRequest = XhrRequest
5146
52−newXMLHttpRequest :: XhrRequest -> (XhrResponse -> IO a) -> IO XMLHttpRequest
47+newXMLHttpRequest :: (HasWebView m, MonadIO m) => XhrRequest -> (XhrResponse -> IO a) -> m XMLHttpRequest
5348newXMLHttpRequest req cb = do
54− xhr <- xmlHttpRequestNew
55− let c = _xhrRequest_config req
56− xmlHttpRequestOpen
57− xhr
58− (_xhrRequest_method req)
59− (_xhrRequest_url req)
60− True
61− (fromMaybe "" $ _xhrRequestConfig_user c)
62− (fromMaybe "" $ _xhrRequestConfig_password c)
63− iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr
64− maybe (return ()) (xmlHttpRequestSetResponseType xhr . toJSString) (_xhrRequestConfig_responseType c)
65− _ <- xmlHttpRequestOnreadystatechange xhr $ do
66− readyState <- liftIO $ xmlHttpRequestGetReadyState xhr
67− if readyState == 4
68− then do
69− r <- liftIO $ xmlHttpRequestGetResponseText xhr
70− _ <- liftIO $ cb $ XhrResponse r
71− return ()
72− else return ()
73− _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
74− return xhr
49+ wv <- askWebView
50+ liftIO $ do
51+ xhr <- xmlHttpRequestNew wv
52+ let c = _xhrRequest_config req
53+ xmlHttpRequestOpen
54+ xhr
55+ (_xhrRequest_method req)
56+ (_xhrRequest_url req)
57+ True
58+ (fromMaybe "" $ _xhrRequestConfig_user c)
59+ (fromMaybe "" $ _xhrRequestConfig_password c)
60+ iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr
61+ maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) (_xhrRequestConfig_responseType c)
62+ _ <- xmlHttpRequestOnreadystatechange xhr $ do
63+ readyState <- liftIO $ xmlHttpRequestGetReadyState xhr
64+ if readyState == 4
65+ then do
66+ r <- liftIO $ xmlHttpRequestGetResponseText xhr
67+ _ <- liftIO $ cb $ XhrResponse $ responseTextToText r
68+ return ()
69+ else return ()
70+ _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
71+ return xhr
7572
76−performRequestAsync :: MonadWidget t m => Event t XhrRequest -> m (Event t XhrResponse)
73+performRequestAsync :: (MonadWidget t m) => Event t XhrRequest -> m (Event t XhrResponse)
7774performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do
78− _ <- liftIO $ newXMLHttpRequest r cb
75+ _ <- newXMLHttpRequest r cb
7976 return ()
8077
81−performRequestsAsync :: (Traversable f, MonadWidget t m) => Event t (f XhrRequest) -> m (Event t (f XhrResponse))
82−performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
83− _ <- liftIO $ do
84− resps <- forM rs $ \r -> do
85− resp <- newEmptyMVar
86− _ <- newXMLHttpRequest r $ putMVar resp
87− return resp
88− forkIO $ cb =<< forM resps takeMVar
89− return ()
78+--performRequestsAsync :: (Traversable f, MonadWidget t m) => Event t (f XhrRequest) -> m (Event t (f XhrResponse))
79+--performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
80+-- _ <- liftIO $ do
81+-- resps <- forM rs $ \r -> do
82+-- resp <- newEmptyMVar
83+-- _ <- newXMLHttpRequest r $ putMVar resp
84+-- return resp
85+-- forkIO $ cb =<< forM resps takeMVar
86+-- return ()
9087
9188getAndDecode :: (FromJSON a, MonadWidget t m) => Event t String -> m (Event t (Maybe a))
9289getAndDecode url = do
@@ -101,10 +98,6 @@ getMay f e = do
10198decodeText :: FromJSON a => Text -> Maybe a
10299decodeText = decode . BL.fromStrict . encodeUtf8
103100
104−decodeJSString :: FromJSON a => JSString -> Maybe a
105−decodeJSString = decodeText . fromJSString
106−
107101decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
108−decodeXhrResponse = join . fmap decodeJSString . _xhrResponse_body
102+decodeXhrResponse = join . fmap decodeText . _xhrResponse_body
109103
110−#endif