Implement Rpc.Dict <-> Hashtbl serialization funs

This fixes the "missing Hashtbl.rpc_of_t" and related compilation
errors.

This is cherry-picked from 59544ba.

Signed-off-by: Gabor Igloi <[email protected]>

Author: gaborigloi

ocaml/xapi/OMakefile

@@ -39,7 +39,7 @@ OCAMLPACKS = $(OCAMLPACKS) $(XEN_OCAMLPACKS)
 OCamlProgram(http_test, http_test)
 OCamlProgram(show_bat, show_bat)
 
-OCamlProgram(storage_impl_test, sparse_encoding sparse_dd_wrapper storage_migrate storage_impl task_server updates storage_task storage_locks storage_impl_test)
+OCamlProgram(storage_impl_test, sparse_encoding sparse_dd_wrapper storage_migrate storage_impl task_server updates storage_task storage_locks storage_impl_test rpc_std_helpers)
 
 COMMON = \
 	xapi_templates \
@@ -49,6 +49,7 @@ COMMON = \
 	xapi_mgmt_iface \
 	smint \
 	../gpg/gpg \
+	rpc_std_helpers \
 	helpers \
 	at_least_once_more \
 	fileserver

ocaml/xapi/rpc_std_helpers.ml

@@ -0,0 +1,13 @@
+(** Helpers to marshal and unmarshal Rpc.Dict into Hashtbl *)
+
+let rpc_of_hashtbl ~rpc_of t =
+  let dict = Hashtbl.fold (fun k v acc -> (k, rpc_of v) :: acc) t [] in
+  Rpc.Dict dict
+
+let hashtbl_of_rpc ~of_rpc = function
+  | Rpc.Dict d ->
+    let h = Hashtbl.create (List.length d) in
+    List.iter (function (k, r) -> Hashtbl.add h k (of_rpc r)) d;
+    h
+  | r -> failwith (Printf.sprintf "Expected Rpc.Dict, but got %s" (Xmlrpc.to_string r))
+

ocaml/xapi/storage_impl.ml

@@ -159,7 +159,10 @@ end
 
 module Sr = struct
   (** Represents the state of an SR *)
-  type vdis = (string, Vdi.t) Hashtbl.t [@@deriving rpc]
+  type vdis = (string, Vdi.t) Hashtbl.t
+
+  let vdis_of_rpc = Rpc_std_helpers.hashtbl_of_rpc ~of_rpc:Vdi.t_of_rpc
+  let rpc_of_vdis = Rpc_std_helpers.rpc_of_hashtbl ~rpc_of:Vdi.rpc_of_t
 
   type t = {
     vdis: vdis; (** All tracked VDIs *)
@@ -181,9 +184,14 @@ module Sr = struct
 end
 
 module Host = struct
+  type srs = (string, Sr.t) Hashtbl.t
+
+  let srs_of_rpc = Rpc_std_helpers.hashtbl_of_rpc ~of_rpc:Sr.t_of_rpc
+  let rpc_of_srs = Rpc_std_helpers.rpc_of_hashtbl ~rpc_of:Sr.rpc_of_t
+
   (** Represents the state of a host *)
   type t = {
-    srs: (string, Sr.t) Hashtbl.t;
+    srs: srs;
   } [@@deriving rpc]
 
   let empty () = {

ocaml/xapi/storage_migrate.ml

@@ -72,9 +72,9 @@ module State = struct
   let loaded = ref false
   let mutex = Mutex.create ()
 
-  type send_table = (string, Send_state.t) Hashtbl.t [@@deriving rpc]
-  type recv_table = (string, Receive_state.t) Hashtbl.t [@@deriving rpc]
-  type copy_table = (string, Copy_state.t) Hashtbl.t [@@deriving rpc]
+  type send_table = (string, Send_state.t) Hashtbl.t
+  type recv_table = (string, Receive_state.t) Hashtbl.t
+  type copy_table = (string, Copy_state.t) Hashtbl.t
 
   type osend
   type orecv
@@ -105,10 +105,12 @@ module State = struct
     | Recv_table _ -> Filename.concat !persist_root "storage_mirrors_recv.json"
     | Copy_table _ -> Filename.concat !persist_root "storage_mirrors_copy.json"
 
-  let rpc_of_table : type a. a table -> Rpc.t = function
-    | Send_table send_table -> rpc_of_send_table send_table
-    | Recv_table recv_table -> rpc_of_recv_table recv_table
-    | Copy_table copy_table -> rpc_of_copy_table copy_table
+  let rpc_of_table : type a. a table -> Rpc.t =
+    let open Rpc_std_helpers in
+    function
+    | Send_table send_table -> rpc_of_hashtbl ~rpc_of:Send_state.rpc_of_t send_table
+    | Recv_table recv_table -> rpc_of_hashtbl ~rpc_of:Receive_state.rpc_of_t recv_table
+    | Copy_table copy_table -> rpc_of_hashtbl ~rpc_of:Copy_state.rpc_of_t copy_table
 
   let to_string : type a. a table -> string =
     (fun table -> rpc_of_table table |> Jsonrpc.to_string)
@@ -118,13 +120,14 @@ module State = struct
 
   let load_one : type a. a table -> unit = (fun table ->
       let rpc = path_of_table table |> rpc_of_path in
+      let open Rpc_std_helpers in
       match table with
       | Send_table table ->
-        Hashtbl.iter (Hashtbl.replace table) (send_table_of_rpc rpc)
+        Hashtbl.iter (Hashtbl.replace table) (hashtbl_of_rpc ~of_rpc:Send_state.t_of_rpc rpc)
       | Recv_table table ->
-        Hashtbl.iter (Hashtbl.replace table) (recv_table_of_rpc rpc)
+        Hashtbl.iter (Hashtbl.replace table) (hashtbl_of_rpc ~of_rpc:Receive_state.t_of_rpc rpc)
       | Copy_table table ->
-        Hashtbl.iter (Hashtbl.replace table) (copy_table_of_rpc rpc))
+        Hashtbl.iter (Hashtbl.replace table) (hashtbl_of_rpc ~of_rpc:Copy_state.t_of_rpc rpc))
 
   let load () =
     try load_one (Send_table active_send) with _ -> ();