packages feed

jsaddle-webkit2gtk (empty) → 0.8.0.0

raw patch · 4 files changed

+245/−0 lines, 4 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, directory, gi-gio, gi-glib, gi-gtk, gi-javascriptcore, gi-webkit2, haskell-gi-base, jsaddle, text, unix, webkit2gtk3-javascriptcore

Files

+ LICENSE view
@@ -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.+
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ jsaddle-webkit2gtk.cabal view
@@ -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 <Hamish.K.Mackenzie@googlemail.com>+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+
+ src/Language/Javascript/JSaddle/WebKit2GTK.hs view
@@ -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 <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\+    \"