From 47067a1a3fb680301cd8a4630844c8cf622fa9b2 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] 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 | 108 +++++++++++++++++++++++++++- src/lib/client/eliommod_dom.ml | 1 + src/lib/client/eliommod_dom.mli | 1 + src/lib/eliom_client.client.ml | 33 ++++++--- src/lib/eliom_common_base.shared.ml | 3 +- src/lib/eliom_lib.client.ml | 24 +++++-- src/lib/eliom_lib.client.mli | 7 +- src/lib/eliom_request.client.ml | 14 ++-- 8 files changed, 164 insertions(+), 27 deletions(-) diff --git a/src/lib/client/eliommod_cookies.ml b/src/lib/client/eliommod_cookies.ml index 42b64f242..f0be5cc2f 100644 --- a/src/lib/client/eliommod_cookies.ml +++ b/src/lib/client/eliommod_cookies.ml @@ -30,6 +30,106 @@ 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 = match l with Empty -> 0 | Node {h} -> h in + let hr = match r with Empty -> 0 | Node {h} -> h 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 + +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) + +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 +144,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 +162,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 e87550acf..c742c7050 100644 --- a/src/lib/client/eliommod_dom.ml +++ b/src/lib/client/eliommod_dom.ml @@ -685,6 +685,7 @@ let preload_css (doc : Dom_html.element Js.t) = type position = {html_top : int; html_left : int; body_top : int; body_left : int} +[@@deriving json] 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 3eb542b76..5c849d137 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 c75e6da97..e7fef2767 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 @@ -585,6 +585,7 @@ type state = { (* TODO store cookies_info in state... *) template : string option ; position : Eliommod_dom.position } +[@@deriving json] let random_int = if Js.Optdef.test Js.Unsafe.global##.crypto @@ -600,6 +601,9 @@ let random_int = let section_page = Lwt_log.Section.make "eliom:client:page" type state_id = {session_id : int; state_index : int (* point in history *)} +[@@deriving json] + +type saved_state = state_id * string [@@deriving json] module Page_status_t = struct type t = Generating | Active | Cached | Dead @@ -813,13 +817,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 +1375,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 +1386,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 +2180,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 +2191,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 c52cce965..f55fcfee6 100644 --- a/src/lib/eliom_common_base.shared.ml +++ b/src/lib/eliom_common_base.shared.ml @@ -181,7 +181,8 @@ 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] 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 81a67be1a..30126a676 100644 --- a/src/lib/eliom_lib.client.ml +++ b/src/lib/eliom_lib.client.ml @@ -147,19 +147,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 bf876064d..49693de48 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 6ff0a58b1..c7583cd47 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