diff --git a/CHANGES.md b/CHANGES.md index 1754b6202c..a891b1cd6a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -85,6 +85,7 @@ * Runtime/wasm: fix unmarshalling of compressed data (#2141) * Runtime: fix compilation of loops at start of exception handlers (#2151) * Compiler: fix parallel renaming (#2156) +* Lib: fix `onbeforeunload` handler breaking navigation (#1436) # 6.2.0 (2025-07-30) - Lille diff --git a/lib/js_of_ocaml/dom.ml b/lib/js_of_ocaml/dom.ml index 82fdf2ffaa..56a588959e 100644 --- a/lib/js_of_ocaml/dom.ml +++ b/lib/js_of_ocaml/dom.ml @@ -437,26 +437,60 @@ class type ['a, 'b] customEvent = object method detail : 'b Js.opt Js.readonly_prop end +class type beforeUnloadEvent = object + inherit [element] event + + method returnValue : js_string t prop +end + let no_handler : ('a, 'b) event_listener = Js.null (* The function preventDefault must be called explicitly when using addEventListener... *) + +(* The [beforeunload] event has special return-value semantics: all modern + browsers show a confirmation dialog when the handler returns any value + other than [null] or [undefined]. When the handler returns [true] (allow + the event), we must return [undefined] to the browser instead of [true] + so that it does not trigger the dialog. When the handler returns [false] + (block the event), we also set [returnValue] for legacy browser compat. *) +let beforeunload_return (e : _ #event t) (res : bool t) : bool t = + let is_beforeunload_event : _ #event t -> bool t = + fun e -> + Js.Unsafe.fun_call + (Js.Unsafe.pure_js_expr + {| (function (e) { return ("type" in e && e.type === "beforeunload") }) |}) + [| Js.Unsafe.coerce e |] + in + if Js.to_bool (is_beforeunload_event e) + then + if Js.to_bool res + then (Obj.magic Js.undefined : bool t) + else begin + (Js.Unsafe.coerce e : beforeUnloadEvent t)##.returnValue := Js.string ""; + res + end + else res + let handler f = Js.some (Js.Unsafe.callback (fun e -> let res = f e in if not (Js.to_bool res) then e##preventDefault; - res)) + beforeunload_return e res)) let full_handler f = Js.some (Js.Unsafe.meth_callback (fun this e -> let res = f this e in if not (Js.to_bool res) then e##preventDefault; - res)) + beforeunload_return e res)) let invoke_handler (f : ('a, 'b) event_listener) (this : 'a) (event : 'b) : bool t = - Js.Unsafe.call f this [| Js.Unsafe.inject event |] + let res = Js.Unsafe.call f this [| Js.Unsafe.inject event |] in + (* Normalize: beforeunload handlers return [undefined] for "allow navigation". + [undefined] is not a valid [bool t], so convert it back to [true]. *) + if Js.Optdef.test (Obj.magic res : bool t Js.optdef) then res else Js._true let eventTarget (e : (< .. > as 'a) #event t) : 'a t = Opt.get e##.target (fun () -> Opt.get e##.srcElement (fun () -> raise Not_found)) diff --git a/lib/js_of_ocaml/dom.mli b/lib/js_of_ocaml/dom.mli index 6515fc8d0e..28f0c47ec7 100644 --- a/lib/js_of_ocaml/dom.mli +++ b/lib/js_of_ocaml/dom.mli @@ -456,6 +456,12 @@ class type ['a, 'b] customEvent = object method detail : 'b Js.opt Js.readonly_prop end +class type beforeUnloadEvent = object + inherit [element] event + + method returnValue : js_string t prop +end + (** {2 Event handlers} *) val no_handler : ('a, 'b) event_listener diff --git a/lib/js_of_ocaml/dom_html.ml b/lib/js_of_ocaml/dom_html.ml index 879df4b868..9f54dae3c9 100644 --- a/lib/js_of_ocaml/dom_html.ml +++ b/lib/js_of_ocaml/dom_html.ml @@ -896,6 +896,12 @@ and eventTarget = object ('self) method dispatchEvent : event t -> bool t meth end +and beforeUnloadEvent = object + inherit event + + method returnValue : js_string t prop +end + and popStateEvent = object inherit event @@ -1527,6 +1533,8 @@ module Event = struct let unload = Dom.Event.make "unload" + (** The event type is [beforeUnloadEvent], which exposes the [returnValue] + property needed to trigger the browser's "leave page?" confirmation dialog. *) let beforeunload = Dom.Event.make "beforeunload" let resize = Dom.Event.make "resize" @@ -3585,7 +3593,7 @@ class type window = object method onunload : (window t, event t) event_listener prop - method onbeforeunload : (window t, event t) event_listener prop + method onbeforeunload : (window t, beforeUnloadEvent t) event_listener prop method onblur : (window t, focusEvent t) event_listener prop diff --git a/lib/js_of_ocaml/dom_html.mli b/lib/js_of_ocaml/dom_html.mli index 2e92b3ee56..b0269e7190 100644 --- a/lib/js_of_ocaml/dom_html.mli +++ b/lib/js_of_ocaml/dom_html.mli @@ -913,6 +913,12 @@ and eventTarget = object ('self) method dispatchEvent : event t -> bool t meth end +and beforeUnloadEvent = object + inherit event + + method returnValue : js_string t prop +end + and popStateEvent = object inherit event @@ -3458,7 +3464,7 @@ class type window = object method onunload : (window t, event t) event_listener prop - method onbeforeunload : (window t, event t) event_listener prop + method onbeforeunload : (window t, beforeUnloadEvent t) event_listener prop method onblur : (window t, focusEvent t) event_listener prop @@ -3660,7 +3666,7 @@ module Event : sig val unload : event t typ - val beforeunload : event t typ + val beforeunload : beforeUnloadEvent t typ val resize : event t typ diff --git a/lib/lwt/lwt_js_events.mli b/lib/lwt/lwt_js_events.mli index 33a578d879..deab1a646d 100644 --- a/lib/lwt/lwt_js_events.mli +++ b/lib/lwt/lwt_js_events.mli @@ -1166,7 +1166,7 @@ val domContentLoaded : unit -> unit Lwt.t val onunload : unit -> Dom_html.event Js.t Lwt.t -val onbeforeunload : unit -> Dom_html.event Js.t Lwt.t +val onbeforeunload : unit -> Dom_html.beforeUnloadEvent Js.t Lwt.t val onresize : unit -> Dom_html.event Js.t Lwt.t diff --git a/lib/tests-browser/test_beforeunload.ml b/lib/tests-browser/test_beforeunload.ml index d209d56927..0c558a2516 100644 --- a/lib/tests-browser/test_beforeunload.ml +++ b/lib/tests-browser/test_beforeunload.ml @@ -17,7 +17,7 @@ let clear_log () = let set_strategy_1 () = clear_log (); Dom_html.window##.onbeforeunload - := Dom_html.handler (fun (_e : Dom_html.event Js.t) -> + := Dom_html.handler (fun (_e : Dom_html.beforeUnloadEvent Js.t) -> log "handler called, returning Js._false (block)"; Js._false); log "Strategy 1: handler returning Js._false (block)"; @@ -30,7 +30,7 @@ let set_strategy_1 () = let set_strategy_2 () = clear_log (); Dom_html.window##.onbeforeunload - := Dom_html.handler (fun (_e : Dom_html.event Js.t) -> + := Dom_html.handler (fun (_e : Dom_html.beforeUnloadEvent Js.t) -> log "handler called, returning Js._true (allow)"; Js._true); log "Strategy 2: handler returning Js._true (allow)"; @@ -44,7 +44,7 @@ let should_block = ref true let set_strategy_3 () = clear_log (); Dom_html.window##.onbeforeunload - := Dom_html.handler (fun (_e : Dom_html.event Js.t) -> + := Dom_html.handler (fun (_e : Dom_html.beforeUnloadEvent Js.t) -> log (Printf.sprintf "handler called, should_block=%b" !should_block); Js.bool (not !should_block)); log "Strategy 3: handler with conditional logic";