diff --git a/jsaddle-webkit2gtk.cabal b/jsaddle-webkit2gtk.cabal --- a/jsaddle-webkit2gtk.cabal +++ b/jsaddle-webkit2gtk.cabal @@ -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, diff --git a/src/Language/Javascript/JSaddle/WebKit2GTK.hs b/src/Language/Javascript/JSaddle/WebKit2GTK.hs deleted file mode 100644 --- a/src/Language/Javascript/JSaddle/WebKit2GTK.hs +++ /dev/null @@ -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 --- --- | --- ------------------------------------------------------------------------------ -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\ - \" diff --git a/src/Language/Javascript/JSaddle/WebKitGTK.hs b/src/Language/Javascript/JSaddle/WebKitGTK.hs new file mode 100644 --- /dev/null +++ b/src/Language/Javascript/JSaddle/WebKitGTK.hs @@ -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 +-- +-- | +-- +----------------------------------------------------------------------------- +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