Opt-in batch serialisation for shared-main-thread runners; make jsaddle-wkwebview TH-loadable; aeson <2.4

jsaddle-webkitgtk/jsaddle-webkitgtk.cabal

@@ -26,7 +26,7 @@ library
         base <5
     if !impl(ghcjs -any) && !arch(javascript)
       build-depends:
-        aeson >=0.8.0.2 && <2.3,
+        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.14 && <2.1,

jsaddle-webview2/jsaddle-webview2.cabal

@@ -31,7 +31,7 @@ library
     ghc-options: -ferror-spans -Wall
     build-depends:
         base <5,
-        aeson >=0.8.0.2 && <2.3,
+        aeson >=0.8.0.2 && <2.4,
         bytestring >=0.10.6.0 && <0.13,
         data-default,
         jsaddle >=0.9.9.0 && <0.10,

jsaddle-wkwebview/cbits-cocoa/WKWebView-AppDelegate.m

@@ -0,0 +1,17 @@
+// Single translation unit combining the package's Cocoa Objective-C
+// sources.  GHC's runtime linker — used for Template Haskell when the
+// compiler is statically linked — refuses the duplicate Objective-C
+// protocol/class metadata every ObjC object file emits (e.g.
+// __OBJC_LABEL_PROTOCOL_$_NSObject, coalesced by the system linker but
+// treated as strong duplicate definitions by GHC), so all of the
+// package's ObjC code must land in ONE archive member for TH splices
+// in dependents to be able to load this library.
+// Combining the sources puts the whole translation unit into clang's
+// nullability-audit mode (AppDelegate.m uses _Nonnull), which then
+// demands annotations on every pointer in WKWebView-cbits.m — the
+// files compile cleanly standalone, so silence the completeness
+// diagnostics for the composite.
+#pragma clang diagnostic ignored "-Wnullability-completeness"
+#pragma clang diagnostic ignored "-Wnullability-completeness-on-arrays"
+#include "../cbits/WKWebView-cbits.m"
+#include "AppDelegate.m"

jsaddle-wkwebview/jsaddle-wkwebview.cabal

@@ -15,6 +15,13 @@ category: Web, Javascript
 author: Hamish Mackenzie
 tested-with: GHC==9.12.2, GHC==9.10.1, GHC==9.8.4, GHC==9.6.7, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4
 
+-- #included by cbits-cocoa/WKWebView-AppDelegate.m (the single Cocoa
+-- translation unit) rather than compiled directly, so they must be
+-- shipped explicitly.
+extra-source-files:
+    cbits/WKWebView-cbits.m
+    cbits-cocoa/AppDelegate.m
+
 flag include-app-delegate
     description: Include default AppDelegate C sources.
     default: True
@@ -40,7 +47,7 @@ library
     else
         frameworks: Foundation, WebKit
         build-depends:
-            aeson >=0.8.0.2 && <2.3,
+            aeson >=0.8.0.2 && <2.4,
             bytestring >=0.10.6.0 && <0.13,
             directory,
             jsaddle >= 0.9.9.0 && <0.10,
@@ -50,19 +57,36 @@ library
         exposed-modules:
             Language.Javascript.JSaddle.WKWebView.Internal
         hs-source-dirs: src-ghc
-        cxx-sources:
-            cbits/WKWebView.m
+        -- The cbits file is named -cbits so its object's archive-member
+        -- basename can't collide with the
+        -- Language.Javascript.JSaddle.WKWebView module object (Cabal
+        -- 3.12+ places Haskell and foreign objects in one object tree;
+        -- ar stores members by basename, and GHC 9.14's in-process TH
+        -- loader mis-resolves duplicate member names).
         cc-options: -Wno-everything
         if os(ios)
             frameworks: UIKit, UserNotifications
             if flag(include-app-delegate)
               cxx-sources:
+                  cbits/WKWebView-cbits.m
                   cbits-uikit/AppDelegate.m
                   cbits-uikit/ViewController.m
               cpp-options: -DUSE_UIKIT
+            else
+              cxx-sources:
+                  cbits/WKWebView-cbits.m
         else
             frameworks: Cocoa
             if flag(include-app-delegate)
+              -- A SINGLE Objective-C translation unit (it #includes
+              -- WKWebView-cbits.m and AppDelegate.m): GHC's runtime
+              -- linker — used for TH under a statically linked GHC —
+              -- rejects the duplicate ObjC protocol metadata every ObjC
+              -- object emits, so the package's ObjC code must form one
+              -- archive member for dependents' TH splices to load it.
               cxx-sources:
-                  cbits-cocoa/AppDelegate.m
+                  cbits-cocoa/WKWebView-AppDelegate.m
               cpp-options: -DUSE_COCOA
+            else
+              cxx-sources:
+                  cbits/WKWebView-cbits.m

jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView/Internal.hs

@@ -9,7 +9,9 @@ module Language.Javascript.JSaddle.WKWebView.Internal
 
 import Control.Monad (void, join)
 import Control.Concurrent (forkIO, forkOS)
-import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
+import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
+
+import System.IO.Unsafe (unsafePerformIO)
 
 import Data.Monoid ((<>))
 import Data.ByteString (useAsCString, packCString)
@@ -25,14 +27,24 @@ import Foreign.Ptr (Ptr, nullPtr)
 import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr)
 
 import Language.Javascript.JSaddle (Results, Batch, JSM)
-import Language.Javascript.JSaddle.Run (runJavaScript)
+import Language.Javascript.JSaddle.Run (runJavaScriptWithSerializer)
 import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
 
 import System.Directory (getCurrentDirectory)
 
 newtype WKWebView = WKWebView (Ptr WKWebView)
 newtype JSaddleHandler = JSaddleHandler (Ptr JSaddleHandler)
 
+-- | Serialises the jsaddle batch round-trip across every WKWebView in the
+-- process.  All windows dispatch their JS onto the one Cocoa main queue, and a
+-- synchronous @window.prompt@ round-trip blocks that queue; without this lock
+-- two windows driving JS concurrently can wedge each other.  Shared (not
+-- per-webview) precisely because the contended resource — the main queue — is
+-- shared.  See 'runJavaScriptWithSerializer'.
+{-# NOINLINE wkWebViewBatchLock #-}
+wkWebViewBatchLock :: MVar ()
+wkWebViewBatchLock = unsafePerformIO (newMVar ())
+
 foreign export ccall jsaddleStart :: StablePtr (IO ()) -> IO ()
 foreign export ccall jsaddleResult :: StablePtr (Results -> IO ()) -> CString -> IO ()
 foreign export ccall jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()
@@ -83,7 +95,7 @@ jsaddleMain' :: JSM () -> WKWebView -> IO () -> IO ()
 jsaddleMain' f webView loadHtml = do
     ready <- newEmptyMVar
 
-    (processResult, syncResult, start) <- runJavaScript (\batch ->
+    (processResult, syncResult, start) <- runJavaScriptWithSerializer (Just wkWebViewBatchLock) (\batch ->
         useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $
             evaluateJavaScript webView)
         f

jsaddle/jsaddle.cabal

@@ -111,7 +111,7 @@ library
         Language.Javascript.JSaddle.Value
         Language.Javascript.JSaddle.Types
     build-depends:
-        aeson >=0.11.3.0 && <2.3,
+        aeson >=0.11.3.0 && <2.4,
         base >=4.9 && <5,
         base-compat >=0.9.0 && <0.16,
         base64-bytestring >=1.0.0.1 && <1.3,

jsaddle/src/Language/Javascript/JSaddle/Run.hs

@@ -26,6 +26,7 @@ module Language.Javascript.JSaddle.Run (
 #ifndef ghcjs_HOST_OS
   -- * Functions used to implement JSaddle using JSON messaging
   , runJavaScript
+  , runJavaScriptWithSerializer
   , AsyncCommand(..)
   , Command(..)
   , Result(..)
@@ -55,7 +56,7 @@ import Control.Concurrent.STM.TChan
 import Control.Concurrent.STM.TVar
        (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
 import Control.Concurrent.MVar
-       (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)
+       (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar, withMVar)
 
 import System.IO.Unsafe (unsafeInterleaveIO)
 import System.Random
@@ -134,7 +135,29 @@ sendAsyncCommand cmd = do
     liftIO $ s cmd
 
 runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
-runJavaScript sendBatch entryPoint = do
+runJavaScript = runJavaScriptWithSerializer Nothing
+
+-- | Like 'runJavaScript', but with an optional serialiser that brackets each
+-- batch round-trip (@sendBatch@..@takeResult@).
+--
+-- Pass @Nothing@ (as plain 'runJavaScript' does) for the default: contexts run
+-- fully independently, which is what transports with per-context transports want
+-- — e.g. jsaddle-warp, where each browser client is its own context on its own
+-- WebSocket and serialising across them would let one slow client stall the
+-- rest.
+--
+-- Pass @Just lock@ — one 'MVar' shared across all the contexts that share a
+-- single transport thread — when concurrent contexts on that thread can wedge
+-- each other.  This is the case for the native GUI runners (several WKWebView /
+-- WebKitGTK / WebView2 windows dispatching onto the one Cocoa\/GTK\/UI main
+-- thread, where a synchronous @window.prompt@ round-trip blocks that thread):
+-- holding the lock means at most one context occupies the transport at a time.
+-- It is safe against jsaddle's sync-callback protocol — a prompt's handler
+-- returns the pre-set 'lastAsyncBatch' without needing the batch thread, so
+-- blocking the batch thread here never stalls an in-flight synchronous
+-- round-trip.
+runJavaScriptWithSerializer :: Maybe (MVar ()) -> (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
+runJavaScriptWithSerializer mSerializer sendBatch entryPoint = do
     contextId' <- randomIO
     startTime' <- getCurrentTime
     recvMVar <- newEmptyMVar
@@ -146,6 +169,8 @@ runJavaScript sendBatch entryPoint = do
     animationFrameHandlers' <- newMVar []
     loggingEnabled <- newIORef False
     liveRefs' <- newMVar S.empty
+    let withSerializer :: IO a -> IO a
+        withSerializer act = maybe act (\lock -> withMVar lock (const act)) mSerializer
     let ctx = JSContextRef {
             contextId = contextId'
           , startTime = startTime'
@@ -210,8 +235,7 @@ runJavaScript sendBatch entryPoint = do
                 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
                 _ <- tryTakeMVar lastAsyncBatch
                 putMVar lastAsyncBatch batch
-                sendBatch batch
-                takeResult recvMVar nBatch >>= \case
+                withSerializer (sendBatch batch >> takeResult recvMVar nBatch) >>= \case
                     (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"
                     (_, Success callbacksToFree results)
                            | length results /= length resultMVars -> error "Unexpected number of jsaddle results"