reflex-dom 0.1 → 0.1.1
raw patch · 3 files changed
+219/−3 lines, 3 files
Files
- reflex-dom.cabal +8/−3
- src-ghc/Reflex/Dom/Internal/Foreign.hs +56/−0
- src-ghc/Reflex/Dom/Xhr/Foreign.hs +155/−0
reflex-dom.cabal view
@@ -1,7 +1,7 @@ Name: reflex-dom-Version: 0.1-Synopsis: Glitch-free Functional Reactive Programming-Description: Reflex is a Functional Reactive Programming implementation that provides strong guarantees of deterministic execution and scalable runtime performance+Version: 0.1.1+Synopsis: Glitch-free Functional Reactive Web Apps+Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine License: BSD3 License-file: LICENSE Author: Ryan Trinkle@@ -10,6 +10,10 @@ Category: FRP Build-type: Simple Cabal-version: >=1.9.2+extra-source-files: src-ghc/Reflex/Dom/Internal/Foreign.hs+ src-ghc/Reflex/Dom/Xhr/Foreign.hs+ src-ghcjs/Reflex/Dom/Internal/Foreign.hs+ src-ghcjs/Reflex/Dom/Xhr/Foreign.hs library hs-source-dirs: src@@ -45,6 +49,7 @@ gtk3 == 0.13.*, webkitgtk3 == 0.13.*, webkitgtk3-javascriptcore == 0.13.*+ -- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367 exposed-modules: Reflex.Dom
+ src-ghc/Reflex/Dom/Internal/Foreign.hs view
@@ -0,0 +1,56 @@+module Reflex.Dom.Internal.Foreign where++import GHCJS.DOM hiding (runWebGUI)+import Control.Concurrent+import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get)+import GHCJS.DOM.Navigator+import GHCJS.DOM.DOMWindow+import Graphics.UI.Gtk hiding (Widget)+import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget, unWidget)+import Graphics.UI.Gtk.WebKit.WebSettings+import Graphics.UI.Gtk.WebKit.WebFrame+import Data.List++makeDefaultWebView :: String -> (WebView -> IO ()) -> IO ()+makeDefaultWebView userAgentKey main = do+ _ <- initGUI+ window <- windowNew+ _ <- timeoutAddFull (yield >> return True) priorityHigh 10+ windowSetDefaultSize window 900 600+ windowSetPosition window WinPosCenter+ scrollWin <- scrolledWindowNew Nothing Nothing+ webView <- webViewNew+ settings <- webViewGetWebSettings webView+ userAgent <- settings `get` webSettingsUserAgent+ settings `set` [ webSettingsUserAgent := userAgent ++ " " ++ userAgentKey+ , webSettingsEnableUniversalAccessFromFileUris := True+ ]+ webViewSetWebSettings webView settings+ window `containerAdd` scrollWin+ scrollWin `containerAdd` webView+ _ <- on window objectDestroy . liftIO $ mainQuit+ widgetShowAll window+ _ <- webView `on` loadFinished $ \_ -> do+ main webView+ wf <- webViewGetMainFrame webView+ webFrameLoadString wf "" Nothing "file:///"+ main webView+ mainGUI++runWebGUI :: (WebView -> IO ()) -> IO ()+runWebGUI = runWebGUI' "GHCJS"++runWebGUI' :: String -> (WebView -> IO ()) -> IO ()+runWebGUI' userAgentKey main = do+ -- Are we in a java script inside some kind of browser+ mbWindow <- currentWindow+ case mbWindow of+ Just window -> do+ -- Check if we are running in javascript inside the the native version+ Just n <- domWindowGetNavigator window+ agent <- navigatorGetUserAgent n+ unless ((" " ++ userAgentKey) `isSuffixOf` agent) $ main (castToWebView window)+ Nothing -> do+ makeDefaultWebView userAgentKey main+
+ src-ghc/Reflex/Dom/Xhr/Foreign.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Reflex.Dom.Xhr.Foreign where++import Control.Lens.Indexed+import qualified Data.Text as T+import Data.Text (Text)+import System.Glib.FFI+import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef+import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame++data XMLHttpRequest = XMLHttpRequest JSValueRef JSContextRef deriving (Eq, Ord)++xhrContext :: XMLHttpRequest -> JSContextRef+xhrContext (XMLHttpRequest _ c) = c++xhrValue :: XMLHttpRequest -> JSValueRef+xhrValue (XMLHttpRequest v _) = v++toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef+toJSObject ctx args = do+ o <- jsobjectmake ctx nullPtr nullPtr+ iforM_ args $ \n a -> do+ prop <- jsstringcreatewithutf8cstring $ show n+ jsobjectsetproperty ctx o prop a 1 nullPtr+ return o++toResponseType :: a -> a+toResponseType = id++responseTextToText :: Maybe String -> Maybe Text+responseTextToText = fmap T.pack++stringToJSValue :: JSContextRef -> String -> IO JSValueRef+stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s++xmlHttpRequestNew :: WebView -> IO XMLHttpRequest+xmlHttpRequestNew wv = do+ --wv <- readIORef globalWebViewRef+ wf <- webViewGetMainFrame wv+ jsContext <- webFrameGetGlobalContext wf+ xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()"+ xhr' <- jsevaluatescript jsContext xhrScript nullPtr nullPtr 1 nullPtr+ jsvalueprotect jsContext xhr'+ return $ XMLHttpRequest xhr' jsContext++xmlHttpRequestOpen :: XMLHttpRequest -> String -> String -> Bool -> String -> String -> IO ()+xmlHttpRequestOpen xhr method url async user password = do+ let c = xhrContext xhr+ method' <- stringToJSValue c method+ url' <- stringToJSValue c url+ async' <- jsvaluemakeboolean (xhrContext xhr) async+ user' <- stringToJSValue c user+ password' <- stringToJSValue c password+ o <- toJSObject c [xhrValue xhr, method', url', async', user', password']+ script <- jsstringcreatewithutf8cstring "this[0].open(this[1], this[2], this[3], this[4], this[5])"+ _ <- jsevaluatescript c script o nullPtr 1 nullPtr+ return ()++foreign import ccall "wrapper"+ wrapper :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback++xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> IO () -> IO ()+xmlHttpRequestOnreadystatechange xhr userCallback = do+ let c = xhrContext xhr+ fp <- wrapper $ \_ _ _ _ _ _ -> do+ userCallback+ jsvaluemakeundefined c+ cb <- jsobjectmakefunctionwithcallback c nullPtr fp+ o <- toJSObject c [xhrValue xhr, cb]+ script <- jsstringcreatewithutf8cstring "this[0].onreadystatechange=this[1]"+ _ <- jsevaluatescript c script o nullPtr 1 nullPtr+ return ()++xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word+xmlHttpRequestGetReadyState xhr = do+ let c = xhrContext xhr+ script <- jsstringcreatewithutf8cstring "this.readyState"+ rs <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr+ d <- jsvaluetonumber c rs nullPtr+ return $ truncate d++xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe String)+xmlHttpRequestGetResponseText xhr = do+ let c = xhrContext xhr+ script <- jsstringcreatewithutf8cstring "this.responseText"+ t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr+ isNull <- jsvalueisnull c t+ case isNull of+ True -> return Nothing+ False -> do+ j <- jsvaluetostringcopy c t nullPtr+ l <- jsstringgetmaximumutf8cstringsize j+ s <- allocaBytes (fromIntegral l) $ \ps -> do+ _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)+ peekCString ps+ return $ Just s++xmlHttpRequestSend :: XMLHttpRequest -> Maybe String -> IO ()+xmlHttpRequestSend xhr payload = do+ let c = xhrContext xhr+ (o,s) <- case payload of+ Nothing -> do+ o <- toJSObject c [xhrValue xhr]+ s <- jsstringcreatewithutf8cstring "this[0].send();"+ return (o,s)+ Just payload' -> do+ d <- stringToJSValue c payload'+ o <- toJSObject c [xhrValue xhr, d]+ s <- jsstringcreatewithutf8cstring "this[0].send(this[1])"+ return (o,s)+ _ <- jsevaluatescript c s o nullPtr 1 nullPtr+ return ()+ +xmlHttpRequestSetRequestHeader :: XMLHttpRequest -> String -> String -> IO ()+xmlHttpRequestSetRequestHeader xhr header value = do+ let c = xhrContext xhr+ header' <- stringToJSValue c header+ value' <- stringToJSValue c value+ o <- toJSObject c [xhrValue xhr, header', value']+ script <- jsstringcreatewithutf8cstring "this[0].setRequestHeader(this[1], this[2])"+ _ <- jsevaluatescript c script o nullPtr 1 nullPtr+ return ()++xmlHttpRequestSetResponseType :: XMLHttpRequest -> String -> IO ()+xmlHttpRequestSetResponseType xhr t = do+ let c = xhrContext xhr+ t' <- stringToJSValue c t+ o <- toJSObject c [xhrValue xhr, t']+ script <- jsstringcreatewithutf8cstring "this[0].responseType = this[1]"+ _ <- jsevaluatescript c script o nullPtr 1 nullPtr+ return ()++xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word+xmlHttpRequestGetStatus xhr = do+ let c = xhrContext xhr+ script <- jsstringcreatewithutf8cstring "this.status"+ s <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr+ d <- jsvaluetonumber c s nullPtr+ return $ truncate d++xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO String+xmlHttpRequestGetStatusText xhr = do+ let c = xhrContext xhr+ script <- jsstringcreatewithutf8cstring "this.statusText"+ t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr+ j <- jsvaluetostringcopy c t nullPtr+ l <- jsstringgetmaximumutf8cstringsize j+ s <- allocaBytes (fromIntegral l) $ \ps -> do+ _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)+ peekCString ps+ return s