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

@@ -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 () =

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}
 

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

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,18 +2180,24 @@ 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
     := Dom_html.handler (fun event ->
       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 *)

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

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
 

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.

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