diff --git a/cbits-cocoa/AppDelegate.m b/cbits-cocoa/AppDelegate.m --- a/cbits-cocoa/AppDelegate.m +++ b/cbits-cocoa/AppDelegate.m @@ -2,10 +2,12 @@ #import #import -extern void callIO(HsStablePtr); -extern bool callWithCStringReturningBool(const char * _Nonnull, HsStablePtr); -extern void callWithCString(const char * _Nonnull, HsStablePtr); -extern void callWithWebView(WKWebView *, HsStablePtr); +// The Haskell callbacks come through the registered jsaddleCallbacks table +// (see cbits/WKWebView-callbacks.h for why they are not extern symbols). The +// table itself is defined in WKWebView-cbits.m, which the composite Cocoa +// translation unit #includes before this file; the header is included here +// anyway (it is #pragma once) so this file does not depend on that order. +#include "../cbits/WKWebView-callbacks.h" @interface AppDelegate : NSObject @property (nonatomic, assign) IBOutlet NSWindow *window; @@ -41,7 +43,9 @@ } -(BOOL)application:(NSApplication *)sender openFile:(NSString *)filename { - bool b = callWithCStringReturningBool([filename UTF8String], global_applicationOpenFile); + bool b = jsaddleCallbacks.callWithCStringReturningBool + ? jsaddleCallbacks.callWithCStringReturningBool([filename UTF8String], global_applicationOpenFile) + : false; return b ? YES : NO; } @@ -52,8 +56,16 @@ } WKWebView *webView = [[WKWebView alloc] initWithFrame: [_window.contentView frame] configuration:theConfiguration]; [_window setContentView:webView]; - callWithWebView(webView, _handler); - callIO(global_willFinishLaunchingWithOptions); + if (jsaddleCallbacks.callWithWebView) + jsaddleCallbacks.callWithWebView((void *)webView, _handler); + if (jsaddleCallbacks.callIO) + jsaddleCallbacks.callIO(global_willFinishLaunchingWithOptions); + // Balance the allocs above: -setContentView: retained the webview, so the + // window is its sole owner from here. Without these releases the boot + // webview — and its WebContent renderer process — outlives the window + // forever. After the callbacks, so nothing reads webView post-release. + [webView release]; + [theConfiguration release]; // Listen to URL events NSAppleEventManager *manager = [NSAppleEventManager sharedAppleEventManager]; [manager @@ -65,14 +77,16 @@ - (void)applicationUniversalLink:(NSAppleEventDescriptor *)event { NSString *url = [[event paramDescriptorForKeyword:keyDirectObject] stringValue]; - callWithCString([url UTF8String], global_applicationUniversalLink); + if (jsaddleCallbacks.callWithCString) + jsaddleCallbacks.callWithCString([url UTF8String], global_applicationUniversalLink); } -(void)applicationDidFinishLaunching:(NSNotification *)notification { [_window orderFrontRegardless]; [_window center]; [NSApp activateIgnoringOtherApps:YES]; - callIO(global_didFinishLaunchingWithOptions); + if (jsaddleCallbacks.callIO) + jsaddleCallbacks.callIO(global_didFinishLaunchingWithOptions); } -(BOOL) applicationShouldTerminateAfterLastWindowClosed:(NSApplication *)app { diff --git a/cbits-cocoa/WKWebView-AppDelegate.m b/cbits-cocoa/WKWebView-AppDelegate.m new file mode 100644 --- /dev/null +++ b/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" diff --git a/cbits-uikit/AppDelegate.m b/cbits-uikit/AppDelegate.m --- a/cbits-uikit/AppDelegate.m +++ b/cbits-uikit/AppDelegate.m @@ -3,9 +3,9 @@ #import #import -extern void callIO(HsStablePtr); -extern void callWithCString(const char * _Nonnull, HsStablePtr); -extern void callWithCIntCString(int n, const char * _Nonnull, HsStablePtr); +// The Haskell callbacks come through the registered jsaddleCallbacks table +// (see cbits/WKWebView-callbacks.h for why they are not extern symbols). +#include "../cbits/WKWebView-callbacks.h" @interface AppDelegate () @@ -35,7 +35,7 @@ - (BOOL)application:(UIApplication *)application willFinishLaunchingWithOptions:(NSDictionary *)launchOptions { // Tells the delegate that the launch process has begun but that state restoration has not yet occurred. - callIO(global_willFinishLaunchingWithOptions); + if (jsaddleCallbacks.callIO) jsaddleCallbacks.callIO(global_willFinishLaunchingWithOptions); return YES; } @@ -70,45 +70,45 @@ [application registerForRemoteNotifications]; } } - callIO(global_didFinishLaunchingWithOptions); + if (jsaddleCallbacks.callIO) jsaddleCallbacks.callIO(global_didFinishLaunchingWithOptions); return YES; } - (void)applicationWillResignActive:(UIApplication *)application { // Sent when the application is about to move from active to inactive state. This can occur for certain types of temporary interruptions (such as an incoming phone call or SMS message) or when the user quits the application and it begins the transition to the background state. // Use this method to pause ongoing tasks, disable timers, and invalidate graphics rendering callbacks. Games should use this method to pause the game. - callIO(global_applicationWillResignActive); + if (jsaddleCallbacks.callIO) jsaddleCallbacks.callIO(global_applicationWillResignActive); } - (void)applicationDidEnterBackground:(UIApplication *)application { // Use this method to release shared resources, save user data, invalidate timers, and store enough application state information to restore your application to its current state in case it is terminated later. // If your application supports background execution, this method is called instead of applicationWillTerminate: when the user quits. - callIO(global_applicationDidEnterBackground); + if (jsaddleCallbacks.callIO) jsaddleCallbacks.callIO(global_applicationDidEnterBackground); } - (void)applicationWillEnterForeground:(UIApplication *)application { // Called as part of the transition from the background to the active state; here you can undo many of the changes made on entering the background. - callIO(global_applicationWillEnterForeground); + if (jsaddleCallbacks.callIO) jsaddleCallbacks.callIO(global_applicationWillEnterForeground); } - (void)applicationDidBecomeActive:(UIApplication *)application { // Restart any tasks that were paused (or not yet started) while the application was inactive. If the application was previously in the background, optionally refresh the user interface. - callIO(global_applicationDidBecomeActive); + if (jsaddleCallbacks.callIO) jsaddleCallbacks.callIO(global_applicationDidBecomeActive); } - (void)applicationWillTerminate:(UIApplication *)application { // Called when the application is about to terminate. Save data if appropriate. See also applicationDidEnterBackground:. - callIO(global_applicationWillTerminate); + if (jsaddleCallbacks.callIO) jsaddleCallbacks.callIO(global_applicationWillTerminate); } - (void)application:(UIApplication *)application didRegisterForRemoteNotificationsWithDeviceToken:(NSData *)deviceToken { // Tells the delegate that the app successfully registered with Apple Push Notification service (APNs). NSString *deviceTokenString = [deviceToken base64EncodedStringWithOptions: 0]; - callWithCString([deviceTokenString UTF8String], global_didRegisterForRemoteNotificationsWithDeviceToken); + if (jsaddleCallbacks.callWithCString) jsaddleCallbacks.callWithCString([deviceTokenString UTF8String], global_didRegisterForRemoteNotificationsWithDeviceToken); } - (void)application:(UIApplication *)application didReceiveRemoteNotification:(NSDictionary *)userInfo fetchCompletionHandler:(void (^)(UIBackgroundFetchResult result))completionHandler { @@ -121,7 +121,7 @@ NSData *jsonData = [NSJSONSerialization dataWithJSONObject:userInfo options:0 error:&error]; if (jsonData) { NSString *jsonString = [[NSString alloc] initWithData:jsonData encoding:NSUTF8StringEncoding]; - callWithCIntCString((int) application.applicationState, [jsonString UTF8String], global_applicationDidReceiveRemoteNotification); + if (jsaddleCallbacks.callWithCIntCString) jsaddleCallbacks.callWithCIntCString((int) application.applicationState, [jsonString UTF8String], global_applicationDidReceiveRemoteNotification); } else { NSLog(@"jsaddle-wkwebview didReceiveRemoteNotification handler: error while serialising push notification as JSON"); } @@ -131,19 +131,19 @@ - (void)application:(UIApplication *)application didFailToRegisterForRemoteNotificationsWithError:(NSError *)error { // Sent to the delegate when Apple Push Notification service cannot successfully complete the registration process. NSString *errorString = [error localizedDescription]; - callWithCString([errorString UTF8String], global_didFailToRegisterForRemoteNotificationsWithError); + if (jsaddleCallbacks.callWithCString) jsaddleCallbacks.callWithCString([errorString UTF8String], global_didFailToRegisterForRemoteNotificationsWithError); } - (void)applicationSignificantTimeChange:(UIApplication *)application { // Tells the delegate when there is a significant change in the time. - callIO(global_applicationSignificantTimeChange); + if (jsaddleCallbacks.callIO) jsaddleCallbacks.callIO(global_applicationSignificantTimeChange); } - (BOOL)application:(UIApplication *)application continueUserActivity:(NSUserActivity *)userActivity restorationHandler:(void (^)(NSArray *restorableObjects))restorationHandler { // TODO: Reroute universal links when they're clicked in-app. // https://developer.apple.com/reference/webkit/wknavigationdelegate/1455643-webview?language=objc if ([userActivity.activityType isEqualToString:NSUserActivityTypeBrowsingWeb] && userActivity.webpageURL) { - callWithCString([userActivity.webpageURL.absoluteString UTF8String], global_applicationUniversalLink); + if (jsaddleCallbacks.callWithCString) jsaddleCallbacks.callWithCString([userActivity.webpageURL.absoluteString UTF8String], global_applicationUniversalLink); return YES; } return NO; diff --git a/cbits-uikit/ViewController.m b/cbits-uikit/ViewController.m --- a/cbits-uikit/ViewController.m +++ b/cbits-uikit/ViewController.m @@ -1,6 +1,7 @@ #import "ViewController.h" -extern void callWithWebView(WKWebView *, HsStablePtr); +// See cbits/WKWebView-callbacks.h: Haskell callbacks are registered, not extern. +#include "../cbits/WKWebView-callbacks.h" @interface ViewController () @@ -27,7 +28,7 @@ - (void)viewDidLoad { [super viewDidLoad]; - callWithWebView(_webView, _handler); + if (jsaddleCallbacks.callWithWebView) jsaddleCallbacks.callWithWebView((void *)_webView, _handler); } diff --git a/cbits/WKWebView-callbacks.h b/cbits/WKWebView-callbacks.h new file mode 100644 --- /dev/null +++ b/cbits/WKWebView-callbacks.h @@ -0,0 +1,32 @@ +// Haskell callbacks for the jsaddle-wkwebview Objective-C. +// +// These are registered at runtime by the Haskell side +// (jsaddle_wk_set_callbacks, called from +// Language.Javascript.JSaddle.WKWebView.Internal.registerJSaddleCallbacks +// before anything can fire a callback) rather than linked as extern foreign +// exports. On toolchains where GHCi's RTS linker loads this package's +// archive, the foreign exports are not dyld-visible — and the ObjC, which +// must then be loaded by dyld for its classes to be registered with the +// Objective-C runtime (e.g. compiled into a dylib and preloaded with +// ghci -L -l; see the objc-in-library cabal flag), could not +// reference them by name. Function pointers created with +// `foreign import ccall "wrapper"` are callable from both worlds, and +// behave identically in an ordinarily compiled application. +#pragma once +#include "HsFFI.h" +#include + +typedef struct { + void (*jsaddleStart)(HsStablePtr); + void (*jsaddleResult)(HsStablePtr, const char * _Nonnull); + void (*jsaddleSyncResult)(HsStablePtr, void * _Nonnull handler, const char * _Nonnull); + void (*callIO)(HsStablePtr); + void (*callWithCString)(const char * _Nonnull, HsStablePtr); + bool (*callWithCStringReturningBool)(const char * _Nonnull, HsStablePtr); + void (*callWithWebView)(void * _Nonnull webView, HsStablePtr); + void (*callWithCIntCString)(int, const char * _Nonnull, HsStablePtr); +} jsaddle_wk_callbacks; + +// Defined in WKWebView-cbits.m (one definition; the iOS build compiles the +// sources as separate translation units, so it cannot be static there). +extern jsaddle_wk_callbacks jsaddleCallbacks; diff --git a/cbits/WKWebView-cbits.m b/cbits/WKWebView-cbits.m new file mode 100644 --- /dev/null +++ b/cbits/WKWebView-cbits.m @@ -0,0 +1,198 @@ +#include "HsFFI.h" +#import +#import + +BOOL openApp(NSURL * url); + +@interface JSaddleHandler : NSObject + +@property (nonatomic, assign) HsStablePtr startHandler; +@property (nonatomic, assign) HsStablePtr resultHandler; +@property (nonatomic, assign) HsStablePtr syncHandler; +@property (nonatomic, assign) void (^completionHandler)(NSString *result); + +- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler syncHandler:(HsStablePtr)syncHandler; + +@end + +// The Haskell callbacks come through the registered jsaddleCallbacks table — +// see WKWebView-callbacks.h for why they are not extern symbol references. +#include "WKWebView-callbacks.h" + +jsaddle_wk_callbacks jsaddleCallbacks; // zero-initialised + +void jsaddle_wk_set_callbacks( + void (*jsaddleStart_)(HsStablePtr), + void (*jsaddleResult_)(HsStablePtr, const char * _Nonnull), + void (*jsaddleSyncResult_)(HsStablePtr, void * _Nonnull, const char * _Nonnull), + void (*callIO_)(HsStablePtr), + void (*callWithCString_)(const char * _Nonnull, HsStablePtr), + bool (*callWithCStringReturningBool_)(const char * _Nonnull, HsStablePtr), + void (*callWithWebView_)(void * _Nonnull, HsStablePtr), + void (*callWithCIntCString_)(int, const char * _Nonnull, HsStablePtr)) +{ + jsaddleCallbacks.jsaddleStart = jsaddleStart_; + jsaddleCallbacks.jsaddleResult = jsaddleResult_; + jsaddleCallbacks.jsaddleSyncResult = jsaddleSyncResult_; + jsaddleCallbacks.callIO = callIO_; + jsaddleCallbacks.callWithCString = callWithCString_; + jsaddleCallbacks.callWithCStringReturningBool = callWithCStringReturningBool_; + jsaddleCallbacks.callWithWebView = callWithWebView_; + jsaddleCallbacks.callWithCIntCString = callWithCIntCString_; +} + +@implementation JSaddleHandler + +- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler syncHandler:(HsStablePtr)syncHandler +{ + self = [super init]; + if (self) { + _startHandler = startHandler; + _resultHandler = resultHandler; + _syncHandler = syncHandler; + } + return self; +} + +// The stable-pointer checks in the three handler methods below cover the +// window between removeJSaddleHandler freeing them (setting them to NULL) and +// the last WebKit delivery already in flight: dereferencing a freed +// StablePtr is undefined, ignoring a message for a detached context is not. +- (void)webView:(WKWebView *)webView didFinishNavigation:(WKNavigation *)navigation +{ + if (jsaddleCallbacks.jsaddleStart && self.startHandler) + jsaddleCallbacks.jsaddleStart(self.startHandler); +} + +- (void)userContentController:(WKUserContentController *)userContentController didReceiveScriptMessage:(WKScriptMessage *)message +{ + NSString * s = (NSString *) message.body; + if (jsaddleCallbacks.jsaddleResult && self.resultHandler) + jsaddleCallbacks.jsaddleResult(self.resultHandler, [s UTF8String]); +} + +- (void)webView:(WKWebView *)webView runJavaScriptTextInputPanelWithPrompt:(NSString *)prompt + defaultText:(NSString *)defaultText initiatedByFrame:(WKFrameInfo *)frame completionHandler:(void (^)(NSString *result))completionHandler +{ + if([prompt isEqualToString:@"JSaddleSync"]) { + if (jsaddleCallbacks.jsaddleSyncResult && self.syncHandler) { + _completionHandler = completionHandler; + jsaddleCallbacks.jsaddleSyncResult(self.syncHandler, (void *)self, [defaultText UTF8String]); + } + else + completionHandler(@""); // detached context: unblock the page + } + else { + // TODO decide what if anything should go here + } +} + +- (void)webView:(WKWebView *)webView decidePolicyForNavigationAction:(WKNavigationAction *)navigationAction decisionHandler:(void (^)(WKNavigationActionPolicy))decisionHandler +{ + NSURL *url = navigationAction.request.URL; + + if(!navigationAction.targetFrame && ![url.scheme isEqualToString:@"file"]) { + if(openApp(url)) + decisionHandler(WKNavigationActionPolicyCancel); + else + decisionHandler(WKNavigationActionPolicyAllow); + } + else + decisionHandler(WKNavigationActionPolicyAllow); +} + +@end + +// Returns the handler (retained: the caller's reference, released by +// removeJSaddleHandler) so a host that tears a webview down can detach it +// again — see removeJSaddleHandler. +JSaddleHandler * addJSaddleHandler(WKWebView *webView, HsStablePtr startHandler, HsStablePtr resultHandler, HsStablePtr syncHandler) { + JSaddleHandler * handler = [[JSaddleHandler alloc] initHandler:startHandler resultHandler:resultHandler syncHandler:syncHandler]; + [[[webView configuration] userContentController] addScriptMessageHandler:handler name:@"jsaddle"]; +#ifdef USE_UIKIT + webView.scrollView.bounces = NO; +#endif + webView.navigationDelegate = handler; + webView.UIDelegate = handler; + return handler; +} + +// Detach a handler installed by addJSaddleHandler and free the three stable +// pointers it holds. Those pointers keep their closures — and through them the +// context's whole callback graph (for a reflex application, the entire live +// network) — alive for the life of the PROCESS, which in ghci mode means every +// reloaded instance's network stays reachable: measured at ~30MB of live heap +// leaked per reload. +// +// On the MAIN QUEUE, because that is where all three callbacks are delivered +// from: running the detach there is what makes it mutually exclusive with a +// callback that is mid-flight, so the frees cannot race a deRefStablePtr. +// Asynchronously, because the caller may be a Haskell thread that the main +// thread is (or is about to be) waiting on — a dispatch_sync from the jsaddle +// sync round trip's own producer would deadlock. The block retains both +// objects, so the host may release the webview as soon as this returns. +// @onDetached@ is run (once) after the handler is detached; freeing the three +// stable pointers is its job, not this file's. Calling the RTS directly here +// is not an option: in ghci mode this file is compiled into a plain dylib with +// no RTS to link against, so hs_free_stable_ptr is an undefined symbol — the +// same constraint that makes every Haskell call out of this file go through the +// registered callback table (see WKWebView-callbacks.h). +void removeJSaddleHandler(WKWebView *webView, JSaddleHandler *handler, HsStablePtr onDetached) { + dispatch_async(dispatch_get_main_queue(), ^{ + [[[webView configuration] userContentController] removeScriptMessageHandlerForName:@"jsaddle"]; + if (webView.navigationDelegate == handler) webView.navigationDelegate = nil; + if (webView.UIDelegate == handler) webView.UIDelegate = nil; + // Clear before the pointers are freed, so a delivery WebKit had already + // queued behind this block sees a detached handler (the methods above + // check) rather than a dangling stable pointer. + handler.startHandler = NULL; + handler.resultHandler = NULL; + handler.syncHandler = NULL; + [handler release]; // balances addJSaddleHandler's +1 + if (jsaddleCallbacks.callIO) + jsaddleCallbacks.callIO(onDetached); + }); +} + +void evaluateJavaScript(WKWebView *webView, const char * _Nonnull js) { + NSString *jsString = [[NSString alloc] initWithCString:js encoding:NSUTF8StringEncoding]; + dispatch_async(dispatch_get_main_queue(), ^{ + [webView evaluateJavaScript:jsString completionHandler:NULL]; + [jsString release]; + }); +} + +void completeSync(JSaddleHandler *handler, const char * _Nonnull s) { + NSString *string = [[NSString alloc] initWithCString:s encoding:NSUTF8StringEncoding]; + handler.completionHandler(string); + handler.completionHandler = NULL; + [string release]; +} + +void loadHTMLStringWithBaseURL(WKWebView *webView, const char * _Nonnull html, const char * _Nonnull url) { + NSString *htmlString = [NSString stringWithCString:html encoding:NSUTF8StringEncoding]; + NSURL *baseURL = [NSURL URLWithString:[NSString stringWithCString:url encoding:NSUTF8StringEncoding]]; + dispatch_async(dispatch_get_main_queue(), ^{ + [webView loadHTMLString:htmlString baseURL:baseURL]; + }); +} + +const char * mainBundleResourcePathC() { + NSBundle *main = [NSBundle mainBundle]; + if(!main) return NULL; + NSString *path = main.resourcePath; + if(!path) return NULL; + return [path UTF8String]; +} + +void loadBundleFile(WKWebView *webView, const char * _Nonnull file, const char * _Nonnull allowing) { + NSBundle *main = [NSBundle mainBundle]; + if(main) { + NSString *path = main.resourcePath; + if(path) { + NSURL *fileUrl = [NSURL fileURLWithPath:[NSString stringWithFormat: @"%@/%@", path, [NSString stringWithCString:file encoding:NSUTF8StringEncoding]]]; + NSURL *allowingUrl = [NSURL fileURLWithPath:[NSString stringWithFormat: @"%@/%@", path, [NSString stringWithCString:allowing encoding:NSUTF8StringEncoding]]]; + [webView loadFileURL:fileUrl allowingReadAccessToURL:allowingUrl]; + } + } +} diff --git a/cbits/WKWebView.m b/cbits/WKWebView.m deleted file mode 100644 --- a/cbits/WKWebView.m +++ /dev/null @@ -1,124 +0,0 @@ -#include "HsFFI.h" -#import -#import - -BOOL openApp(NSURL * url); - -@interface JSaddleHandler : NSObject - -@property (nonatomic, assign) HsStablePtr startHandler; -@property (nonatomic, assign) HsStablePtr resultHandler; -@property (nonatomic, assign) HsStablePtr syncHandler; -@property (nonatomic, assign) void (^completionHandler)(NSString *result); - -- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler syncHandler:(HsStablePtr)syncHandler; - -@end - -extern void jsaddleStart(HsStablePtr); -extern void jsaddleResult(HsStablePtr, const char * _Nonnull result); -extern void jsaddleSyncResult(HsStablePtr, JSaddleHandler *, const char * _Nonnull result); - -@implementation JSaddleHandler - -- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler syncHandler:(HsStablePtr)syncHandler -{ - self = [super init]; - if (self) { - _startHandler = startHandler; - _resultHandler = resultHandler; - _syncHandler = syncHandler; - } - return self; -} - -- (void)webView:(WKWebView *)webView didFinishNavigation:(WKNavigation *)navigation -{ - jsaddleStart(self.startHandler); -} - -- (void)userContentController:(WKUserContentController *)userContentController didReceiveScriptMessage:(WKScriptMessage *)message -{ - NSString * s = (NSString *) message.body; - jsaddleResult(self.resultHandler, [s UTF8String]); -} - -- (void)webView:(WKWebView *)webView runJavaScriptTextInputPanelWithPrompt:(NSString *)prompt - defaultText:(NSString *)defaultText initiatedByFrame:(WKFrameInfo *)frame completionHandler:(void (^)(NSString *result))completionHandler -{ - if([prompt isEqualToString:@"JSaddleSync"]) { - _completionHandler = completionHandler; - jsaddleSyncResult(self.syncHandler, self, [defaultText UTF8String]); - } - else { - // TODO decide what if anything should go here - } -} - -- (void)webView:(WKWebView *)webView decidePolicyForNavigationAction:(WKNavigationAction *)navigationAction decisionHandler:(void (^)(WKNavigationActionPolicy))decisionHandler -{ - NSURL *url = navigationAction.request.URL; - - if(!navigationAction.targetFrame && ![url.scheme isEqualToString:@"file"]) { - if(openApp(url)) - decisionHandler(WKNavigationActionPolicyCancel); - else - decisionHandler(WKNavigationActionPolicyAllow); - } - else - decisionHandler(WKNavigationActionPolicyAllow); -} - -@end - -void addJSaddleHandler(WKWebView *webView, HsStablePtr startHandler, HsStablePtr resultHandler, HsStablePtr syncHandler) { - JSaddleHandler * handler = [[JSaddleHandler alloc] initHandler:startHandler resultHandler:resultHandler syncHandler:syncHandler]; - [[[webView configuration] userContentController] addScriptMessageHandler:handler name:@"jsaddle"]; -#ifdef USE_UIKIT - webView.scrollView.bounces = NO; -#endif - webView.navigationDelegate = handler; - webView.UIDelegate = handler; -} - -void evaluateJavaScript(WKWebView *webView, const char * _Nonnull js) { - NSString *jsString = [[NSString alloc] initWithCString:js encoding:NSUTF8StringEncoding]; - dispatch_async(dispatch_get_main_queue(), ^{ - [webView evaluateJavaScript:jsString completionHandler:NULL]; - [jsString release]; - }); -} - -void completeSync(JSaddleHandler *handler, const char * _Nonnull s) { - NSString *string = [[NSString alloc] initWithCString:s encoding:NSUTF8StringEncoding]; - handler.completionHandler(string); - handler.completionHandler = NULL; -} - -void loadHTMLStringWithBaseURL(WKWebView *webView, const char * _Nonnull html, const char * _Nonnull url) { - NSString *htmlString = [NSString stringWithCString:html encoding:NSUTF8StringEncoding]; - NSURL *baseURL = [NSURL URLWithString:[[NSString alloc] initWithCString:url encoding:NSUTF8StringEncoding]]; - dispatch_async(dispatch_get_main_queue(), ^{ - [webView loadHTMLString:htmlString baseURL:baseURL]; - }); -} - -const char * mainBundleResourcePathC() { - NSBundle *main = [NSBundle mainBundle]; - if(!main) return NULL; - NSString *path = main.resourcePath; - if(!path) return NULL; - return [path UTF8String]; -} - -void loadBundleFile(WKWebView *webView, const char * _Nonnull file, const char * _Nonnull allowing) { - NSBundle *main = [NSBundle mainBundle]; - if(main) { - NSString *path = main.resourcePath; - if(path) { - NSURL *fileUrl = [NSURL fileURLWithPath:[NSString stringWithFormat: @"%@/%@", path, [NSString stringWithCString:file encoding:NSUTF8StringEncoding]]]; - NSURL *allowingUrl = [NSURL fileURLWithPath:[NSString stringWithFormat: @"%@/%@", path, [NSString stringWithCString:allowing encoding:NSUTF8StringEncoding]]]; - [webView loadFileURL:fileUrl allowingReadAccessToURL:allowingUrl]; - } - } -} diff --git a/jsaddle-wkwebview.cabal b/jsaddle-wkwebview.cabal --- a/jsaddle-wkwebview.cabal +++ b/jsaddle-wkwebview.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: jsaddle-wkwebview -version: 0.9.9.3 +version: 0.9.10.0 build-type: Simple license: MIT license-file: LICENSE @@ -13,12 +13,34 @@ drive a small JavaScipt helper. 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 +tested-with: GHC==9.14.1, GHC==9.12.4, GHC==9.10.3, GHC==9.8.4, GHC==9.6.7 +-- #included by cbits-cocoa/WKWebView-AppDelegate.m (the single Cocoa +-- translation unit) rather than compiled directly, so they must be +-- shipped explicitly. (WKWebView-callbacks.h is #included everywhere.) +extra-source-files: + cbits/WKWebView-cbits.m + cbits/WKWebView-callbacks.h + cbits-cocoa/AppDelegate.m + flag include-app-delegate description: Include default AppDelegate C sources. default: True +flag objc-in-library + description: + Compile the Objective-C into the Haskell library (the default). + Disable for GHCi sessions on toolchains where the RTS linker loads + this library's archive: Objective-C classes are only registered with + the runtime when their image is loaded by dyld, so such a session + must instead preload the ObjC compiled as a dylib (e.g. + cc -dynamiclib cbits-cocoa/WKWebView-AppDelegate.m -DUSE_COCOA + -Icbits ... and ghci -L -l); the Haskell side then + reaches it through dyld, and it calls back in through the FunPtrs + registered by registerJSaddleCallbacks. + default: True + manual: True + source-repository head type: git location: https://github.com/ghcjs/jsaddle @@ -31,36 +53,59 @@ default-language: Haskell2010 hs-source-dirs: src ghc-options: -ferror-spans -Wall - if os(linux) + -- Native builds need the Foundation/WebKit frameworks: macOS and iOS + -- only. (The ghcjs/javascript branch below builds anywhere.) + if !os(osx) && !os(ios) && !impl(ghcjs) && !arch(javascript) buildable: False if impl(ghcjs) || arch(javascript) hs-source-dirs: src-ghcjs 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, + jsaddle >= 0.9.10.0 && <0.10, text, data-default, containers 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-uikit/AppDelegate.m - cbits-uikit/ViewController.m + if flag(objc-in-library) + cxx-sources: + cbits/WKWebView-cbits.m + cbits-uikit/AppDelegate.m + cbits-uikit/ViewController.m cpp-options: -DUSE_UIKIT + else + if flag(objc-in-library) + cxx-sources: + cbits/WKWebView-cbits.m else frameworks: Cocoa if flag(include-app-delegate) - cxx-sources: - cbits-cocoa/AppDelegate.m + -- 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. + if flag(objc-in-library) + cxx-sources: + cbits-cocoa/WKWebView-AppDelegate.m cpp-options: -DUSE_COCOA + else + if flag(objc-in-library) + cxx-sources: + cbits/WKWebView-cbits.m diff --git a/src-ghc/Language/Javascript/JSaddle/WKWebView.hs b/src-ghc/Language/Javascript/JSaddle/WKWebView.hs --- a/src-ghc/Language/Javascript/JSaddle/WKWebView.hs +++ b/src-ghc/Language/Javascript/JSaddle/WKWebView.hs @@ -3,6 +3,7 @@ , jsaddleMainHTMLWithBaseURL , jsaddleMainFile , WKWebView(..) + , jsaddleWebViewInvalidate , run , run' , runWithAppConfig @@ -22,7 +23,9 @@ import Data.Word import Foreign.Marshal.Utils (fromBool) import Language.Javascript.JSaddle.WKWebView.Internal - (jsaddleMain, jsaddleMainHTMLWithBaseURL, jsaddleMainFile, WKWebView(..), mainBundleResourcePath) + (jsaddleMain, jsaddleMainHTMLWithBaseURL, jsaddleMainFile, WKWebView(..), + mainBundleResourcePath, registerJSaddleCallbacks, + jsaddleWebViewInvalidate) import System.Environment (getProgName) import Foreign.C.String (CString, withCString) import Foreign.C.Types (CBool, CInt) @@ -163,6 +166,9 @@ -> (WKWebView -> IO ()) -> IO () run' cfg main = do + -- The ObjC side calls Haskell through registered FunPtrs (see Internal); + -- register before runInWKWebView can fire any of them. + registerJSaddleCallbacks handler <- newStablePtr main progName <- getProgName diff --git a/src/Language/Javascript/JSaddle/WKWebView/Internal.hs b/src/Language/Javascript/JSaddle/WKWebView/Internal.hs --- a/src/Language/Javascript/JSaddle/WKWebView/Internal.hs +++ b/src/Language/Javascript/JSaddle/WKWebView/Internal.hs @@ -1,16 +1,25 @@ -{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-} +{-# LANGUAGE ForeignFunctionInterface, LambdaCase, OverloadedStrings, ScopedTypeVariables #-} module Language.Javascript.JSaddle.WKWebView.Internal ( jsaddleMain , jsaddleMainHTMLWithBaseURL , jsaddleMainFile , WKWebView(..) , mainBundleResourcePath + , registerJSaddleCallbacks + , jsaddleWebViewInvalidate ) where -import Control.Monad (void, join) -import Control.Concurrent (forkIO, forkOS) -import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Monad (void, join, unless) +import Control.Concurrent (forkIO, forkOS, threadDelay) +import Control.Exception (IOException, finally, handle, mask) +import Control.Concurrent.MVar + (MVar, modifyMVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, readMVar, + takeMVar, tryPutMVar, tryTakeMVar, withMVar) +import Data.IORef (newIORef, readIORef, writeIORef, atomicModifyIORef') + +import System.IO.Unsafe (unsafePerformIO) + import Data.Monoid ((<>)) import Data.ByteString (useAsCString, packCString) import qualified Data.ByteString as BS (ByteString) @@ -21,11 +30,13 @@ import Foreign.C.String (CString) import Foreign.C.Types (CBool(..), CInt(..)) -import Foreign.Ptr (Ptr, nullPtr) -import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr) +import Foreign.Ptr (Ptr, FunPtr, nullPtr) +import Foreign.StablePtr + (StablePtr, newStablePtr, deRefStablePtr, freeStablePtr) -import Language.Javascript.JSaddle (Results, Batch, JSM) -import Language.Javascript.JSaddle.Run (runJavaScript) +import Language.Javascript.JSaddle (Results, JSM) +import Language.Javascript.JSaddle.Types (Batch(..)) +import Language.Javascript.JSaddle.Run (runJavaScriptWithSerializer) import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers) import System.Directory (getCurrentDirectory) @@ -33,6 +44,88 @@ 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 ()) + +-- | Run an invalidation while holding 'wkWebViewBatchLock', so it cannot +-- land in the middle of one of this context's round trips. +-- +-- 'runJavaScriptWithSerializer' holds the lock from a batch's send until its +-- REPLY arrives. Closing the gate only waits for the send (the 'aliveVar' +-- section around @evaluateJavaScript@); if it then closed while that batch's +-- reply was still on its way, the reply would be dropped — the inbound gate +-- discards it and the handler is detached — and the batch thread would wait +-- for it forever, STILL HOLDING THE LOCK. Every other webview in the process +-- then hangs on its next round trip. (Seen in a multi-window app closing one +-- window at a time: the remaining windows froze for 26s, 85s, or until +-- restart — whenever the GC got round to noticing the orphaned wait.) Taking +-- the lock first means any round trip already under way finishes before the +-- gate closes, and none can start until it has. +-- +-- Bounded: a round trip that never completes (a wedged page) would otherwise +-- block the invalidation forever. After ~5s it closes the gate without the +-- lock, as before. Polled with 'tryTakeMVar' rather than 'timeout' around +-- 'takeMVar': the timeout's exception can arrive just after the take has +-- succeeded and lose the lock for good. +-- +-- Must not run on the main thread: the reply this waits for is delivered +-- there. +withBatchLockBounded :: IO () -> IO () +withBatchLockBounded act = go (50 :: Int) + where + go n = mask $ \restore -> + tryTakeMVar wkWebViewBatchLock >>= \case + Just () -> restore act `finally` putMVar wkWebViewBatchLock () + Nothing + | n <= 0 -> restore act + | otherwise -> restore (threadDelay 100000) >> go (n - 1) + +-- | Per-context invalidators, keyed by the raw webview pointer each context +-- sends its batches to. 'jsaddleWebViewInvalidate' runs (and drops) a +-- webview's entries so the host application can safely release the webview: +-- until then jsaddle's threads keep calling 'evaluateJavaScript' with the +-- stored pointer, and releasing the webview under them is a use-after-free. +{-# NOINLINE contextInvalidators #-} +contextInvalidators :: MVar [(Ptr WKWebView, IO ())] +contextInvalidators = unsafePerformIO (newMVar []) + +-- | Invalidate every jsaddle context attached to @webView@: no jsaddle thread +-- will touch the webview pointer after this returns, so the host may release +-- the webview (and let its WebContent renderer process exit). Blocks until +-- any batch round trip already under way — in ANY context, since they share +-- 'wkWebViewBatchLock' — has had its reply (bounded; see +-- 'withBatchLockBounded'), so call it OFF the main thread, where those replies +-- are delivered. The contexts' Haskell threads are not stopped — their +-- subsequent sends throw instead (a dropped send would leave jsaddle's batch +-- thread waiting for a reply forever while holding 'wkWebViewBatchLock', +-- deadlocking every other window; see 'jsaddleMain''). +-- +-- Also detaches each context's ObjC handler and frees the stable pointers it +-- holds, which is what makes an invalidated context COLLECTABLE — see +-- @removeJSaddleHandler@ in cbits/WKWebView-cbits.m. Without it the callback +-- closures, and through them the context's entire object graph, are pinned for +-- the life of the process. +-- +-- Call it once per webview: the registry entries are claimed under the lock, so +-- a second concurrent call for the SAME webview finds nothing and returns while +-- the first is still running (it would not wait for that in-flight send). +jsaddleWebViewInvalidate :: WKWebView -> IO () +jsaddleWebViewInvalidate (WKWebView ptr) = do + -- CLAIM under the lock, RUN outside it. An invalidator blocks until this + -- context's in-flight send finishes; holding the registry across that would + -- stall every other webview's invalidation — and every new context's + -- registration, which 'jsaddleMain'' does on the same MVar during startup. + invs <- modifyMVar contextInvalidators $ \invs -> + return (filter ((/= ptr) . fst) invs, [ inv | (p, inv) <- invs, p == ptr ]) + sequence_ invs + 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 () @@ -41,7 +134,69 @@ foreign export ccall callWithCString :: CString -> StablePtr (CString -> IO ()) -> IO () foreign export ccall callWithCStringReturningBool :: CString -> StablePtr (CString -> IO CBool) -> IO CBool foreign export ccall callIO :: StablePtr (IO ()) -> IO () -foreign import ccall addJSaddleHandler :: WKWebView -> StablePtr (IO ()) -> StablePtr (Results -> IO ()) -> StablePtr (Results -> IO Batch) -> IO () + +-- The Objective-C side calls back into Haskell through function pointers +-- registered with 'registerJSaddleCallbacks' rather than through the foreign +-- exports above (kept for compatibility): on toolchains where GHCi's RTS +-- linker loads this package's archive, the exports are not dyld-visible, so +-- ObjC compiled into a dylib (necessary there for its classes to be +-- registered with the ObjC runtime; see the objc-in-library cabal flag) +-- could not reference them. See cbits/WKWebView-callbacks.h. +foreign import ccall "wrapper" mkStablePtrIOCb + :: (StablePtr (IO ()) -> IO ()) + -> IO (FunPtr (StablePtr (IO ()) -> IO ())) +foreign import ccall "wrapper" mkResultCb + :: (StablePtr (Results -> IO ()) -> CString -> IO ()) + -> IO (FunPtr (StablePtr (Results -> IO ()) -> CString -> IO ())) +foreign import ccall "wrapper" mkSyncResultCb + :: (StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()) + -> IO (FunPtr (StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ())) +foreign import ccall "wrapper" mkCStringCb + :: (CString -> StablePtr (CString -> IO ()) -> IO ()) + -> IO (FunPtr (CString -> StablePtr (CString -> IO ()) -> IO ())) +foreign import ccall "wrapper" mkCStringBoolCb + :: (CString -> StablePtr (CString -> IO CBool) -> IO CBool) + -> IO (FunPtr (CString -> StablePtr (CString -> IO CBool) -> IO CBool)) +foreign import ccall "wrapper" mkWebViewCb + :: (WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()) + -> IO (FunPtr (WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ())) +foreign import ccall "wrapper" mkCIntCStringCb + :: (CInt -> CString -> StablePtr (CInt -> CString -> IO ()) -> IO ()) + -> IO (FunPtr (CInt -> CString -> StablePtr (CInt -> CString -> IO ()) -> IO ())) +foreign import ccall "jsaddle_wk_set_callbacks" c_jsaddleWkSetCallbacks + :: FunPtr (StablePtr (IO ()) -> IO ()) + -> FunPtr (StablePtr (Results -> IO ()) -> CString -> IO ()) + -> FunPtr (StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()) + -> FunPtr (StablePtr (IO ()) -> IO ()) + -> FunPtr (CString -> StablePtr (CString -> IO ()) -> IO ()) + -> FunPtr (CString -> StablePtr (CString -> IO CBool) -> IO CBool) + -> FunPtr (WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()) + -> FunPtr (CInt -> CString -> StablePtr (CInt -> CString -> IO ()) -> IO ()) + -> IO () + +{-# NOINLINE callbacksRegistered #-} +callbacksRegistered :: MVar Bool +callbacksRegistered = unsafePerformIO (newMVar False) + +-- | Register the Haskell callbacks with the Objective-C side. Idempotent; +-- run before anything can trigger a callback (jsaddleMain' and run' call it). +-- The FunPtrs live for the life of the process. +registerJSaddleCallbacks :: IO () +registerJSaddleCallbacks = modifyMVar_ callbacksRegistered $ \done -> do + unless done $ do + start <- mkStablePtrIOCb jsaddleStart + result <- mkResultCb jsaddleResult + sync <- mkSyncResultCb jsaddleSyncResult + io <- mkStablePtrIOCb callIO + cstr <- mkCStringCb callWithCString + cstrb <- mkCStringBoolCb callWithCStringReturningBool + webv <- mkWebViewCb callWithWebView + cint <- mkCIntCStringCb callWithCIntCString + c_jsaddleWkSetCallbacks start result sync io cstr cstrb webv cint + return True + +foreign import ccall addJSaddleHandler :: WKWebView -> StablePtr (IO ()) -> StablePtr (Results -> IO ()) -> StablePtr (Results -> IO Batch) -> IO JSaddleHandler +foreign import ccall removeJSaddleHandler :: WKWebView -> JSaddleHandler -> StablePtr (IO ()) -> IO () foreign import ccall loadHTMLStringWithBaseURL :: WKWebView -> CString -> CString -> IO () foreign import ccall loadBundleFile :: WKWebView -> CString -> CString -> IO () foreign import ccall evaluateJavaScript :: WKWebView -> CString -> IO () @@ -80,22 +235,112 @@ loadBundleFile webView u a jsaddleMain' :: JSM () -> WKWebView -> IO () -> IO () -jsaddleMain' f webView loadHtml = do +jsaddleMain' f webView@(WKWebView ptr) loadHtml = do + registerJSaddleCallbacks ready <- newEmptyMVar - (processResult, syncResult, start) <- runJavaScript (\batch -> - useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $ - evaluateJavaScript webView) + -- Every use of the raw webview pointer goes through this gate. An MVar + -- (not an IORef) so 'jsaddleWebViewInvalidate' SYNCHRONIZES with an + -- in-flight send: invalidation blocks until the send's evaluateJavaScript + -- call — which copies the pointer into a main-queue block, retaining it — + -- has returned, and no later send can start. After that the host can + -- release the webview with no thread left to dereference it. + aliveVar <- newMVar True + -- This context's pending detach (see @removeJSaddleHandler@), from the + -- moment 'addJSaddleHandler' has installed something to detach until + -- invalidation runs it. Taken and written under @aliveVar@ — by the + -- invalidator below and by the install site — so the detach happens exactly + -- once even if the context is invalidated while it is still being set up. + detachRef <- newIORef Nothing + modifyMVar_ contextInvalidators $ return . + ((ptr, do + -- Close the gate and detach while holding 'wkWebViewBatchLock' + -- (see 'withBatchLockBounded'). Same order as a batch round + -- trip — the lock, then 'aliveVar' inside the send — so this + -- cannot invert against one. + withBatchLockBounded $ + modifyMVar_ aliveVar $ \_ -> do + mbDetach <- atomicModifyIORef' detachRef (\d -> (Nothing, d)) + sequence_ mbDetach + return False + -- Release the startup thread below if the page never signalled + -- ready (invalidated mid-load): nothing else will ever fill this, + -- and it is holding an OS thread and this context's closures. It + -- wakes, hits the now-closed gate and exits. + void $ tryPutMVar ready ()) :) + -- An invalidated context must FAIL its send, not silently drop it. + -- 'runJavaScriptWithSerializer' holds the shared 'wkWebViewBatchLock' + -- across @sendBatch@ AND the @takeResult@ that waits for that batch's + -- reply: a dropped batch leaves its batch thread waiting for a reply that + -- can never arrive, holding the lock every OTHER window needs — so one + -- invalidated context deadlocks the whole process (in ghci mode: every + -- later @:main@ hangs on its first round trip, CPU idle). Throwing + -- unwinds out of 'withMVar', releasing both MVars, and kills only the dead + -- context's own batch pump. + let withWebView act = withMVar aliveVar $ \alive -> + if alive then act + else ioError (userError "jsaddle-wkwebview: context invalidated \ + \(webview released) — batch dropped") + + (processResult, syncResult, start) <- runJavaScriptWithSerializer (Just wkWebViewBatchLock) (\batch -> + withWebView $ + useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $ + evaluateJavaScript webView) f + -- INBOUND must be gated too, or invalidating a context leaks threads without + -- bound. The webview keeps its script-message handler until the host + -- releases it, and a page whose JS is still running keeps posting results; + -- 'runJavaScriptWithSerializer' forks a @processResults@ thread per delivery, + -- and with this context's batch pump gone (killed by the send gate above) + -- every one of them blocks forever on the pump's MVar. Measured before this + -- gate: ~5000 blocked threads PER SECOND, 500k threads and 12GB RSS in one + -- session (and 72GB in a longer one). A dead context simply drops what + -- arrives: nothing is listening for it anyway. + -- + -- The flag is only READ here (not held across the handler): holding it would + -- deadlock the sync path, whose 'readMVar lastAsyncBatch' can wait on the + -- batch thread — which needs this same MVar to send. + let ifAlive :: a -> IO a -> IO a + ifAlive dflt act = readMVar aliveVar >>= \alive -> + if alive then act else return dflt startHandler <- newStablePtr (putMVar ready ()) - resultHandler <- newStablePtr processResult - syncResultHandler <- newStablePtr syncResult - addJSaddleHandler webView startHandler resultHandler syncResultHandler + resultHandler <- newStablePtr (\results -> ifAlive () (processResult results)) + -- An empty batch is what a context with nothing to say returns. + syncResultHandler <- newStablePtr + (\results -> ifAlive (Batch [] False 0) (syncResult results)) + handler <- addJSaddleHandler webView startHandler resultHandler syncResultHandler + -- Freeing the three stable pointers above is what lets an invalidated + -- context be collected: each pins its closure, and those closures capture + -- the whole 'JSContextRef' — for a reflex application, the entire live + -- network. Held for the life of the process (as they were), every instance + -- a ghci session ever ran stays reachable: ~30MB of live heap per reload. + -- Only safe once the ObjC handler can no longer dereference them, so it is + -- @removeJSaddleHandler@ that runs this, after detaching (asynchronously, on + -- the main queue). @selfRef@ lets the callback free its own stable pointer + -- too; it is written before any detach can be requested below. + selfRef <- newIORef Nothing + onDetached <- newStablePtr $ do + freeStablePtr startHandler + freeStablePtr resultHandler + freeStablePtr syncResultHandler + readIORef selfRef >>= mapM_ freeStablePtr + writeIORef selfRef (Just onDetached) + -- Arm the detach for the invalidator — or, if invalidation already happened + -- (it found nothing to detach), detach right here. + let detach = removeJSaddleHandler webView handler onDetached + modifyMVar_ aliveVar $ \alive -> do + if alive then writeIORef detachRef (Just detach) else detach + return alive loadHtml - void . forkOS $ do + -- If the context is invalidated before the page signals ready, the gate + -- throws here; that just means this window died during startup, so swallow + -- it rather than letting forkOS report an unhandled exception. Only that + -- 'IOException' — anything else is a real failure and belongs on stderr. + void . forkOS . handle (\(_ :: IOException) -> return ()) $ do takeMVar ready - useAsCString (toStrict jsaddleJs) (evaluateJavaScript webView) >> void (forkIO start) + withWebView $ useAsCString (toStrict jsaddleJs) (evaluateJavaScript webView) + void (forkIO start) jsaddleStart :: StablePtr (IO ()) -> IO () jsaddleStart ptrHandler = join (deRefStablePtr ptrHandler)