jsaddle-webkit2gtk 0.8.0.0 → 0.8.1.0
raw patch · 3 files changed
+195/−178 lines, 3 files
Files
- jsaddle-webkit2gtk.cabal +6/−2
- src/Language/Javascript/JSaddle/WebKit2GTK.hs +0/−176
- src/Language/Javascript/JSaddle/WebKitGTK.hs +189/−0
jsaddle-webkit2gtk.cabal view
@@ -1,5 +1,5 @@ name: jsaddle-webkit2gtk-version: 0.8.0.0+version: 0.8.1.0 cabal-version: >=1.10 build-type: Simple license: MIT@@ -17,11 +17,15 @@ source-repository head type: git location: https://github.com/ghcjs/jsaddle+ subdir: jsaddle-webkit2gtk library exposed-modules:- Language.Javascript.JSaddle.WebKit2GTK+ Language.Javascript.JSaddle.WebKitGTK build-depends:+ base <5+ if !impl(ghcjs -any)+ build-depends: aeson >=0.8.0.2 && <1.1, base <5, bytestring >=0.10.6.0 && <0.11,
− src/Language/Javascript/JSaddle/WebKit2GTK.hs
@@ -1,176 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE LambdaCase #-}------------------------------------------------------------------------------------ Module : Language.Javascript.JSaddle.WebSockets--- Copyright : (c) Hamish Mackenzie--- License : MIT------ Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>------ |----------------------------------------------------------------------------------module Language.Javascript.JSaddle.WebKit2GTK (- -- * Running JSM in a WebView- run- , runInWebView- ) where--import Control.Monad (void)-import Control.Monad.IO.Class (MonadIO(..), MonadIO)-import Control.Concurrent (forkIO, yield)--import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))-import System.Directory (getCurrentDirectory)--import Data.Monoid ((<>))-import Data.ByteString.Lazy (toStrict, fromStrict)-import qualified Data.ByteString.Lazy as LB (ByteString)-import Data.Aeson (encode, decode)-import Data.Text (Text)-import qualified Data.Text as T (pack)-import Data.Text.Foreign (fromPtr)-import Data.Text.Encoding (decodeUtf8, encodeUtf8)--import Foreign.Ptr (castPtr, nullPtr)--import Data.GI.Base.BasicTypes (GObject)-import Data.GI.Base.Signals- (connectSignalFunPtr, SignalConnectMode(..), SignalConnectMode,- SignalHandlerId)-import Data.GI.Base.ManagedPtr (withManagedPtr)--import GI.GLib (timeoutAdd, idleAdd, pattern PRIORITY_HIGH, pattern PRIORITY_DEFAULT)-import qualified GI.Gtk as Gtk (main, init)-import GI.Gtk- (windowSetPosition, windowSetDefaultSize, windowNew,- scrolledWindowNew, noAdjustment, containerAdd,- WindowType(..), WindowPosition(..), widgetDestroy,- widgetGetToplevel, widgetShowAll, onWidgetDestroy,- mainQuit)-import GI.Gio (noCancellable)-import GI.JavaScriptCore (Value(..), GlobalContext(..))-import GI.WebKit2- (WebView, setSettingsEnableWriteConsoleMessagesToStdout,- setSettingsEnableJavascript,- webViewNewWithUserContentManager, userContentManagerNew,- userContentManagerRegisterScriptMessageHandler,- javascriptResultGetValue, javascriptResultGetGlobalContext,- webViewGetUserContentManager,- mk_UserContentManagerScriptMessageReceivedCallback,- wrap_UserContentManagerScriptMessageReceivedCallback,- webViewRunJavascript, LoadEvent(..),- UserContentManagerScriptMessageReceivedCallback, webViewLoadHtml,- onWebViewLoadChanged, setSettingsEnableDeveloperExtras,- webViewSetSettings, webViewGetSettings)--import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase- (JSValueRef, JSContextRef)-import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef- (jsstringgetcharactersptr, jsstringgetlength, jsstringrelease)-import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef- (jsvaluetostringcopy)--import Language.Javascript.JSaddle (JSM, Results)-import Language.Javascript.JSaddle.Run (runJavaScript)-import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)--quitWebView :: WebView -> IO ()-quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't this be postGUISync?- widgetDestroy w--installQuitHandler :: WebView -> IO ()-installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing--postGUIAsync :: IO () -> IO ()-postGUIAsync action =- void . idleAdd PRIORITY_DEFAULT $ action >> return False--withJSContextRef :: GlobalContext -> (JSContextRef -> IO a) -> IO a-withJSContextRef (GlobalContext ctx) f = withManagedPtr ctx (f . castPtr)--withJSValueRef :: Value -> (JSValueRef -> IO a) -> IO a-withJSValueRef (Value ptr) f = withManagedPtr ptr (f . castPtr)--valueToText :: JSContextRef -> JSValueRef -> IO Text-valueToText ctxRef s = do- jsstring <- jsvaluetostringcopy ctxRef s nullPtr- l <- jsstringgetlength jsstring- p <- jsstringgetcharactersptr jsstring- result <- fromPtr (castPtr p) (fromIntegral l)- jsstringrelease jsstring- return result--run :: JSM () -> IO ()-run main = do- _ <- Gtk.init Nothing- window <- windowNew WindowTypeToplevel- _ <- timeoutAdd PRIORITY_HIGH 10 (yield >> return True)- windowSetDefaultSize window 900 600- windowSetPosition window WindowPositionCenter- scrollWin <- scrolledWindowNew noAdjustment noAdjustment- contentManager <- userContentManagerNew- webView <- webViewNewWithUserContentManager contentManager- settings <- webViewGetSettings webView- -- setSettingsEnableUniversalAccessFromFileUris settings True- setSettingsEnableDeveloperExtras settings True- setSettingsEnableJavascript settings True- setSettingsEnableWriteConsoleMessagesToStdout settings True- webViewSetSettings webView settings- window `containerAdd` scrollWin- scrollWin `containerAdd` webView- _ <- onWidgetDestroy window mainQuit- widgetShowAll window- pwd <- getCurrentDirectory- void . onWebViewLoadChanged webView $ \case- LoadEventFinished -> runInWebView main webView- _ -> return ()- webViewLoadHtml webView "" . Just $ "file://" <> T.pack pwd <> "/"- installQuitHandler webView- Gtk.main--runInWebView :: JSM () -> WebView -> IO ()-runInWebView f webView = do- (processResults, start) <- runJavaScript (\batch -> postGUIAsync $- webViewRunJavascript webView (decodeUtf8 . toStrict $ "runJSaddleBatch(" <> encode batch <> ");") noCancellable Nothing)- f-- addJSaddleHandler webView processResults- webViewRunJavascript webView (decodeUtf8 $ toStrict jsaddleJs) noCancellable . Just $- \_obj _asyncResult ->- void $ forkIO start--onUserContentManagerScriptMessageReceived :: (GObject a, MonadIO m) => a -> UserContentManagerScriptMessageReceivedCallback -> m SignalHandlerId-onUserContentManagerScriptMessageReceived obj cb = liftIO $ connectUserContentManagerScriptMessageReceived obj cb SignalConnectBefore--connectUserContentManagerScriptMessageReceived :: (GObject a, MonadIO m) =>- a -> UserContentManagerScriptMessageReceivedCallback -> SignalConnectMode -> m SignalHandlerId-connectUserContentManagerScriptMessageReceived obj cb after = liftIO $ do- let cb' = wrap_UserContentManagerScriptMessageReceivedCallback cb- cb'' <- mk_UserContentManagerScriptMessageReceivedCallback cb'- connectSignalFunPtr obj "script-message-received::jsaddle" cb'' after--addJSaddleHandler :: WebView -> (Results -> IO ()) -> IO ()-addJSaddleHandler webView processResult = do- manager <- webViewGetUserContentManager webView- _ <- onUserContentManagerScriptMessageReceived manager $ \result -> do- ctx <- javascriptResultGetGlobalContext result- arg <- javascriptResultGetValue result- bs <- withJSContextRef ctx $ \ctxRef ->- withJSValueRef arg $ \argRef ->- encodeUtf8 <$> valueToText ctxRef argRef- mapM_ processResult (decode (fromStrict bs))- void $ userContentManagerRegisterScriptMessageHandler manager "jsaddle"--jsaddleJs :: LB.ByteString-jsaddleJs = ghcjsHelpers <> "\- \runJSaddleBatch = (function() {\n\- \ " <> initState <> "\n\- \ return function(batch) {\n\- \ " <> runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));") <> "\- \ };\n\- \})()\n\- \"
+ src/Language/Javascript/JSaddle/WebKitGTK.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE LambdaCase #-}+-----------------------------------------------------------------------------+--+-- Module : Language.Javascript.JSaddle.WebSockets+-- Copyright : (c) Hamish Mackenzie+-- License : MIT+--+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>+--+-- |+--+-----------------------------------------------------------------------------+module Language.Javascript.JSaddle.WebKitGTK (+ -- * Running JSM in a WebView+ run+#ifndef ghcjs_HOST_OS+ , runInWebView+#endif+ ) where++#ifdef ghcjs_HOST_OS++run = IO () -> IO ()+run = id+{-# INLINE run #-}++#else++import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO(..), MonadIO)+import Control.Concurrent (forkIO, yield)++import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))+import System.Directory (getCurrentDirectory)++import Data.Monoid ((<>))+import Data.ByteString.Lazy (toStrict, fromStrict)+import qualified Data.ByteString.Lazy as LB (ByteString)+import Data.Aeson (encode, decode)+import Data.Text (Text)+import qualified Data.Text as T (pack)+import Data.Text.Foreign (fromPtr)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)++import Foreign.Ptr (castPtr, nullPtr)++import Data.GI.Base.BasicTypes (GObject)+import Data.GI.Base.Signals+ (connectSignalFunPtr, SignalConnectMode(..), SignalConnectMode,+ SignalHandlerId)+import Data.GI.Base.ManagedPtr (withManagedPtr)++import GI.GLib (timeoutAdd, idleAdd, pattern PRIORITY_HIGH, pattern PRIORITY_DEFAULT)+import qualified GI.Gtk as Gtk (main, init)+import GI.Gtk+ (windowSetPosition, windowSetDefaultSize, windowNew,+ scrolledWindowNew, noAdjustment, containerAdd,+ WindowType(..), WindowPosition(..), widgetDestroy,+ widgetGetToplevel, widgetShowAll, onWidgetDestroy,+ mainQuit)+import GI.Gio (noCancellable)+import GI.JavaScriptCore (Value(..), GlobalContext(..))+import GI.WebKit2+ (WebView, setSettingsEnableWriteConsoleMessagesToStdout,+ setSettingsEnableJavascript,+ webViewNewWithUserContentManager, userContentManagerNew,+ userContentManagerRegisterScriptMessageHandler,+ javascriptResultGetValue, javascriptResultGetGlobalContext,+ webViewGetUserContentManager,+ mk_UserContentManagerScriptMessageReceivedCallback,+ wrap_UserContentManagerScriptMessageReceivedCallback,+ webViewRunJavascript, LoadEvent(..),+ UserContentManagerScriptMessageReceivedCallback, webViewLoadHtml,+ onWebViewLoadChanged, setSettingsEnableDeveloperExtras,+ webViewSetSettings, webViewGetSettings)++import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase+ (JSValueRef, JSContextRef)+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef+ (jsstringgetcharactersptr, jsstringgetlength, jsstringrelease)+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef+ (jsvaluetostringcopy)++import Language.Javascript.JSaddle (JSM, Results)+import Language.Javascript.JSaddle.Run (runJavaScript)+import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)++quitWebView :: WebView -> IO ()+quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't this be postGUISync?+ widgetDestroy w++installQuitHandler :: WebView -> IO ()+installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing++postGUIAsync :: IO () -> IO ()+postGUIAsync action =+ void . idleAdd PRIORITY_DEFAULT $ action >> return False++withJSContextRef :: GlobalContext -> (JSContextRef -> IO a) -> IO a+withJSContextRef (GlobalContext ctx) f = withManagedPtr ctx (f . castPtr)++withJSValueRef :: Value -> (JSValueRef -> IO a) -> IO a+withJSValueRef (Value ptr) f = withManagedPtr ptr (f . castPtr)++valueToText :: JSContextRef -> JSValueRef -> IO Text+valueToText ctxRef s = do+ jsstring <- jsvaluetostringcopy ctxRef s nullPtr+ l <- jsstringgetlength jsstring+ p <- jsstringgetcharactersptr jsstring+ result <- fromPtr (castPtr p) (fromIntegral l)+ jsstringrelease jsstring+ return result++run :: JSM () -> IO ()+run main = do+ _ <- Gtk.init Nothing+ window <- windowNew WindowTypeToplevel+ _ <- timeoutAdd PRIORITY_HIGH 10 (yield >> return True)+ windowSetDefaultSize window 900 600+ windowSetPosition window WindowPositionCenter+ scrollWin <- scrolledWindowNew noAdjustment noAdjustment+ contentManager <- userContentManagerNew+ webView <- webViewNewWithUserContentManager contentManager+ settings <- webViewGetSettings webView+ -- setSettingsEnableUniversalAccessFromFileUris settings True+ setSettingsEnableDeveloperExtras settings True+ setSettingsEnableJavascript settings True+ setSettingsEnableWriteConsoleMessagesToStdout settings True+ webViewSetSettings webView settings+ window `containerAdd` scrollWin+ scrollWin `containerAdd` webView+ _ <- onWidgetDestroy window mainQuit+ widgetShowAll window+ pwd <- getCurrentDirectory+ void . onWebViewLoadChanged webView $ \case+ LoadEventFinished -> runInWebView main webView+ _ -> return ()+ webViewLoadHtml webView "" . Just $ "file://" <> T.pack pwd <> "/"+ installQuitHandler webView+ Gtk.main++runInWebView :: JSM () -> WebView -> IO ()+runInWebView f webView = do+ (processResults, start) <- runJavaScript (\batch -> postGUIAsync $+ webViewRunJavascript webView (decodeUtf8 . toStrict $ "runJSaddleBatch(" <> encode batch <> ");") noCancellable Nothing)+ f++ addJSaddleHandler webView processResults+ webViewRunJavascript webView (decodeUtf8 $ toStrict jsaddleJs) noCancellable . Just $+ \_obj _asyncResult ->+ void $ forkIO start++onUserContentManagerScriptMessageReceived :: (GObject a, MonadIO m) => a -> UserContentManagerScriptMessageReceivedCallback -> m SignalHandlerId+onUserContentManagerScriptMessageReceived obj cb = liftIO $ connectUserContentManagerScriptMessageReceived obj cb SignalConnectBefore++connectUserContentManagerScriptMessageReceived :: (GObject a, MonadIO m) =>+ a -> UserContentManagerScriptMessageReceivedCallback -> SignalConnectMode -> m SignalHandlerId+connectUserContentManagerScriptMessageReceived obj cb after = liftIO $ do+ let cb' = wrap_UserContentManagerScriptMessageReceivedCallback cb+ cb'' <- mk_UserContentManagerScriptMessageReceivedCallback cb'+ connectSignalFunPtr obj "script-message-received::jsaddle" cb'' after++addJSaddleHandler :: WebView -> (Results -> IO ()) -> IO ()+addJSaddleHandler webView processResult = do+ manager <- webViewGetUserContentManager webView+ _ <- onUserContentManagerScriptMessageReceived manager $ \result -> do+ ctx <- javascriptResultGetGlobalContext result+ arg <- javascriptResultGetValue result+ bs <- withJSContextRef ctx $ \ctxRef ->+ withJSValueRef arg $ \argRef ->+ encodeUtf8 <$> valueToText ctxRef argRef+ mapM_ processResult (decode (fromStrict bs))+ void $ userContentManagerRegisterScriptMessageHandler manager "jsaddle"++jsaddleJs :: LB.ByteString+jsaddleJs = ghcjsHelpers <> mconcat+ [ "runJSaddleBatch = (function() {\n"+ , initState+ , "\nreturn function(batch) {\n"+ , runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));\n")+ , "};\n"+ , "})()"+ ]++#endif