@@ -0,0 +1,211 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE PatternSynonyms #-}
4+{-# LANGUAGE LambdaCase #-}
5+-----------------------------------------------------------------------------
6+--
7+-- Module : Language.Javascript.JSaddle.WebSockets
8+-- Copyright : (c) Hamish Mackenzie
9+-- License : MIT
10+--
11+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
12+--
13+-- |
14+--
15+-----------------------------------------------------------------------------
16+module Language.Javascript.JSaddle.WebKitGTK (
17+ -- * Running JSM in a WebView
18+ run
19+ , runInWebView
20+ ) where
21+
22+import Control.Monad (when, void)
23+import qualified Control.Exception as E (catch)
24+import Control.Exception (SomeException(..))
25+import Control.Concurrent (forkIO, yield)
26+
27+import System.Posix.Signals (installHandler)
28+import System.Directory (getCurrentDirectory)
29+
30+import Data.Monoid ((<>))
31+import Data.ByteString.Lazy (toStrict, fromStrict)
32+import qualified Data.ByteString.Lazy as LB (ByteString)
33+import Data.Aeson (encode, decode)
34+import Data.Text (Text)
35+import qualified Data.Text as T (unpack, pack)
36+import Data.Text.Foreign (useAsPtr, fromPtr)
37+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
38+
39+import Foreign.Ptr (castPtr, nullPtr)
40+import Foreign.Marshal.Array (withArray, peekArray)
41+import Foreign.Storable (Storable(..))
42+import Foreign.Marshal.Alloc (alloca)
43+
44+import Data.GI.Base.ManagedPtr (withManagedPtr)
45+import GI.GLib
46+ (timeoutAdd, idleAdd, pattern PRIORITY_HIGH, pattern PRIORITY_DEFAULT)
47+import qualified GI.Gtk as Gtk (main, init)
48+import GI.Gtk
49+ (windowSetPosition, windowSetDefaultSize, windowNew, scrolledWindowNew,
50+ noAdjustment, containerAdd, WindowType(..), WindowPosition(..),
51+ widgetDestroy, widgetGetToplevel, widgetShowAll, onWidgetDestroy,
52+ mainQuit)
53+import GI.JavaScriptCore.Structs.GlobalContext (GlobalContext(..))
54+import GI.WebKit
55+ (WebView, webViewGetMainFrame, webFrameGetGlobalContext,
56+ onWebInspectorInspectWebView, webViewGetInspector, webViewSetSettings,
57+ setWebSettingsEnableDeveloperExtras,
58+ setWebSettingsEnableUniversalAccessFromFileUris,
59+ webViewGetSettings, webViewNew, onWebViewLoadFinished,
60+ webViewLoadString)
61+
62+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
63+ (JSValueRef, JSValueRefRef, JSObjectRef, JSContextRef,
64+ jsevaluatescript, JSStringRef)
65+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
66+ (jsstringretain, jsstringrelease, jsstringgetcharactersptr,
67+ jsstringgetlength, jsstringcreatewithcharacters)
68+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
69+ (jsobjectcallasfunction, JSCSize, jsobjectsetproperty,
70+ jsobjectmakefunctionwithcallback, mkJSObjectCallAsFunctionCallback)
71+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSContextRef
72+ (jscontextgetglobalobject)
73+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
74+ (jsvalueprotect, jsvalueunprotect,
75+ jsvaluetostringcopy, jsvaluemakestring, jsvaluemakeundefined)
76+
77+import Language.Javascript.JSaddle (JSM, Results)
78+import Language.Javascript.JSaddle.Run (runJavaScript)
79+import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
80+
81+quitWebView :: WebView -> IO ()
82+quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't this be postGUISync?
83+ widgetDestroy w
84+
85+installQuitHandler :: WebView -> IO ()
86+installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing
87+
88+postGUIAsync :: IO () -> IO ()
89+postGUIAsync action =
90+ void . idleAdd PRIORITY_DEFAULT $ action >> return False
91+
92+withJSString :: Text -> (JSStringRef -> IO a) -> IO a
93+withJSString s f = do
94+ jsstring <- useAsPtr s $ \p l -> jsstringcreatewithcharacters (castPtr p) (fromIntegral l)
95+ _ <- jsstringretain jsstring
96+ result <- f jsstring
97+ jsstringrelease jsstring
98+ return result
99+
100+withJSContextRef :: GlobalContext -> (JSContextRef -> IO a) -> IO a
101+withJSContextRef (GlobalContext ctx) f = withManagedPtr ctx (f . castPtr)
102+
103+valueToText :: JSContextRef -> JSValueRef -> IO Text
104+valueToText ctxRef s = do
105+ jsstring <- jsvaluetostringcopy ctxRef s nullPtr
106+ l <- jsstringgetlength jsstring
107+ p <- jsstringgetcharactersptr jsstring
108+ result <- fromPtr (castPtr p) (fromIntegral l)
109+ jsstringrelease jsstring
110+ return result
111+
112+check :: JSContextRef -> (JSValueRefRef -> IO a) -> IO a
113+check ctxRef f =
114+ alloca $ \exceptionPtr -> do
115+ poke exceptionPtr nullPtr
116+ result <- f exceptionPtr
117+ exception <- peek exceptionPtr
118+ when (exception /= nullPtr) $ do
119+ errorText <- valueToText ctxRef exception
120+ error $ T.unpack errorText
121+ return result
122+
123+eval :: JSContextRef -> Text -> IO JSValueRef
124+eval ctxRef script =
125+ withJSString script $ \script' ->
126+ check ctxRef $ jsevaluatescript ctxRef script' nullPtr nullPtr 0
127+
128+run :: JSM () -> IO ()
129+run main = do
130+ _ <- Gtk.init Nothing
131+ window <- windowNew WindowTypeToplevel
132+ _ <- timeoutAdd PRIORITY_HIGH 10 (yield >> return True)
133+ windowSetDefaultSize window 900 600
134+ windowSetPosition window WindowPositionCenter
135+ scrollWin <- scrolledWindowNew noAdjustment noAdjustment
136+ webView <- webViewNew
137+ settings <- webViewGetSettings webView
138+ setWebSettingsEnableUniversalAccessFromFileUris settings True
139+ setWebSettingsEnableDeveloperExtras settings True
140+ webViewSetSettings webView settings
141+ window `containerAdd` scrollWin
142+ scrollWin `containerAdd` webView
143+ _ <- onWidgetDestroy window mainQuit
144+ widgetShowAll window
145+ inspector <- webViewGetInspector webView
146+ _ <- onWebInspectorInspectWebView inspector $ \_ -> do
147+ inspectorWindow <- windowNew WindowTypeToplevel
148+ windowSetDefaultSize inspectorWindow 900 600
149+ inspectorScrollWin <- scrolledWindowNew noAdjustment noAdjustment
150+ inspectorWebView <- webViewNew
151+ inspectorWindow `containerAdd` inspectorScrollWin
152+ inspectorScrollWin `containerAdd` inspectorWebView
153+ widgetShowAll inspectorWindow
154+ return inspectorWebView
155+ pwd <- getCurrentDirectory
156+ void . onWebViewLoadFinished webView $ \ _ ->
157+ runInWebView main webView
158+ webViewLoadString webView "" "text/html" "UTF-8" $ "file://" <> T.pack pwd <> "/"
159+ installQuitHandler webView
160+ Gtk.main
161+
162+runInWebView :: JSM () -> WebView -> IO ()
163+runInWebView f webView = do
164+ ctx <- webViewGetMainFrame webView >>= webFrameGetGlobalContext
165+ runJSaddleBatch <-
166+ withJSContextRef ctx $ \ctxRef -> do
167+ result <- eval ctxRef (decodeUtf8 $ toStrict jsaddleJs)
168+ jsvalueprotect ctxRef result
169+ return result
170+
171+ (processResults, start) <- runJavaScript (\batch -> postGUIAsync $
172+ withJSContextRef ctx $ \ctxRef ->
173+ withJSString (decodeUtf8 . toStrict $ encode batch) $ \script -> do
174+ val <- jsvaluemakestring ctxRef script
175+ withArray [val] $ \args ->
176+ void . check ctxRef $ jsobjectcallasfunction ctxRef runJSaddleBatch nullPtr 1 args
177+ jsvalueunprotect ctxRef val)
178+ f
179+
180+ withJSContextRef ctx $ \ctxRef -> do
181+ addJSaddleHandler ctxRef processResults
182+ void $ forkIO start
183+
184+addJSaddleHandler :: JSContextRef -> (Results -> IO ()) -> IO ()
185+addJSaddleHandler ctxRef processResult = do
186+ callback <- mkJSObjectCallAsFunctionCallback wrap
187+ function <- jsobjectmakefunctionwithcallback ctxRef nullPtr callback
188+ global <- jscontextgetglobalobject ctxRef
189+ withJSString "jsaddleCallback" $ \propName ->
190+ jsobjectsetproperty ctxRef global propName function 0 nullPtr
191+ where
192+ wrap :: JSContextRef -> JSObjectRef -> JSObjectRef -> JSCSize -> JSValueRefRef -> JSValueRefRef -> IO JSValueRef
193+ wrap _ctx _fobj _this argc argv exception = do
194+ [arg] <- peekArray (fromIntegral argc) argv
195+ bs <- encodeUtf8 <$> valueToText ctxRef arg
196+ mapM_ processResult (decode (fromStrict bs))
197+ jsvaluemakeundefined ctxRef
198+ `E.catch` \(e :: SomeException) -> do
199+ withJSString (T.pack (show e)) (jsvaluemakestring ctxRef) >>= poke exception
200+ jsvaluemakeundefined ctxRef
201+
202+jsaddleJs :: LB.ByteString
203+jsaddleJs = ghcjsHelpers <> "\
204+ \(function() {\n\
205+ \ " <> initState <> "\n\
206+ \ return function(batchJSON) {\n\
207+ \ var batch = JSON.parse(batchJSON);\n\
208+ \ " <> runBatch (\a -> "window.jsaddleCallback(JSON.stringify(" <> a <> "));") <> "\
209+ \ };\n\
210+ \})()\n\
211+ \"