WebKitGTK.hs

{-# LANGUAGE CPP #-}
{-# 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.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 (when, void)
import qualified Control.Exception as E (catch)
import Control.Exception (SomeException(..))
import Control.Concurrent (forkIO, yield)

#ifndef mingw32_HOST_OS
import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))
#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 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)
import GI.Gtk
       (windowSetPosition, windowSetDefaultSize, windowNew, scrolledWindowNew,
        noAdjustment, containerAdd, WindowType(..), WindowPosition(..),
        widgetDestroy, widgetGetToplevel, widgetShowAll, onWidgetDestroy,
        mainQuit)
import GI.JavaScriptCore.Structs.GlobalContext (GlobalContext(..))
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)

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 ()
#ifdef mingw32_HOST_OS
installQuitHandler wv = return () -- TODO: Maybe figure something out here for Windows users.
#else
installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) 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
    _ <- timeoutAdd PRIORITY_HIGH 10 (yield >> return True)
    windowSetDefaultSize window 900 600
    windowSetPosition window WindowPositionCenter
    scrollWin <- scrolledWindowNew noAdjustment noAdjustment
    webView <- webViewNew
    settings <- webViewGetSettings webView
    setWebSettingsEnableUniversalAccessFromFileUris settings True
    setWebSettingsEnableDeveloperExtras 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
    pwd <- getCurrentDirectory
    void . onWebViewLoadFinished webView $ \ _ ->
        runInWebView main webView
    webViewLoadString webView "" "text/html" "UTF-8" $ "file://" <> T.pack pwd <> "/"
    installQuitHandler webView
    Gtk.main

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)
        f

    withJSContextRef ctx $ \ctxRef -> do
        addJSaddleHandler ctxRef processResults
        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

jsaddleJs :: LB.ByteString
jsaddleJs = ghcjsHelpers <> mconcat
    [ "(function() {\n"
    , initState
    , "\nreturn function(batchJSON) {\n"
    , "  var batch = JSON.parse(batchJSON);\n"
    , runBatch (\a -> "window.jsaddleCallback(JSON.stringify(" <> a <> "));\n")
    , "};\n"
    , "})()\n"
    ]

#endif