From 772ad3709358c8a6a01a39ecb8a82fce9783a9e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 20 Sep 2024 11:23:12 +0200 Subject: [PATCH 1/8] Bump js_of_ocaml version dependency --- dune-project | 12 ++++++------ eliom.opam | 12 ++++++------ 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/dune-project b/dune-project index 864325aa31..a2389a4bbc 100644 --- a/dune-project +++ b/dune-project @@ -24,13 +24,13 @@ The client-side code is compiled to JS using Ocsigen Js_of_ocaml or to Wasm usin ocamlfind ppx_deriving (ppxlib (>= 0.15.0)) - (js_of_ocaml-compiler (>= 3.6.0)) - (js_of_ocaml (>= 3.6.0)) - (js_of_ocaml-lwt (>= 3.6.0)) + (js_of_ocaml-compiler (>= 5.5.0)) + (js_of_ocaml (>= 5.5.0)) + (js_of_ocaml-lwt (>= 5.5.0)) (js_of_ocaml-ocamlbuild :build) - (js_of_ocaml-ppx (>= 3.6.0)) - (js_of_ocaml-ppx_deriving_json (>= 3.6.0)) - (js_of_ocaml-tyxml (>= 3.6.0)) + (js_of_ocaml-ppx (>= 5.5.0)) + (js_of_ocaml-ppx_deriving_json (>= 5.5.0)) + (js_of_ocaml-tyxml (>= 5.5.0)) lwt_log (lwt_ppx (>= 1.2.3)) (tyxml (and (>= 4.6.0) (< 4.7.0))) diff --git a/eliom.opam b/eliom.opam index ddf6028a36..52419c16e2 100644 --- a/eliom.opam +++ b/eliom.opam @@ -22,13 +22,13 @@ depends: [ "ocamlfind" "ppx_deriving" "ppxlib" {>= "0.15.0"} - "js_of_ocaml-compiler" {>= "3.6.0"} - "js_of_ocaml" {>= "3.6.0"} - "js_of_ocaml-lwt" {>= "3.6.0"} + "js_of_ocaml-compiler" {>= "5.5.0"} + "js_of_ocaml" {>= "5.5.0"} + "js_of_ocaml-lwt" {>= "5.5.0"} "js_of_ocaml-ocamlbuild" {build} - "js_of_ocaml-ppx" {>= "3.6.0"} - "js_of_ocaml-ppx_deriving_json" {>= "3.6.0"} - "js_of_ocaml-tyxml" {>= "3.6.0"} + "js_of_ocaml-ppx" {>= "5.5.0"} + "js_of_ocaml-ppx_deriving_json" {>= "5.5.0"} + "js_of_ocaml-tyxml" {>= "5.5.0"} "lwt_log" "lwt_ppx" {>= "1.2.3"} "tyxml" {>= "4.6.0" & < "4.7.0"} From 33edf8012cb032558fa6e7d6752d96a6401e9caa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Thu, 14 Sep 2023 13:14:38 +0200 Subject: [PATCH 2/8] Explicit float conversions --- src/lib/client/eliommod_cookies.ml | 2 +- src/lib/client/eliommod_dom.ml | 3 ++- src/lib/eliom_client.client.ml | 2 +- src/lib/eliom_comet.client.ml | 10 ++++++---- 4 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src/lib/client/eliommod_cookies.ml b/src/lib/client/eliommod_cookies.ml index 15ac11441e..42b64f2427 100644 --- a/src/lib/client/eliommod_cookies.ml +++ b/src/lib/client/eliommod_cookies.ml @@ -66,7 +66,7 @@ let set_table ?(in_local_storage = false) host t = let now () = let date = new%js Js.date_now in - date##getTime /. 1000. + Js.to_float date##getTime /. 1000. (** [in_local_storage] implements cookie substitutes for iOS WKWebView *) let update_cookie_table ?(in_local_storage = false) host cookies = diff --git a/src/lib/client/eliommod_dom.ml b/src/lib/client/eliommod_dom.ml index 5113701f0b..e87550acf1 100644 --- a/src/lib/client/eliommod_dom.ml +++ b/src/lib/client/eliommod_dom.ml @@ -789,4 +789,5 @@ let onhashchange f = f Dom_html.window##.location##.hash) in ignore - Dom_html.window ## (setInterval (Js.wrap_callback check) (0.2 *. 1000.)) + Dom_html.window + ## (setInterval (Js.wrap_callback check) (Js.float (0.2 *. 1000.))) diff --git a/src/lib/eliom_client.client.ml b/src/lib/eliom_client.client.ml index f6cf6d266a..8cafce0ac2 100644 --- a/src/lib/eliom_client.client.ml +++ b/src/lib/eliom_client.client.ml @@ -595,7 +595,7 @@ let random_int = Js.Unsafe.global ##. crypto ## (getRandomValues (new%js Typed_array.int32Array 1)) 0 - else fun () -> truncate (4294967296. *. Js.math##random) + else fun () -> truncate (4294967296. *. Js.to_float Js.math##random) let section_page = Lwt_log.Section.make "eliom:client:page" diff --git a/src/lib/eliom_comet.client.ml b/src/lib/eliom_comet.client.ml index a4d9cd601d..3acf50c92d 100644 --- a/src/lib/eliom_comet.client.ml +++ b/src/lib/eliom_comet.client.ml @@ -138,7 +138,7 @@ module Configuration = struct then match (get ()).time_between_request_unfocused, focused () with | Some ((a, b, c) :: l), Some start -> - let now = (new%js Js.date_now)##getTime in + let now = Js.to_float (new%js Js.date_now)##getTime in (* time from idle start *) let t = max 0. (((now -. start) *. 0.001) -. (get ()).time_after_unfocus) @@ -305,7 +305,9 @@ end = struct in let suspend_activity () = if handler.hd_activity.focused = None - then handler.hd_activity.focused <- Some (new%js Js.date_now)##getTime + then + handler.hd_activity.focused <- + Some (Js.to_float (new%js Js.date_now)##getTime) in let visibility_change_callback () = if document_hidden () then suspend_activity () else resume_activity () @@ -322,7 +324,7 @@ end = struct if tbru = Some [0., 0., 0.] (* Always active *) then `Active else - let now = (new%js Js.date_now)##getTime in + let now = Js.to_float (new%js Js.date_now)##getTime in if now -. t < (Configuration.get ()).Configuration.time_after_unfocus *. 1000. then `Active @@ -338,7 +340,7 @@ end = struct then hd.hd_activity.focused <- Some - ((new%js Js.date_now)##getTime + (Js.to_float (new%js Js.date_now)##getTime -. ((Configuration.get ()).Configuration.time_after_unfocus *. 1000.) )) else hd.hd_activity.focused <- None; From 611b45865fc38c3f67aff71547f0da7b3d6125bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Wed, 4 Oct 2023 14:01:37 +0200 Subject: [PATCH 3/8] Make the initialization code resilient to missed load event Webassembly code is started asynchronously, so it can be executed after the load event is triggered. --- src/lib/eliom_client.client.ml | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/src/lib/eliom_client.client.ml b/src/lib/eliom_client.client.ml index 8cafce0ac2..c75e6da973 100644 --- a/src/lib/eliom_client.client.ml +++ b/src/lib/eliom_client.client.ml @@ -1035,10 +1035,17 @@ let init () = Js._false in Lwt_log.ign_debug ~section "Set load/onload events"; - onload_handler := - Some - (Dom.addEventListener Dom_html.window (Dom.Event.make "load") - (Dom.handler onload) Js._true); + if Dom_html.document##.readyState = Js.string "complete" + then + Lwt.async @@ fun () -> + let%lwt () = Js_of_ocaml_lwt.Lwt_js_events.request_animation_frame () in + let _ = onload () in + Lwt.return_unit + else + onload_handler := + Some + (Dom.addEventListener Dom_html.window (Dom.Event.make "load") + (Dom.handler onload) Js._true); add_string_event_listener Dom_html.window "beforeunload" onbeforeunload_fun false; ignore From f276f4dfc96b3d8e5ea9147d96c999b986824596 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 3 Oct 2023 19:40:43 +0200 Subject: [PATCH 4/8] Conversion of OCaml values from and to JSON With Wasm_of_ocaml, we can no longer rely on the JSON object to serialize and deserialize OCaml values. --- src/lib/client/eliommod_cookies.ml | 111 +++++++++++++++++++++++++++- src/lib/client/eliommod_dom.ml | 5 ++ src/lib/client/eliommod_dom.mli | 1 + src/lib/eliom_client.client.ml | 41 +++++++--- src/lib/eliom_common_base.shared.ml | 7 +- src/lib/eliom_lib.client.ml | 24 ++++-- src/lib/eliom_lib.client.mli | 7 +- src/lib/eliom_request.client.ml | 14 +++- 8 files changed, 183 insertions(+), 27 deletions(-) diff --git a/src/lib/client/eliommod_cookies.ml b/src/lib/client/eliommod_cookies.ml index 42b64f2427..0e3607bddc 100644 --- a/src/lib/client/eliommod_cookies.ml +++ b/src/lib/client/eliommod_cookies.ml @@ -30,6 +30,109 @@ let cookie_tables : = Jstable.create () +module Map (Ord : sig + type key [@@deriving json] + + val compare : key -> key -> int + end) = +struct + type 'a t = + | Empty + | Node of {l : 'a t; v : Ord.key; d : 'a; r : 'a t; h : int} + [@@deriving json] + + let height = function Empty -> 0 | Node {h; _} -> h + + let create l x d r = + let hl = height l and hr = height r in + Node {l; v = x; d; r; h = (if hl >= hr then hl + 1 else hr + 1)} + + let bal l x d r = + let hl = height l and hr = height r in + if hl > hr + 2 + then + match l with + | Empty -> invalid_arg "Map.bal" + | Node {l = ll; v = lv; d = ld; r = lr; _} -> ( + if height ll >= height lr + then create ll lv ld (create lr x d r) + else + match lr with + | Empty -> invalid_arg "Map.bal" + | Node {l = lrl; v = lrv; d = lrd; r = lrr; _} -> + create (create ll lv ld lrl) lrv lrd (create lrr x d r)) + else if hr > hl + 2 + then + match r with + | Empty -> invalid_arg "Map.bal" + | Node {l = rl; v = rv; d = rd; r = rr; _} -> ( + if height rr >= height rl + then create (create l x d rl) rv rd rr + else + match rl with + | Empty -> invalid_arg "Map.bal" + | Node {l = rll; v = rlv; d = rld; r = rlr; _} -> + create (create l x d rll) rlv rld (create rlr rv rd rr)) + else Node {l; v = x; d; r; h = (if hl >= hr then hl + 1 else hr + 1)} + + let rec add x data = function + | Empty -> Node {l = Empty; v = x; d = data; r = Empty; h = 1} + | Node {l; v; d; r; h} as m -> + let c = Ord.compare x v in + if c = 0 + then if d == data then m else Node {l; v = x; d = data; r; h} + else if c < 0 + then + let ll = add x data l in + if l == ll then m else bal ll v d r + else + let rr = add x data r in + if r == rr then m else bal l v d rr + + let rec fold f m accu = + match m with + | Empty -> accu + | Node {l; v; d; r; _} -> fold f r (f v d (fold f l accu)) + + let empty = Empty +end + +[@@@warning "-39"] + +module Map_path = Map (struct + type key = string list [@@deriving json] + + let compare = compare + end) + +module Map_inner = Map (struct + type key = string [@@deriving json] + + let compare = compare + end) + +[@@@warning "+39"] + +let json_cookies = + [%json: (float option * string * bool) Map_inner.t Map_path.t] + +let extern_cookies c = + Ocsigen_cookie_map.Map_path.fold + (fun path inner m -> + Map_path.add path + (Ocsigen_cookie_map.Map_inner.fold Map_inner.add inner Map_inner.empty) + m) + c Map_path.empty + +let intern_cookies c = + Map_path.fold + (fun path inner m -> + Ocsigen_cookie_map.Map_path.add path + (Map_inner.fold Ocsigen_cookie_map.Map_inner.add inner + Ocsigen_cookie_map.Map_inner.empty) + m) + c Ocsigen_cookie_map.Map_path.empty + (** [in_local_storage] implements cookie substitutes for iOS WKWebView *) let get_table ?(in_local_storage = false) = function | None -> Ocsigen_cookie_map.Map_path.empty @@ -44,7 +147,8 @@ let get_table ?(in_local_storage = false) = function Js.Opt.case st ## (getItem host) (fun () -> Ocsigen_cookie_map.Map_path.empty) - (fun v -> Json.unsafe_input v)) + (fun v -> + intern_cookies (of_json ~typ:json_cookies (Js.to_string v)))) else Js.Optdef.get (Jstable.find cookie_tables (Js.string host)) @@ -61,7 +165,10 @@ let set_table ?(in_local_storage = false) host t = Js.Optdef.case Dom_html.window##.localStorage (fun () -> ()) - (fun st -> st ## (setItem host (Json.output t))) + (fun st -> + st + ## (setItem host + (Js.string (to_json ~typ:json_cookies (extern_cookies t))))) else Jstable.add cookie_tables (Js.string host) t let now () = diff --git a/src/lib/client/eliommod_dom.ml b/src/lib/client/eliommod_dom.ml index e87550acf1..6b005ec29a 100644 --- a/src/lib/client/eliommod_dom.ml +++ b/src/lib/client/eliommod_dom.ml @@ -683,8 +683,13 @@ let preload_css (doc : Dom_html.element Js.t) = Dom_html.document##body while on Firefox they are found on Dom_html.document##documentElement. *) +[@@@warning "-39"] + type position = {html_top : int; html_left : int; body_top : int; body_left : int} +[@@deriving json] + +[@@@warning "+39"] let top_position = {html_top = 0; html_left = 0; body_top = 0; body_left = 0} diff --git a/src/lib/client/eliommod_dom.mli b/src/lib/client/eliommod_dom.mli index 3eb542b763..5c849d137e 100644 --- a/src/lib/client/eliommod_dom.mli +++ b/src/lib/client/eliommod_dom.mli @@ -87,6 +87,7 @@ val iter_attrList : type position = {html_top : int; html_left : int; body_top : int; body_left : int} +[@@deriving json] val top_position : position val getDocumentScroll : unit -> position diff --git a/src/lib/eliom_client.client.ml b/src/lib/eliom_client.client.ml index c75e6da973..1667e11ee3 100644 --- a/src/lib/eliom_client.client.ml +++ b/src/lib/eliom_client.client.ml @@ -165,7 +165,7 @@ let get_element_cookies_info elt = (Js.Opt.map elt ## (getAttribute (Js.string Eliom_runtime.RawXML.ce_call_service_attrib)) - (fun s -> of_json (Js.to_string s))) + (fun s -> of_json ~typ:[%json: bool * string list] (Js.to_string s))) let get_element_template elt = Js.Opt.to_option @@ -581,10 +581,15 @@ let add_string_event_listener o e f capt : unit = behaviour in not required by the HTML5 specification (only suggested). *) +[@@@warning "-39"] + type state = { (* TODO store cookies_info in state... *) template : string option ; position : Eliommod_dom.position } +[@@deriving json] + +[@@@warning "+39"] let random_int = if Js.Optdef.test Js.Unsafe.global##.crypto @@ -599,7 +604,14 @@ let random_int = let section_page = Lwt_log.Section.make "eliom:client:page" +[@@@warning "-39"] + type state_id = {session_id : int; state_index : int (* point in history *)} +[@@deriving json] + +type saved_state = state_id * string [@@deriving json] + +[@@@warning "+39"] module Page_status_t = struct type t = Generating | Active | Cached | Dead @@ -813,13 +825,14 @@ let get_state state_id : state = Lwt_log.raise_error_f ~section "sessionStorage not available") (fun s -> s ## (getItem (state_key state_id)))) (fun () -> raise Not_found) - (fun s -> Json.unsafe_input s) + (fun s -> of_json ~typ:[%json: state] (Js.to_string s)) let set_state i (v : state) = Js.Optdef.case Dom_html.window##.sessionStorage (fun () -> ()) - (fun s -> s ## (setItem (state_key i) (Json.output v))) + (fun s -> + s ## (setItem (state_key i) (Js.string (to_json ~typ:[%json: state] v)))) let update_state () = set_state !active_page.page_id @@ -1370,7 +1383,9 @@ let change_url_string ~replace uri = then ( Opt.iter stash_reload_function !reload_function; Dom_html.window##.history##replaceState - (Js.Opt.return (this_page.page_id, Js.string full_uri)) + (Js.Opt.return + (Js.string + (to_json ~typ:[%json: saved_state] (this_page.page_id, full_uri)))) (Js.string "") (if !Eliom_common.is_client_app then Js.null @@ -1379,7 +1394,9 @@ let change_url_string ~replace uri = update_state (); Opt.iter stash_reload_function !reload_function; Dom_html.window##.history##pushState - (Js.Opt.return (this_page.page_id, Js.string full_uri)) + (Js.Opt.return + (Js.string + (to_json ~typ:[%json: saved_state] (this_page.page_id, full_uri)))) (Js.string "") (if !Eliom_common.is_client_app then Js.null @@ -2171,7 +2188,10 @@ let () = Dom_html.window ##. history ## (replaceState (Js.Opt.return - (!active_page.page_id, Dom_html.window##.location##.href)) + (Js.string + (to_json ~typ:[%json: saved_state] + ( !active_page.page_id + , Js.to_string Dom_html.window##.location##.href )))) (Js.string "") Js.null); Lwt.return_unit); Dom_html.window##.onpopstate @@ -2179,10 +2199,13 @@ let () = Lwt_log.ign_debug ~section:section_page "revisit_wrapper: onpopstate"; Eliommod_dom.touch_base (); Js.Opt.case - ((Js.Unsafe.coerce event)##.state - : (state_id * Js.js_string Js.t) Js.opt) + ((Js.Unsafe.coerce event)##.state : _ Js.opt) (fun () -> () (* Ignore dummy popstate event fired by chromium. *)) - (fun (state, full_uri) -> revisit_wrapper (Js.to_string full_uri) state); + (fun saved_state -> + let state, full_uri = + of_json ~typ:[%json: saved_state] (Js.to_string saved_state) + in + revisit_wrapper full_uri state); Js._false)) else (* Without history API *) diff --git a/src/lib/eliom_common_base.shared.ml b/src/lib/eliom_common_base.shared.ml index c52cce965a..5ecc5b9f8a 100644 --- a/src/lib/eliom_common_base.shared.ml +++ b/src/lib/eliom_common_base.shared.ml @@ -177,11 +177,16 @@ let nl_is_persistent n = n.[0] = 'p' (*****************************************************************************) +[@@@warning "-39"] + type client_process_info = { cpi_ssl : bool ; cpi_hostname : string ; cpi_server_port : int - ; cpi_original_full_path : Url.path } + ; cpi_original_full_path : string list } +[@@deriving json] + +[@@@warning "+39"] type sess_info = { si_other_get_params : (string * string) list diff --git a/src/lib/eliom_lib.client.ml b/src/lib/eliom_lib.client.ml index 73e65094b3..c7a037f3db 100644 --- a/src/lib/eliom_lib.client.ml +++ b/src/lib/eliom_lib.client.ml @@ -146,19 +146,29 @@ end (* We do not use the deriving (un)marshaling even if typ is available because direct jsn (un)marshaling is very fast client side *) -let to_json ?typ:_ s = Js.to_string (Json.output s) -let of_json ?typ:_ v = Json.unsafe_input (Js.string v) - -(* to marshal data and put it in a form *) -let encode_form_value x = to_json x +let to_json ?typ s = + match Sys.backend_type with + | Other "js_of_ocaml" -> Js.to_string (Json.output s) + | _ -> ( + match typ with + | Some typ -> Deriving_Json.to_string typ s + | None -> Js.to_string (Json.output s)) + +let of_json ?typ v = + match Sys.backend_type with + | Other "js_of_ocaml" -> Json.unsafe_input (Js.string v) + | _ -> ( + match typ with + | Some typ -> Deriving_Json.from_string typ v + | None -> assert false) (* Url.urlencode ~with_plus:true (Marshal.to_string x []) (* I encode the data because it seems that multipart does not like \0 character ... *) *) -let encode_header_value x = +let encode_header_value ~typ x = (* We remove end of lines *) - String.remove_eols (to_json x) + String.remove_eols (to_json ~typ x) let unmarshal_js var = Marshal.from_string (Js.to_bytestring var) 0 diff --git a/src/lib/eliom_lib.client.mli b/src/lib/eliom_lib.client.mli index cbe71f3694..1446dc976f 100644 --- a/src/lib/eliom_lib.client.mli +++ b/src/lib/eliom_lib.client.mli @@ -38,8 +38,8 @@ include type file_info = File.file Js.t -val to_json : ?typ:'a -> 'b -> string -val of_json : ?typ:'a -> string -> 'b +val to_json : ?typ:'a Deriving_Json.t -> 'a -> string +val of_json : ?typ:'a Deriving_Json.t -> string -> 'a module Url : sig (** URL manipulation *) @@ -126,9 +126,8 @@ val confirm : ('a, unit, string, bool) format4 -> 'a val debug_var : string -> 'a -> unit val trace : ('a, unit, string, unit) format4 -> 'a val lwt_ignore : ?message:string -> unit Lwt.t -> unit -val encode_form_value : 'a -> string val unmarshal_js : Js.js_string Js.t -> 'a -val encode_header_value : 'a -> string +val encode_header_value : typ:'a Deriving_Json.t -> 'a -> string val make_cryptographic_safe_string : ?len:int -> unit -> string (** Return a base-64 encoded cryptographic safe string of the given length. diff --git a/src/lib/eliom_request.client.ml b/src/lib/eliom_request.client.ml index 6ff0a58b1d..c7583cd47e 100644 --- a/src/lib/eliom_request.client.ml +++ b/src/lib/eliom_request.client.ml @@ -180,7 +180,10 @@ let send ?with_credentials ?(expecting_process_page = false) ?cookies_info let headers = match cookies with | [] -> [] - | _ -> [Eliom_common.tab_cookies_header_name, encode_header_value cookies] + | _ -> + [ ( Eliom_common.tab_cookies_header_name + , encode_header_value ~typ:[%json: (string * string) list] cookies ) + ] in let headers = if Js.Optdef.test Js.Unsafe.global##.___eliom_use_cookie_substitutes_ @@ -191,7 +194,7 @@ let send ?with_credentials ?(expecting_process_page = false) ?cookies_info path in ( Eliom_common.cookie_substitutes_header_name - , encode_header_value cookies ) + , encode_header_value ~typ:[%json: (string * string) list] cookies ) :: headers else headers in @@ -209,7 +212,9 @@ let send ?with_credentials ?(expecting_process_page = false) ?cookies_info match host with | Some host when host = Url.Current.host -> ( Eliom_common.tab_cpi_header_name - , encode_header_value (Eliom_process.get_info ()) ) + , encode_header_value + ~typ:[%json: Eliom_common_base.client_process_info] + (Eliom_process.get_info ()) ) :: headers | _ -> headers in @@ -228,7 +233,8 @@ let send ?with_credentials ?(expecting_process_page = false) ?cookies_info else "application/xhtml+xml" in ("Accept", content_type) - :: (Eliom_common.expecting_process_page_name, encode_header_value true) + :: ( Eliom_common.expecting_process_page_name + , encode_header_value ~typ:[%json: bool] true ) :: headers else headers in From 55701e599a4a9ffceb0ef8df80f7e5e819a51b88 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 20 Sep 2024 11:12:17 +0200 Subject: [PATCH 5/8] Unwrapping: clean-up --- src/lib/client/eliom_client.js | 4 ++-- src/lib/eliom_unwrap.client.ml | 7 ++++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/lib/client/eliom_client.js b/src/lib/client/eliom_client.js index ca73d37ded..be0465361a 100644 --- a/src/lib/client/eliom_client.js +++ b/src/lib/client/eliom_client.js @@ -3,7 +3,7 @@ //Provides: caml_unwrap_value_from_string //Requires: caml_failwith, caml_marshal_constants //Requires: caml_int64_float_of_bits, caml_int64_of_bytes, caml_new_string -//Requires: caml_jsbytes_of_string +//Requires: caml_jsbytes_of_string, caml_callback var caml_unwrap_value_from_string = function (){ function StringReader (s, i) { this.s = caml_jsbytes_of_string(s); this.i = i; } StringReader.prototype = { @@ -222,7 +222,7 @@ var caml_unwrap_value_from_string = function (){ if (v[0] === 0 && size >= 2 && v[size] instanceof Array && v[size].length == 3 && v[size][2] === intern_obj_table[2] /*unwrap_mark*/) { - var unwrapped_v = apply_unwrapper(v[size], v); + var unwrapped_v = caml_callback(apply_unwrapper, [v[size], v]); if (unwrapped_v === 0) { // No unwrapper is registered, so replace the unwrap // marker v[size] by a late_unwrap marker diff --git a/src/lib/eliom_unwrap.client.ml b/src/lib/eliom_unwrap.client.ml index 6a52a73e47..4bb93c6223 100644 --- a/src/lib/eliom_unwrap.client.ml +++ b/src/lib/eliom_unwrap.client.ml @@ -72,11 +72,12 @@ let apply_unwrapper unwrapper v = let late_unwrap_value old_value new_value = let old_value = Obj.repr old_value in List.iter - (fun {parent; field} -> Js.Unsafe.set parent field new_value) + (fun {parent; field} -> + Obj.set_field parent (field - 1) (Obj.repr new_value)) (Obj.obj (Obj.field (Obj.field old_value (Obj.size old_value - 1)) 2)) external raw_unmarshal_and_unwrap : - (unit, unwrapper -> _ -> _ option) Js.meth_callback + (unwrapper -> _ -> _ option) -> string -> int -> _ @@ -85,7 +86,7 @@ external raw_unmarshal_and_unwrap : let unwrap s i = if !Eliom_config.debug_timings then Firebug.console ## (time (Js.string "unwrap")); - let res = raw_unmarshal_and_unwrap (Js.wrap_callback apply_unwrapper) s i in + let res = raw_unmarshal_and_unwrap apply_unwrapper s i in if !Eliom_config.debug_timings then Firebug.console ## (timeEnd (Js.string "unwrap")); res From ad3932f136a45444132f9fcb94ccaf69cf605736 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 3 Oct 2023 21:04:08 +0200 Subject: [PATCH 6/8] Fix typed array usage --- src/lib/eliom_client.client.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/lib/eliom_client.client.ml b/src/lib/eliom_client.client.ml index 1667e11ee3..518ade5c35 100644 --- a/src/lib/eliom_client.client.ml +++ b/src/lib/eliom_client.client.ml @@ -596,10 +596,11 @@ let random_int = && Js.Optdef.test Js.Unsafe.global##.crypto##.getRandomValues then fun () -> - Typed_array.unsafe_get + let a = Js.Unsafe.global ##. crypto - ## (getRandomValues (new%js Typed_array.int32Array 1)) - 0 + ## (getRandomValues (new%js Typed_array.int16Array 2)) + in + (Typed_array.unsafe_get a 0 lsl 16) lor Typed_array.unsafe_get a 1 else fun () -> truncate (4294967296. *. Js.to_float Js.math##random) let section_page = Lwt_log.Section.make "eliom:client:page" From 684ea6f3cedb1fc5962f9e8f2bd93518865a608d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Mon, 2 Oct 2023 21:50:22 +0200 Subject: [PATCH 7/8] Wasm runtime file --- src/lib/client/eliom_client.wat | 656 ++++++++++++++++++++++++++++++++ 1 file changed, 656 insertions(+) create mode 100644 src/lib/client/eliom_client.wat diff --git a/src/lib/client/eliom_client.wat b/src/lib/client/eliom_client.wat new file mode 100644 index 0000000000..561629cad1 --- /dev/null +++ b/src/lib/client/eliom_client.wat @@ -0,0 +1,656 @@ +(module + (import "env" "caml_failwith" (func $caml_failwith (param (ref eq)))) + (import "env" "caml_init_custom_operations" + (func $caml_init_custom_operations)) + (import "env" "caml_find_custom_operations" + (func $caml_find_custom_operations + (param (ref $string)) (result (ref null $custom_operations)))) + (import "env" "caml_callback_2" + (func $caml_callback_2 + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + (type $float (struct (field f64))) + (type $float_array (array (mut f64))) + (type $js (struct (field anyref))) + + (type $compare + (func (param (ref eq)) (param (ref eq)) (param i32) (result i32))) + (type $hash + (func (param (ref eq)) (result i32))) + (type $fixed_length (struct (field $bsize_32 i32) (field $bsize_64 i32))) + (type $serialize + (func (param (ref eq)) (param (ref eq)) (result i32) (result i32))) + (type $deserialize (func (param (ref eq)) (result (ref eq)) (result i32))) + (type $dup (func (param (ref eq)) (result (ref eq)))) + (type $custom_operations + (struct + (field $id (ref $string)) + (field $compare (ref null $compare)) + (field $compare_ext (ref null $compare)) + (field $hash (ref null $hash)) + (field $fixed_length (ref null $fixed_length)) + (field $serialize (ref null $serialize)) + (field $deserialize (ref null $deserialize)) + (field $dup (ref null $dup)))) + (type $custom (sub (struct (field (ref $custom_operations))))) + + (data $bad_length "unwrap_value: bad length") + + (func (export "caml_unwrap_value_from_string") + (param $unwrapper (ref eq)) + (param $vstr (ref eq)) (param $vofs (ref eq)) (result (ref eq)) + (local $str (ref $string)) + (local $ofs i32) + (local $s (ref $intern_state)) + (local $h (ref $marshal_header)) + (local.set $str (ref.cast (ref $string) (local.get $vstr))) + (local.set $ofs (i31.get_u (ref.cast (ref i31) (local.get $vofs)))) + (local.set $s + (call $get_intern_state (local.get $str) (local.get $ofs))) + (local.set $h (call $parse_header (local.get $s))) + (if (i32.gt_s + (i32.add (local.get $ofs) + (i32.add (struct.get $marshal_header $data_len (local.get $h)) + (i32.const 20))) + (array.len (local.get $str))) + (then + (call $caml_failwith + (array.new_data $string $bad_length + (i32.const 0) (i32.const 24))))) + (return_call $intern_rec + (local.get $unwrapper) (local.get $s) (local.get $h))) + + (global $Intext_magic_number_small i32 (i32.const 0x8495A6BE)) + (global $Intext_magic_number_big i32 (i32.const 0x8495A6BF)) + + (global $PREFIX_SMALL_BLOCK i32 (i32.const 0x80)) + (global $PREFIX_SMALL_INT i32 (i32.const 0x40)) + (global $PREFIX_SMALL_STRING i32 (i32.const 0x20)) + (global $CODE_INT8 i32 (i32.const 0x00)) + (global $CODE_INT16 i32 (i32.const 0x01)) + (global $CODE_INT32 i32 (i32.const 0x02)) + (global $CODE_INT64 i32 (i32.const 0x03)) + (global $CODE_SHARED8 i32 (i32.const 0x04)) + (global $CODE_SHARED16 i32 (i32.const 0x05)) + (global $CODE_SHARED32 i32 (i32.const 0x06)) + (global $CODE_BLOCK32 i32 (i32.const 0x08)) + (global $CODE_BLOCK64 i32 (i32.const 0x13)) + (global $CODE_STRING8 i32 (i32.const 0x09)) + (global $CODE_STRING32 i32 (i32.const 0x0A)) + (global $CODE_DOUBLE_BIG i32 (i32.const 0x0B)) + (global $CODE_DOUBLE_LITTLE i32 (i32.const 0x0C)) + (global $CODE_DOUBLE_ARRAY8_BIG i32 (i32.const 0x0D)) + (global $CODE_DOUBLE_ARRAY8_LITTLE i32 (i32.const 0x0E)) + (global $CODE_DOUBLE_ARRAY32_BIG i32 (i32.const 0x0F)) + (global $CODE_DOUBLE_ARRAY32_LITTLE i32 (i32.const 0x07)) + (global $CODE_CODEPOINTER i32 (i32.const 0x10)) + (global $CODE_INFIXPOINTER i32 (i32.const 0x11)) + (global $CODE_CUSTOM i32 (i32.const 0x12)) + (global $CODE_CUSTOM_LEN i32 (i32.const 0x18)) + (global $CODE_CUSTOM_FIXED i32 (i32.const 0x19)) + + ;; Keep in sync with marshal.wat + (type $intern_state + (struct + (field $src (ref $string)) + (field $pos (mut i32)) + (field $obj_table (mut (ref null $block))) + (field $obj_counter (mut i32)))) + + (func $get_intern_state + (param $src (ref $string)) (param $pos i32) (result (ref $intern_state)) + (struct.new $intern_state + (local.get $src) (local.get $pos) (ref.null $block) + (i32.const 0))) + + (func $read8u (param $s (ref $intern_state)) (result i32) + (local $pos i32) (local $res i32) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (local.set $res + (array.get_u $string + (struct.get $intern_state $src (local.get $s)) + (local.get $pos))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 1))) + (local.get $res)) + + (func $read8s (param $s (ref $intern_state)) (result i32) + (local $pos i32) (local $res i32) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (local.set $res + (array.get_s $string + (struct.get $intern_state $src (local.get $s)) + (local.get $pos))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 1))) + (local.get $res)) + + (func $read16u (param $s (ref $intern_state)) (result i32) + (local $src (ref $string)) (local $pos i32) (local $res i32) + (local.set $src (struct.get $intern_state $src (local.get $s))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (local.set $res + (i32.or + (i32.shl + (array.get_u $string (local.get $src) (local.get $pos)) + (i32.const 8)) + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (i32.const 1))))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 2))) + (local.get $res)) + + (func $read16s (param $s (ref $intern_state)) (result i32) + (local $src (ref $string)) (local $pos i32) (local $res i32) + (local.set $src (struct.get $intern_state $src (local.get $s))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (local.set $res + (i32.or + (i32.shl + (array.get_s $string (local.get $src) (local.get $pos)) + (i32.const 8)) + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (i32.const 1))))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 2))) + (local.get $res)) + + (func $read32 (param $s (ref $intern_state)) (result i32) + (local $src (ref $string)) (local $pos i32) (local $res i32) + (local.set $src (struct.get $intern_state $src (local.get $s))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (local.set $res + (i32.or + (i32.or + (i32.shl + (array.get_u $string (local.get $src) (local.get $pos)) + (i32.const 24)) + (i32.shl + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (i32.const 1))) + (i32.const 16))) + (i32.or + (i32.shl + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (i32.const 2))) + (i32.const 8)) + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (i32.const 3)))))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 4))) + (local.get $res)) + + (func $readblock (param $s (ref $intern_state)) (param $str (ref $string)) + (local $len i32) (local $pos i32) + (local.set $len (array.len (local.get $str))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (array.copy $string $string + (local.get $str) (i32.const 0) + (struct.get $intern_state $src (local.get $s)) (local.get $pos) + (local.get $len)) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (local.get $len)))) + + (func $readstr (param $s (ref $intern_state)) (result (ref $string)) + (local $len i32) (local $pos i32) (local $res (ref $string)) + (local $src (ref $string)) + (local.set $src (struct.get $intern_state $src (local.get $s))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (loop $loop + (if (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (local.get $len))) + (then + (local.set $len (i32.add (local.get $len) (i32.const 1))) + (br $loop)))) + (local.set $res (array.new $string (i32.const 0) (local.get $len))) + (array.copy $string $string + (local.get $res) (i32.const 0) + (local.get $src) (local.get $pos) + (local.get $len)) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.add (local.get $len) (i32.const 1)))) + (local.get $res)) + + (func $readfloat + (param $s (ref $intern_state)) (param $code i32) (result f64) + (local $src (ref $string)) (local $pos i32) (local $res i32) + (local $d i64) + (local $i i32) + (local $v (ref eq)) + (local.set $src (struct.get $intern_state $src (local.get $s))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 8))) + (if (i32.eq (local.get $code) (global.get $CODE_DOUBLE_BIG)) + (then + (loop $loop + (local.set $d + (i64.or + (i64.shl (local.get $d) (i64.const 8)) + (i64.extend_i32_u + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (local.get $i)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $loop (i32.lt_u (local.get $i) (i32.const 8))))) + (else + (loop $loop + (local.set $d + (i64.rotr + (i64.or (local.get $d) + (i64.extend_i32_u + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (local.get $i))))) + (i64.const 8))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $loop (i32.lt_u (local.get $i) (i32.const 8)))))) + (f64.reinterpret_i64 (local.get $d))) + + (func $readfloats + (param $s (ref $intern_state)) (param $code i32) (param $len i32) + (result (ref eq)) + (local $dest (ref $float_array)) + (local $i i32) + (local.set $code + (select (global.get $CODE_DOUBLE_BIG) (global.get $CODE_DOUBLE_LITTLE) + (i32.or + (i32.eq (local.get $code) (global.get $CODE_DOUBLE_ARRAY8_BIG)) + (i32.eq (local.get $code) + (global.get $CODE_DOUBLE_ARRAY32_BIG))))) + (local.set $dest (array.new $float_array (f64.const 0) (local.get $len))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $float_array (local.get $dest) (local.get $i) + (call $readfloat (local.get $s) (local.get $code))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.get $dest)) + + (func $register_object (param $s (ref $intern_state)) (param $v (ref eq)) + (local $p i32) + (local.set $p (struct.get $intern_state $obj_counter (local.get $s))) + (array.set $block + (struct.get $intern_state $obj_table (local.get $s)) + (local.get $p) (local.get $v)) + (struct.set $intern_state $obj_counter (local.get $s) + (i32.add (local.get $p) (i32.const 1)))) + + (data $unknown_custom "unwrap_value: unknown custom block identifier") + (data $expected_size "unwrap_value: expected a fixed-size custom block") + (data $incorrect_size + "unwrap_value: incorrect length of serialized custom block") + + (func $intern_custom + (param $s (ref $intern_state)) (param $code i32) (result (ref eq)) + (local $ops (ref $custom_operations)) + (local $expected_size i32) + (local $r (tuple (ref eq) i32)) + (block $unknown + (local.set $ops + (br_on_null $unknown + (call + $caml_find_custom_operations + (call $readstr + (local.get $s))))) + (block $no_length + (if (i32.eq (local.get $code) (global.get $CODE_CUSTOM_FIXED)) + (then + (local.set $expected_size + (struct.get $fixed_length $bsize_32 + (br_on_null $no_length + (struct.get $custom_operations $fixed_length + (local.get $ops)))))) + (else + (if (i32.eq (local.get $code) (global.get $CODE_CUSTOM_LEN)) + (then + (local.set $expected_size (call $read32 (local.get $s))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (struct.get $intern_state $pos (local.get $s)) + (i32.const 8))))))) + (local.set $r + (call_ref $deserialize (local.get $s) + (struct.get $custom_operations $deserialize (local.get $ops)))) + (if (i32.and + (i32.ne (tuple.extract 2 1 (local.get $r)) + (local.get $expected_size)) + (i32.ne (local.get $code) (global.get $CODE_CUSTOM))) + (then + (call $caml_failwith + (array.new_data $string $incorrect_size + (i32.const 0) (i32.const 57))))) + (return (tuple.extract 2 0 (local.get $r)))) + (call $caml_failwith + (array.new_data $string $expected_size + (i32.const 0) (i32.const 48)))) + (call $caml_failwith + (array.new_data $string $unknown_custom + (i32.const 0) (i32.const 45))) + (ref.i31 (i32.const 0))) + + (data $integer_too_large "unwrap_value: integer too large") + (data $code_pointer "unwrap_value: code pointer") + (data $ill_formed "unwrap_value: ill-formed message") + (data $incorrect_value "unwrap_value: incorrect value") + + (type $stack_item + (struct + (field $blk (ref $block)) + (field $pos (mut i32)) + (field $ofs i32) + (field $next (ref null $stack_item)))) + + (func $intern_rec + (param $unwrapper (ref eq)) + (param $s (ref $intern_state)) (param $h (ref $marshal_header)) + (result (ref eq)) + (local $late_unwrap_mark (ref $block)) + (local $res (ref $block)) (local $dest (ref $block)) + (local $sp (ref $stack_item)) + (local $code i32) + (local $header i32) (local $tag i32) (local $size i32) + (local $len i32) (local $pos i32) (local $pos' i32) (local $ofs i32) + (local $b (ref $block)) + (local $str (ref $string)) + (local $v (ref eq)) (local $v' (ref eq)) + (call $caml_init_custom_operations) + (local.set $late_unwrap_mark (array.new_fixed $block 0)) + (local.set $res (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) + (local.set $sp + (struct.new $stack_item + (local.get $res) (i32.const 0) (i32.const -1) + (ref.null $stack_item))) + (local.set $size (struct.get $marshal_header $num_objects (local.get $h))) + (struct.set $intern_state $obj_table (local.get $s) + (array.new $block (ref.i31 (i32.const 0)) (local.get $size))) + (local.set $v (ref.i31 (i32.const 0))) ;; keep validator happy + (block $exit + (loop $loop + (block $done + (block $read_block + (block $read_string + (block $read_double_array + (block $read_shared + (local.set $code (call $read8u (local.get $s))) + (if (i32.ge_u (local.get $code) (global.get $PREFIX_SMALL_INT)) + (then + (if (i32.ge_u (local.get $code) (global.get $PREFIX_SMALL_BLOCK)) + (then + ;; Small block + (local.set $tag + (i32.and (local.get $code) (i32.const 0xF))) + (local.set $size + (i32.and (i32.shr_u (local.get $code) (i32.const 4)) + (i32.const 0x7))) + (br $read_block)) + (else + ;; Small int + (local.set $v + (ref.i31 + (i32.and (local.get $code) (i32.const 0x3F)))) + (br $done)))) + (else + (if (i32.ge_u (local.get $code) + (global.get $PREFIX_SMALL_STRING)) + (then + (local.set $len + (i32.and (local.get $code) (i32.const 0x1F))) + (br $read_string)) + (else + (block $INT8 + (block $INT16 + (block $INT32 + (block $INT64 + (block $SHARED8 + (block $SHARED16 + (block $SHARED32 + (block $BLOCK32 + (block $STRING8 + (block $STRING32 + (block $DOUBLE + (block $DOUBLE_ARRAY8 + (block $DOUBLE_ARRAY32 + (block $CODEPOINTER + (block $CUSTOM + (block $default + (br_table $INT8 $INT16 $INT32 $INT64 + $SHARED8 $SHARED16 $SHARED32 + $DOUBLE_ARRAY32 $BLOCK32 $STRING8 + $STRING32 $DOUBLE $DOUBLE + $DOUBLE_ARRAY8 $DOUBLE_ARRAY8 + $DOUBLE_ARRAY32 $CODEPOINTER + $CODEPOINTER $CUSTOM $default + $default $default $default $default + $CUSTOM $CUSTOM $default + (local.get $code))) + ;; default + (call $caml_failwith + (array.new_data $string $ill_formed + (i32.const 0) (i32.const 32))) + (br $done)) + ;; CUSTOM + (local.set $v + (call $intern_custom (local.get $s) + (local.get $code))) + (call $register_object (local.get $s) + (local.get $v)) + (br $done)) + ;; CODEPOINTER + (call $caml_failwith + (array.new_data $string $code_pointer + (i32.const 0) (i32.const 26))) + (br $done)) + ;; DOUBLE_ARRAY32 + (local.set $len + (call $read32 (local.get $s))) + (br $read_double_array)) + ;; DOUBLE_ARRAY8 + (local.set $len + (call $read8u (local.get $s))) + (br $read_double_array)) + ;; DOUBLE + (local.set $v + (struct.new $float + (call $readfloat + (local.get $s) (local.get $code)))) + (call $register_object + (local.get $s) (local.get $v)) + (br $done)) + ;; STRING32 + (local.set $len (call $read32 (local.get $s))) + (br $read_string)) + ;; STRING8 + (local.set $len (call $read8u (local.get $s))) + (br $read_string)) + ;; BLOCK32 + (local.set $header (call $read32 (local.get $s))) + (local.set $tag + (i32.and (local.get $header) + (i32.const 0xFF))) + (local.set $size + (i32.shr_u (local.get $header) + (i32.const 10))) + (br $read_block)) + ;; SHARED32 + (local.set $ofs (call $read32 (local.get $s))) + (br $read_shared)) + ;; SHARED16 + (local.set $ofs (call $read16u (local.get $s))) + (br $read_shared)) + ;; SHARED8 + (local.set $ofs (call $read8u (local.get $s))) + (br $read_shared)) + ;; INT64 + (call $caml_failwith + (array.new_data $string $integer_too_large + (i32.const 0) (i32.const 31))) + (br $done)) + ;; INT32 + (local.set $v (ref.i31 (call $read32 (local.get $s)))) + (br $done)) + ;; INT16 + (local.set $v (ref.i31 (call $read16s (local.get $s)))) + (br $done)) + ;; INT8 + (local.set $v (ref.i31 (call $read8s (local.get $s)))) + (br $done)) + )))) + ;; read_shared + (local.set $ofs + (i32.sub + (struct.get $intern_state $obj_counter (local.get $s)) + (local.get $ofs))) + (local.set $v + (array.get $block + (struct.get $intern_state $obj_table (local.get $s)) + (local.get $ofs))) + (br_if $done (i32.eqz (ref.test (ref $block) (local.get $v)))) + (local.set $b (ref.cast (ref $block) (local.get $v))) + (local.set $len (array.len (local.get $b))) + (br_if $done (i32.lt_u (local.get $len) (i32.const 2))) + (local.set $v' + (array.get $block (local.get $b) + (i32.sub (local.get $len) (i32.const 1)))) + (br_if $done (i32.eqz (ref.test (ref $block) (local.get $v')))) + (local.set $b (ref.cast (ref $block) (local.get $v'))) + (br_if $done (i32.ne (array.len (local.get $b)) (i32.const 4))) + (br_if $done + (i32.eqz + (ref.eq (array.get $block (local.get $b) (i32.const 2)) + (local.get $late_unwrap_mark)))) + (array.set $block (local.get $b) (i32.const 3) + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (struct.get $stack_item $blk (local.get $sp)) + (ref.i31 + (struct.get $stack_item $pos (local.get $sp)))) + (array.get $block (local.get $b) (i32.const 3)))) + (br $done)) + ;; read_double_array + (local.set $v + (call $readfloats + (local.get $s) (local.get $code) (local.get $len))) + (call $register_object (local.get $s) (local.get $v)) + (br $done)) + ;; read_string + (local.set $str (array.new $string (i32.const 0) (local.get $len))) + (call $readblock (local.get $s) (local.get $str)) + (local.set $v (local.get $str)) + (call $register_object (local.get $s) (local.get $v)) + (br $done)) + ;; read_block + (local.set $b + (array.new $block (ref.i31 (i32.const 0)) + (i32.add (local.get $size) (i32.const 1)))) + (array.set $block (local.get $b) (i32.const 0) + (ref.i31 (local.get $tag))) + (if (local.get $size) + (then + (local.set $sp + (struct.new $stack_item + (local.get $b) (i32.const 1) + (struct.get $intern_state $obj_counter (local.get $s)) + (local.get $sp))) + (call $register_object (local.get $s) (local.get $b)) + (br $loop))) + (local.set $v (local.get $b)) + (br $done)) + ;; done + (loop $assign + (local.set $dest (struct.get $stack_item $blk (local.get $sp))) + (local.set $pos (struct.get $stack_item $pos (local.get $sp))) + (array.set $block (local.get $dest) (local.get $pos) (local.get $v)) + (local.set $pos' (i32.add (local.get $pos) (i32.const 1))) + (struct.set $stack_item $pos (local.get $sp) (local.get $pos')) + (local.set $len (array.len (local.get $dest))) + (br_if $loop (i32.ne (local.get $pos') (local.get $len))) + (local.set $v (local.get $dest)) + (local.set $ofs (struct.get $stack_item $ofs (local.get $sp))) + (local.set $sp + (br_on_null $exit (struct.get $stack_item $next (local.get $sp)))) + (br_if $assign (i32.lt_u (local.get $len) (i32.const 2))) + (br_if $assign + (i32.eqz + (ref.eq (array.get $block (local.get $dest) (i32.const 0)) + (ref.i31 (i32.const 0))))) + (local.set $v' + (array.get $block (local.get $dest) + (i32.sub (local.get $len) (i32.const 1)))) + (br_if $assign (i32.eqz (ref.test (ref $block) (local.get $v')))) + (local.set $b (ref.cast (ref $block) (local.get $v'))) + (br_if $assign (i32.ne (array.len (local.get $b)) (i32.const 3))) + (br_if $assign + (i32.eqz + (ref.eq (array.get $block (local.get $b) (i32.const 2)) + (array.get $block + (struct.get $intern_state $obj_table (local.get $s)) + (i32.const 1))))) + (local.set $v' + (call $caml_callback_2 (local.get $unwrapper) + (local.get $b) (local.get $dest))) + (if (ref.test (ref $block) (local.get $v')) + (then + (local.set $v + (array.get $block (ref.cast (ref $block) (local.get $v')) + (i32.const 1))) + (array.set $block + (struct.get $intern_state $obj_table (local.get $s)) + (local.get $ofs) (local.get $v))) + (else + (array.set $block (local.get $dest) + (i32.sub (local.get $len) (i32.const 1)) + (array.new_fixed $block 4 (ref.i31 (i32.const 0)) + (array.get $block (local.get $b) (i32.const 1)) + (local.get $late_unwrap_mark) + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (struct.get $stack_item $blk (local.get $sp)) + (ref.i31 + (struct.get $stack_item $pos (local.get $sp)))) + (ref.i31 (i32.const 0))))))) + (br $assign)))) + (drop (block $incorrect_value (result (ref eq)) + (local.set $b + (br_on_cast_fail $incorrect_value (ref eq) (ref $block) + (array.get $block (local.get $res) (i32.const 0)))) + (if (i32.eq (array.len (local.get $b)) (i32.const 3)) + (then (return (array.get $block (local.get $b) (i32.const 2))))) + (ref.i31 (i32.const 0)))) + (call $caml_failwith + (array.new_data $string $incorrect_value (i32.const 0) (i32.const 29))) + (ref.i31 (i32.const 0))) + + (data $too_large + "unwrap_value: object too large to be read back on a 32-bit platform") + (data $bad_object "unwrap_value: bad object") + + (type $marshal_header + (struct + (field $data_len i32) + (field $num_objects i32))) + + (func $parse_header + (param $s (ref $intern_state)) + (result (ref $marshal_header)) + (local $magic i32) + (local $data_len i32) (local $num_objects i32) (local $whsize i32) + (local.set $magic (call $read32 (local.get $s))) + (if (i32.eq (local.get $magic) (global.get $Intext_magic_number_big)) + (then + (call $caml_failwith + (array.new_data $string $too_large + (i32.const 0) (i32.const 67))))) + (if (i32.ne (local.get $magic) (global.get $Intext_magic_number_small)) + (then + (call $caml_failwith + (array.new_data $string $bad_object + (i32.const 0) (i32.const 24))))) + (local.set $data_len (call $read32 (local.get $s))) + (local.set $num_objects (call $read32 (local.get $s))) + (drop (call $read32 (local.get $s))) + (drop (call $read32 (local.get $s))) + (struct.new $marshal_header + (local.get $data_len) + (local.get $num_objects))) +) From 876eb2f6464bb462de422c50dc14ad8842bba4f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 3 Oct 2023 23:47:17 +0200 Subject: [PATCH 8/8] Do not use physical equality on JavaScript values --- src/lib/client/eliommod_dom.ml | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/lib/client/eliommod_dom.ml b/src/lib/client/eliommod_dom.ml index 6b005ec29a..22c4b67cb1 100644 --- a/src/lib/client/eliommod_dom.ml +++ b/src/lib/client/eliommod_dom.ml @@ -83,7 +83,7 @@ let fast_ancessor (elt1 : #Dom.node Js.t) (elt2 : #Dom.node Js.t) = let slow_ancessor (elt1 : #Dom.node Js.t) (elt2 : #Dom.node Js.t) = let rec check_parent n = - if n == (elt1 :> Dom.node Js.t) + if Js.strict_equals n (elt1 :> Dom.node Js.t) then true else match Js.Opt.to_option n##.parentNode with @@ -162,20 +162,20 @@ let slow_has_classes (node : Dom_html.element Js.t) = let found_attrib = ref false in for i = 0 to classes##.length - 1 do found_call_service := - Js.array_get classes i - == Js.def (Js.string Eliom_runtime.RawXML.ce_call_service_class) + Js.Optdef.strict_equals (Js.array_get classes i) + (Js.def (Js.string Eliom_runtime.RawXML.ce_call_service_class)) || !found_call_service; found_process_node := - Js.array_get classes i - == Js.def (Js.string Eliom_runtime.RawXML.process_node_class) + Js.Optdef.strict_equals (Js.array_get classes i) + (Js.def (Js.string Eliom_runtime.RawXML.process_node_class)) || !found_process_node; found_closure := - Js.array_get classes i - == Js.def (Js.string Eliom_runtime.RawXML.ce_registered_closure_class) + Js.Optdef.strict_equals (Js.array_get classes i) + (Js.def (Js.string Eliom_runtime.RawXML.ce_registered_closure_class)) || !found_closure; found_attrib := - Js.array_get classes i - == Js.def (Js.string Eliom_runtime.RawXML.ce_registered_attr_class) + Js.Optdef.strict_equals (Js.array_get classes i) + (Js.def (Js.string Eliom_runtime.RawXML.ce_registered_attr_class)) || !found_attrib done; !found_call_service, !found_process_node, !found_closure, !found_attrib @@ -185,8 +185,8 @@ let slow_has_request_class (node : Dom_html.element Js.t) = let found_request_node = ref false in for i = 0 to classes##.length - 1 do found_request_node := - Js.array_get classes i - == Js.def (Js.string Eliom_runtime.RawXML.request_node_class) + Js.Optdef.strict_equals (Js.array_get classes i) + (Js.def (Js.string Eliom_runtime.RawXML.request_node_class)) || !found_request_node done; !found_request_node @@ -788,7 +788,7 @@ let onhashchange f = else let last_fragment = ref Dom_html.window##.location##.hash in let check () = - if !last_fragment != Dom_html.window##.location##.hash + if not (Js.equals !last_fragment Dom_html.window##.location##.hash) then ( last_fragment := Dom_html.window##.location##.hash; f Dom_html.window##.location##.hash)