diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +Copyright (c) 2010-2012 Hamish Mackenzie, Victor Nazarov, Luite Stegeman + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/jsaddle-webkit2gtk.cabal b/jsaddle-webkit2gtk.cabal new file mode 100644 --- /dev/null +++ b/jsaddle-webkit2gtk.cabal @@ -0,0 +1,42 @@ +name: jsaddle-webkit2gtk +version: 0.8.0.0 +cabal-version: >=1.10 +build-type: Simple +license: MIT +license-file: LICENSE +maintainer: Hamish Mackenzie +synopsis: Interface for JavaScript that works with GHCJS and GHC +description: + This package provides an EDSL for calling JavaScript that + can be used both from GHCJS and GHC. When using GHC + the application is run using Warp and WebSockets to + drive a small JavaScipt helper. +category: Web, Javascript +author: Hamish Mackenzie + +source-repository head + type: git + location: https://github.com/ghcjs/jsaddle + +library + exposed-modules: + Language.Javascript.JSaddle.WebKit2GTK + build-depends: + aeson >=0.8.0.2 && <1.1, + base <5, + bytestring >=0.10.6.0 && <0.11, + directory >=1.0.0.2 && <1.3, + gi-glib >=2.0.6 && <2.1, + gi-gio >=2.0.6 && <2.1, + gi-gtk >=3.0.6 && <3.1, + gi-webkit2 >=4.0.6 && <4.1, + gi-javascriptcore >=4.0.6 && <4.1, + haskell-gi-base >=0.20 && <0.21, + jsaddle >=0.8.0.0 && <0.9, + text >=1.2.1.3 && <1.3, + unix >=2.3.1.0 && <2.8, + webkit2gtk3-javascriptcore >=0.14.0.0 && <0.15 + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -ferror-spans -Wall + diff --git a/src/Language/Javascript/JSaddle/WebKit2GTK.hs b/src/Language/Javascript/JSaddle/WebKit2GTK.hs new file mode 100644 --- /dev/null +++ b/src/Language/Javascript/JSaddle/WebKit2GTK.hs @@ -0,0 +1,176 @@ +{-# 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\ + \"