jsaddle-webkitgtk 0.9.0.0 → 0.10.0.0
raw patch · 4 files changed
+220/−167 lines, 4 filesdep +gi-giodep +gi-gtk4dep +gi-javascriptcore6dep −gi-gtkdep −gi-javascriptcoredep −webkitgtk3-javascriptcoredep ~aesondep ~bytestringdep ~gi-glibnew-component:exe:jsaddle-webkitgtk-demo
Dependencies added: gi-gio, gi-gtk4, gi-javascriptcore6, jsaddle-webkitgtk
Dependencies removed: gi-gtk, gi-javascriptcore, webkitgtk3-javascriptcore
Dependency ranges changed: aeson, bytestring, gi-glib, gi-webkit, haskell-gi-base, jsaddle, text, unix
Files
- ChangeLog.md +9/−0
- demo/Main.hs +87/−0
- jsaddle-webkitgtk.cabal +38/−17
- src/Language/Javascript/JSaddle/WebKitGTK.hs +86/−150
+ ChangeLog.md view
@@ -0,0 +1,9 @@+# Revision history for jsaddle-webkitgtk++## 0.10.0.0++* Ported to GTK 4 and WebKitGTK 6.0 (gi-gtk4, gi-webkit 6.x,+ gi-javascriptcore6), replacing GTK 3 / WebKitGTK 3. `run` keeps its+ type; `runInWebView` now takes a WebKitGTK 6.0 `WebView`. Native builds+ are Linux only (the JavaScript backend stub builds anywhere).+* jsaddle-webkit2gtk (GTK 3 / webkit2gtk 4.0) remains for GTK 3 apps.
+ demo/Main.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+-- | Minimal jsaddle-webkitgtk demo: a click counter (exercises the+-- synchronous prompt bridge via the callback) and an uptime ticker+-- (exercises async batches from a background Haskell thread).+--+-- With @--smoke@ it also asserts a full round trip through the bridge+-- (async eval + result, and a Haskell callback invoked from JS) and+-- exits 0/1 — suitable for headless CI under @xvfb-run@.+module Main (main) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Monad (forever, void, when)+import Control.Monad.IO.Class (liftIO)+import Data.IORef (atomicModifyIORef', newIORef, readIORef, writeIORef)+import qualified Data.Text as T+import System.Environment (getArgs)+import System.Exit (ExitCode(..))+import System.IO (hSetBuffering, stdout, BufferMode(LineBuffering))+import System.Posix.Process (exitImmediately)+import Language.Javascript.JSaddle+import Language.Javascript.JSaddle.WebKitGTK (run)++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ smoke <- elem "--smoke" <$> getArgs+ -- exitImmediately: exitSuccess/exitFailure only throw in the calling+ -- thread, and everything here runs off the GTK main loop's thread.+ when smoke . void . forkIO $ do+ threadDelay 60000000+ putStrLn "SMOKE-TIMEOUT"+ exitImmediately (ExitFailure 1)+ run $ do+ doc <- jsg "document"+ body <- doc ! "body"+ void $ body # "insertAdjacentHTML" $+ ( "beforeend"+ , "<h1>jsaddle-webkitgtk demo</h1>\+ \<p>Uptime: <span id=\"uptime\">0</span>s</p>\+ \<p><button id=\"btn\">Clicked <span id=\"count\">0</span> times</button></p>"+ )++ clicks <- liftIO $ newIORef (0 :: Int)+ btn <- doc # "getElementById" $ ["btn"]+ void $ btn # "addEventListener" $+ ( "click"+ , fun $ \_ _ _ -> do+ n <- liftIO $ atomicModifyIORef' clicks $ \c -> (c + 1, c + 1)+ el <- doc # "getElementById" $ ["count"]+ el <# "textContent" $ T.pack (show n)+ )++ seconds <- liftIO $ newIORef (0 :: Int)+ ctx <- askJSM+ void . liftIO . forkIO . forever $ do+ threadDelay 1000000+ s <- atomicModifyIORef' seconds $ \c -> (c + 1, c + 1)+ runJSaddle ctx $ do+ el <- jsg "document" # "getElementById" $ ["uptime"]+ el <# "textContent" $ T.pack (show s)++ when smoke $ do+ v <- eval "6 * 7"+ n <- valToNumber v+ liftIO . putStrLn $ "SMOKE eval 6*7 = " ++ show n+ -- A Haskell callback invoked from an eval'd script goes through+ -- the synchronous JSaddleSync prompt path.+ got <- liftIO $ newIORef (0 :: Double)+ _ <- jsg "globalThis" <# "hsSmoke" $ fun $ \_ _ as -> case as of+ (a:_) -> valToNumber a >>= liftIO . writeIORef got+ _ -> return ()+ _ <- eval "globalThis.hsSmoke(123)"+ syncPoint+ liftIO $ do+ -- callbacks run on forked threads; give it a moment+ let waitCb 0 = readIORef got+ waitCb k = do+ x <- readIORef got+ if x == 123 then return x+ else threadDelay 100000 >> waitCb (k - 1 :: Int)+ x <- waitCb 100+ putStrLn $ "SMOKE callback got " ++ show x+ if n == 42 && x == 123+ then putStrLn "SMOKE-OK" >> exitImmediately ExitSuccess+ else putStrLn "SMOKE-FAIL" >> exitImmediately (ExitFailure 1)
jsaddle-webkitgtk.cabal view
@@ -1,16 +1,17 @@ name: jsaddle-webkitgtk-version: 0.9.0.0+version: 0.10.0.0 cabal-version: >=1.10 build-type: Simple license: MIT license-file: LICENSE+extra-source-files: ChangeLog.md 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.+ jsaddle backend hosting the app in a GTK4 window containing a+ WebKitGTK 6.0 WebView (gi-gtk4 / gi-webkit 6.x). The modern+ replacement for jsaddle-webkit2gtk (GTK3 / webkit2gtk 4.0, which has+ been removed from nixpkgs). category: Web, Javascript author: Hamish Mackenzie @@ -23,22 +24,42 @@ exposed-modules: Language.Javascript.JSaddle.WebKitGTK build-depends:- aeson >=0.8.0.2 && <1.3,- base <5,- bytestring >=0.10.6.0 && <0.11,+ base <5+ if !impl(ghcjs -any) && !arch(javascript)+ build-depends:+ aeson >=0.8.0.2 && <2.4,+ bytestring >=0.10.6.0 && <0.13, directory >=1.0.0.2 && <1.4,- gi-glib >=2.0.6 && <2.1,- gi-gtk >=3.0.6 && <3.1,- gi-webkit >=3.0.6 && <3.1,- gi-javascriptcore >=3.0.6 && <3.1,- haskell-gi-base >=0.20 && <0.21,- jsaddle >=0.9.0.0 && <0.10,- text >=1.2.1.3 && <1.3,- webkitgtk3-javascriptcore >=0.14.0.0 && <0.15+ gi-glib >=2.0.14 && <2.1,+ gi-gio >=2.0.14 && <2.1,+ gi-gtk4 >=4.0.8 && <4.1,+ gi-webkit >=6.0.2 && <6.1,+ gi-javascriptcore6 >=6.0.2 && <6.1,+ haskell-gi-base >=0.26 && <0.27,+ jsaddle >=0.9.9.0 && <0.10,+ text >=1.2.1.3 && <1.3 || >= 2.0 && < 2.2 if !os(windows) build-depends:- unix >=2.3.1.0 && <2.8+ unix >=2.3.1.0 && <2.9+ -- Native builds need webkitgtk 6.0 (GTK4): Linux only.+ -- (The ghcjs/javascript stub builds anywhere.)+ if !os(linux) && !impl(ghcjs) && !arch(javascript)+ buildable: False default-language: Haskell2010 hs-source-dirs: src ghc-options: -ferror-spans -Wall +executable jsaddle-webkitgtk-demo+ main-is: Main.hs+ hs-source-dirs: demo+ build-depends:+ base <5,+ jsaddle,+ jsaddle-webkitgtk,+ text,+ unix+ -- Native-only (no ghcjs stub): a plain WebKitGTK window app.+ if !os(linux)+ buildable: False+ default-language: Haskell2010+ ghc-options: -ferror-spans -Wall -threaded
src/Language/Javascript/JSaddle/WebKitGTK.hs view
@@ -3,15 +3,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonoLocalBinds #-} ----------------------------------------------------------------------------- ----- Module : Language.Javascript.JSaddle.WebSockets+-- Module : Language.Javascript.JSaddle.WebKitGTK -- Copyright : (c) Hamish Mackenzie -- License : MIT -- -- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com> ----- |+-- | Run jsaddle apps in a GTK4 window hosting a WebKitGTK 6.0 WebView. -- ----------------------------------------------------------------------------- module Language.Javascript.JSaddle.WebKitGTK (@@ -30,9 +31,7 @@ #else -import Control.Monad (when, void)-import qualified Control.Exception as E (catch)-import Control.Exception (SomeException(..))+import Control.Monad (void) import Control.Concurrent (forkIO, yield) #ifndef mingw32_HOST_OS@@ -40,191 +39,128 @@ #endif 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 (unpack, pack)-import Data.Text.Foreign (useAsPtr, fromPtr)+import qualified Data.Text as T (pack) import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Foreign.Ptr (castPtr, nullPtr)-import Foreign.Marshal.Array (withArray, peekArray)-import Foreign.Storable (Storable(..))-import Foreign.Marshal.Alloc (alloca)--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)+ (timeoutAdd, idleAdd, mainLoopNew, mainLoopRun, mainLoopQuit,+ pattern PRIORITY_HIGH, pattern PRIORITY_DEFAULT)+import qualified GI.Gtk as Gtk (init) import GI.Gtk- (windowSetPosition, windowSetDefaultSize, windowNew, scrolledWindowNew,- noAdjustment, containerAdd, WindowType(..), WindowPosition(..),- widgetDestroy, widgetGetToplevel, widgetShowAll, onWidgetDestroy,- mainQuit)-import GI.JavaScriptCore.Structs.GlobalContext (GlobalContext(..))+ (Window, windowNew, windowSetDefaultSize, windowSetChild,+ windowPresent, windowDestroy, scrolledWindowNew,+ scrolledWindowSetChild, onWidgetDestroy)+import GI.Gio (Cancellable)+import GI.JavaScriptCore (valueToString) import GI.WebKit- (WebView, webViewGetMainFrame, webFrameGetGlobalContext,- onWebInspectorInspectWebView, webViewGetInspector, webViewSetSettings,- setWebSettingsEnableDeveloperExtras,- setWebSettingsEnableUniversalAccessFromFileUris,- webViewGetSettings, webViewNew, onWebViewLoadFinished,- webViewLoadString)--import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase- (JSValueRef, JSValueRefRef, JSObjectRef, JSContextRef,- jsevaluatescript, JSStringRef)-import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef- (jsstringretain, jsstringrelease, jsstringgetcharactersptr,- jsstringgetlength, jsstringcreatewithcharacters)-import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef- (jsobjectcallasfunction, JSCSize, jsobjectsetproperty,- jsobjectmakefunctionwithcallback, mkJSObjectCallAsFunctionCallback)-import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSContextRef- (jscontextgetglobalobject)-import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef- (jsvalueprotect, jsvalueunprotect,- jsvaluetostringcopy, jsvaluemakestring, jsvaluemakeundefined)+ (scriptDialogPromptSetText, scriptDialogPromptGetDefaultText,+ scriptDialogGetMessage, scriptDialogGetDialogType,+ onWebViewScriptDialog, WebView, webViewNew,+ setSettingsEnableWriteConsoleMessagesToStdout,+ setSettingsEnableJavascript,+ onUserContentManagerScriptMessageReceived,+ userContentManagerRegisterScriptMessageHandler,+ webViewGetUserContentManager,+ webViewEvaluateJavascript, LoadEvent(..), webViewLoadHtml,+ onWebViewLoadChanged, setSettingsEnableDeveloperExtras,+ webViewSetSettings, webViewGetSettings, ScriptDialogType(..)) -import Language.Javascript.JSaddle (JSM, Results)+import Language.Javascript.JSaddle (JSM, Results, Batch) 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+noCancellable :: Maybe Cancellable+noCancellable = Nothing -installQuitHandler :: WebView -> IO ()+quitWindow :: Window -> IO ()+quitWindow window = postGUIAsync $ windowDestroy window++installQuitHandler :: Window -> IO () #ifdef mingw32_HOST_OS-installQuitHandler wv = return () -- TODO: Maybe figure something out here for Windows users.+installQuitHandler _ = return () -- TODO: Maybe figure something out here for Windows users. #else-installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing+installQuitHandler window = void $ installHandler keyboardSignal (Catch (quitWindow window)) Nothing #endif postGUIAsync :: IO () -> IO () postGUIAsync action = void . idleAdd PRIORITY_DEFAULT $ action >> return False -withJSString :: Text -> (JSStringRef -> IO a) -> IO a-withJSString s f = do- jsstring <- useAsPtr s $ \p l -> jsstringcreatewithcharacters (castPtr p) (fromIntegral l)- _ <- jsstringretain jsstring- result <- f jsstring- jsstringrelease jsstring- return result--withJSContextRef :: GlobalContext -> (JSContextRef -> IO a) -> IO a-withJSContextRef (GlobalContext ctx) f = withManagedPtr ctx (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--check :: JSContextRef -> (JSValueRefRef -> IO a) -> IO a-check ctxRef f =- alloca $ \exceptionPtr -> do- poke exceptionPtr nullPtr- result <- f exceptionPtr- exception <- peek exceptionPtr- when (exception /= nullPtr) $ do- errorText <- valueToText ctxRef exception- error $ T.unpack errorText- return result--eval :: JSContextRef -> Text -> IO JSValueRef-eval ctxRef script =- withJSString script $ \script' ->- check ctxRef $ jsevaluatescript ctxRef script' nullPtr nullPtr 0- run :: JSM () -> IO () run main = do- _ <- Gtk.init Nothing- window <- windowNew WindowTypeToplevel+ Gtk.init+ loop <- mainLoopNew Nothing False _ <- timeoutAdd PRIORITY_HIGH 10 (yield >> return True)+ window <- windowNew windowSetDefaultSize window 900 600- windowSetPosition window WindowPositionCenter- scrollWin <- scrolledWindowNew noAdjustment noAdjustment+ scrollWin <- scrolledWindowNew webView <- webViewNew settings <- webViewGetSettings webView- setWebSettingsEnableUniversalAccessFromFileUris settings True- setWebSettingsEnableDeveloperExtras 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- inspector <- webViewGetInspector webView- _ <- onWebInspectorInspectWebView inspector $ \_ -> do- inspectorWindow <- windowNew WindowTypeToplevel- windowSetDefaultSize inspectorWindow 900 600- inspectorScrollWin <- scrolledWindowNew noAdjustment noAdjustment- inspectorWebView <- webViewNew- inspectorWindow `containerAdd` inspectorScrollWin- inspectorScrollWin `containerAdd` inspectorWebView- widgetShowAll inspectorWindow- return inspectorWebView+ scrolledWindowSetChild scrollWin (Just webView)+ windowSetChild window (Just scrollWin)+ _ <- onWidgetDestroy window $ mainLoopQuit loop+ windowPresent window pwd <- getCurrentDirectory- void . onWebViewLoadFinished webView $ \ _ ->- runInWebView main webView- webViewLoadString webView "" "text/html" "UTF-8" $ "file://" <> T.pack pwd <> "/"- installQuitHandler webView- Gtk.main+ let webViewLoadChangedCallback LoadEventFinished = runInWebView main webView+ webViewLoadChangedCallback _ = return ()+ _ <- onWebViewLoadChanged webView webViewLoadChangedCallback+ webViewLoadHtml webView "" . Just $ "file://" <> T.pack pwd <> "/index.html"+ installQuitHandler window+ mainLoopRun loop runInWebView :: JSM () -> WebView -> IO () runInWebView f webView = do- ctx <- webViewGetMainFrame webView >>= webFrameGetGlobalContext- runJSaddleBatch <-- withJSContextRef ctx $ \ctxRef -> do- result <- eval ctxRef (decodeUtf8 $ toStrict jsaddleJs)- jsvalueprotect ctxRef result- return result-- (processResults, _, start) <- runJavaScript (\batch -> postGUIAsync $- withJSContextRef ctx $ \ctxRef ->- withJSString (decodeUtf8 . toStrict $ encode batch) $ \script -> do- val <- jsvaluemakestring ctxRef script- withArray [val] $ \args ->- void . check ctxRef $ jsobjectcallasfunction ctxRef runJSaddleBatch nullPtr 1 args- jsvalueunprotect ctxRef val)+ (processResults, syncResults, start) <- runJavaScript (\batch -> postGUIAsync $+ webViewEvaluateJavascript webView+ (decodeUtf8 . toStrict $ "runJSaddleBatch(" <> encode batch <> ");")+ (-1) Nothing Nothing noCancellable Nothing) f - withJSContextRef ctx $ \ctxRef -> do- addJSaddleHandler ctxRef processResults- void $ forkIO start+ addJSaddleHandler webView processResults syncResults+ webViewEvaluateJavascript webView (decodeUtf8 $ toStrict jsaddleJs)+ (-1) Nothing Nothing noCancellable . Just $+ \_obj _asyncResult ->+ void $ forkIO start -addJSaddleHandler :: JSContextRef -> (Results -> IO ()) -> IO ()-addJSaddleHandler ctxRef processResult = do- callback <- mkJSObjectCallAsFunctionCallback wrap- function <- jsobjectmakefunctionwithcallback ctxRef nullPtr callback- global <- jscontextgetglobalobject ctxRef- withJSString "jsaddleCallback" $ \propName ->- jsobjectsetproperty ctxRef global propName function 0 nullPtr- where- wrap :: JSContextRef -> JSObjectRef -> JSObjectRef -> JSCSize -> JSValueRefRef -> JSValueRefRef -> IO JSValueRef- wrap _ctx _fobj _this argc argv exception = do- [arg] <- peekArray (fromIntegral argc) argv- bs <- encodeUtf8 <$> valueToText ctxRef arg- mapM_ processResult (decode (fromStrict bs))- jsvaluemakeundefined ctxRef- `E.catch` \(e :: SomeException) -> do- withJSString (T.pack (show e)) (jsvaluemakestring ctxRef) >>= poke exception- jsvaluemakeundefined ctxRef+addJSaddleHandler :: WebView -> (Results -> IO ()) -> (Results -> IO Batch) -> IO ()+addJSaddleHandler webView processResult syncResults = do+ manager <- webViewGetUserContentManager webView+ _ <- onUserContentManagerScriptMessageReceived manager Nothing $ \value -> do+ bs <- encodeUtf8 <$> valueToString value+ mapM_ processResult (decode (fromStrict bs))+ _ <- onWebViewScriptDialog webView $ \dialog ->+ scriptDialogGetDialogType dialog >>= \case+ ScriptDialogTypePrompt ->+ scriptDialogGetMessage dialog >>= \case+ "JSaddleSync" -> do+ resultsText <- scriptDialogPromptGetDefaultText dialog+ case decode (fromStrict $ encodeUtf8 resultsText) of+ Just results -> do+ batch <- syncResults results+ scriptDialogPromptSetText dialog (decodeUtf8 . toStrict $ encode batch)+ return True+ Nothing -> return False+ _ -> return False+ _ -> return False + void $ userContentManagerRegisterScriptMessageHandler manager "jsaddle" Nothing+ jsaddleJs :: LB.ByteString jsaddleJs = ghcjsHelpers <> mconcat- [ "(function() {\n"+ [ "runJSaddleBatch = (function() {\n" , initState- , "\nreturn function(batchJSON) {\n"- , " var batch = JSON.parse(batchJSON);\n"- , runBatch (\a -> "window.jsaddleCallback(JSON.stringify(" <> a <> "));\n") Nothing+ , "\nreturn function(batch) {\n"+ , runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));\n")+ (Just (\a -> "JSON.parse(window.prompt(\"JSaddleSync\", JSON.stringify(" <> a <> ")))")) , "};\n"- , "})()\n"+ , "})()" ] #endif