[Date Prev][Date Next]   [Thread Prev][Thread Next]   [Thread Index] [Date Index] [Author Index]

[Libguestfs] [PATCH 4/4] mltools: JSON: unify JSON_parser type with JSON.json_t.



---
 builder/simplestreams_parser.ml               |  9 +-
 .../test-virt-builder-list-simplestreams.sh   | 64 ++++++-------
 builder/utils.mli                             |  2 +-
 common/mltools/JSON_parser-c.c                | 96 ++++++++++++-------
 common/mltools/JSON_parser.ml                 | 29 ++----
 common/mltools/JSON_parser.mli                | 25 ++---
 common/mltools/JSON_parser_tests.ml           | 77 +++++++--------
 7 files changed, 156 insertions(+), 146 deletions(-)

diff --git a/builder/simplestreams_parser.ml b/builder/simplestreams_parser.ml
index fa5b887ac..ccbfdff67 100644
--- a/builder/simplestreams_parser.ml
+++ b/builder/simplestreams_parser.ml
@@ -59,7 +59,7 @@ let get_index ~downloader ~sigchecker { Sources.uri; proxy } =
       error (f_"%s is not a Simple Streams (index) v1.0 JSON file (format: %s)")
         uri format;
 
-    let index = Array.to_list (object_get_object "index" tree) in
+    let index = object_get_object "index" tree in
     List.filter_map (
       fun (_, desc) ->
         let format = object_get_string "format" desc in
@@ -78,13 +78,12 @@ let get_index ~downloader ~sigchecker { Sources.uri; proxy } =
       error (f_"%s is not a Simple Streams (products) v1.0 JSON file (format: %s)")
         uri format;
 
-    let products_node = object_get_object "products" tree in
+    let products = object_get_object "products" tree in
 
-    let products = Array.to_list products_node in
     List.filter_map (
       fun (prod, prod_desc) ->
         let arch = Index.Arch (object_get_string "arch" prod_desc) in
-        let prods = Array.to_list (object_get_object "versions" prod_desc) in
+        let prods = object_get_object "versions" prod_desc in
         let prods = List.filter_map (
           fun (rel, rel_desc) ->
             let pubname = objects_get_string "pubname" [rel_desc; prod_desc] in
@@ -106,7 +105,7 @@ let get_index ~downloader ~sigchecker { Sources.uri; proxy } =
                    * the ones related to checksums, explicitly filter
                    * the supported checksums.
                    *)
-                  | ("sha256"|"sha512" as t, JSON_parser_string c) ->
+                  | ("sha256"|"sha512" as t, JSON.String c) ->
                     Some (Checksums.of_string t c)
                   | _ -> None
                 ) disk_item in
diff --git a/builder/test-virt-builder-list-simplestreams.sh b/builder/test-virt-builder-list-simplestreams.sh
index 29fbfacce..3158066b1 100755
--- a/builder/test-virt-builder-list-simplestreams.sh
+++ b/builder/test-virt-builder-list-simplestreams.sh
@@ -26,9 +26,9 @@ export XDG_CONFIG_DIRS="$abs_builddir/test-simplestreams"
 
 short_list=$($VG virt-builder --no-check-signature --no-cache --list)
 
-if [ "$short_list" != "net.cirros-cloud:standard:0.3:i386 i386       cirros-0.3.4-i386
+if [ "$short_list" != "net.cirros-cloud:standard:0.3:powerpc powerpc    cirros-0.3.4-powerpc
 net.cirros-cloud:standard:0.3:x86_64 x86_64     cirros-0.3.4-x86_64
-net.cirros-cloud:standard:0.3:powerpc powerpc    cirros-0.3.4-powerpc" ]; then
+net.cirros-cloud:standard:0.3:i386 i386       cirros-0.3.4-i386" ]; then
     echo "$0: unexpected --list output:"
     echo "$short_list"
     exit 1
@@ -38,11 +38,11 @@ long_list=$(virt-builder --no-check-signature --no-cache --list --long)
 
 if [ "$long_list" != "Source URI: file://$abs_builddir/test-simplestreams
 
-os-version:              net.cirros-cloud:standard:0.3:i386
-Full name:               cirros-0.3.4-i386
-Architecture:            i386
-Minimum/default size:    11.9M
-Aliases:                 cirros-0.3.4-i386
+os-version:              net.cirros-cloud:standard:0.3:powerpc
+Full name:               cirros-0.3.4-powerpc
+Architecture:            powerpc
+Minimum/default size:    16.4M
+Aliases:                 cirros-0.3.4-powerpc
 
 os-version:              net.cirros-cloud:standard:0.3:x86_64
 Full name:               cirros-0.3.4-x86_64
@@ -50,11 +50,11 @@ Architecture:            x86_64
 Minimum/default size:    12.7M
 Aliases:                 cirros-0.3.4-x86_64
 
-os-version:              net.cirros-cloud:standard:0.3:powerpc
-Full name:               cirros-0.3.4-powerpc
-Architecture:            powerpc
-Minimum/default size:    16.4M
-Aliases:                 cirros-0.3.4-powerpc" ]; then
+os-version:              net.cirros-cloud:standard:0.3:i386
+Full name:               cirros-0.3.4-i386
+Architecture:            i386
+Minimum/default size:    11.9M
+Aliases:                 cirros-0.3.4-i386" ]; then
     echo "$0: unexpected --list --long output:"
     echo "$long_list"
     exit 1
@@ -70,26 +70,6 @@ if [ "$json_list" != "{
     }
   ],
   \"templates\": [
-    {
-      \"os-version\": \"net.cirros-cloud:standard:0.3:i386\",
-      \"full-name\": \"cirros-0.3.4-i386\",
-      \"arch\": \"i386\",
-      \"size\": 12506112,
-      \"aliases\": [
-        \"cirros-0.3.4-i386\"
-      ],
-      \"hidden\": false
-    },
-    {
-      \"os-version\": \"net.cirros-cloud:standard:0.3:x86_64\",
-      \"full-name\": \"cirros-0.3.4-x86_64\",
-      \"arch\": \"x86_64\",
-      \"size\": 13287936,
-      \"aliases\": [
-        \"cirros-0.3.4-x86_64\"
-      ],
-      \"hidden\": false
-    },
     {
       \"os-version\": \"net.cirros-cloud:standard:0.3:powerpc\",
       \"full-name\": \"cirros-0.3.4-powerpc\",
@@ -99,6 +79,26 @@ if [ "$json_list" != "{
         \"cirros-0.3.4-powerpc\"
       ],
       \"hidden\": false
+    },
+    {
+      \"os-version\": \"net.cirros-cloud:standard:0.3:x86_64\",
+      \"full-name\": \"cirros-0.3.4-x86_64\",
+      \"arch\": \"x86_64\",
+      \"size\": 13287936,
+      \"aliases\": [
+        \"cirros-0.3.4-x86_64\"
+      ],
+      \"hidden\": false
+    },
+    {
+      \"os-version\": \"net.cirros-cloud:standard:0.3:i386\",
+      \"full-name\": \"cirros-0.3.4-i386\",
+      \"arch\": \"i386\",
+      \"size\": 12506112,
+      \"aliases\": [
+        \"cirros-0.3.4-i386\"
+      ],
+      \"hidden\": false
     }
   ]
 }" ]; then
diff --git a/builder/utils.mli b/builder/utils.mli
index 5dde43a01..c7631636c 100644
--- a/builder/utils.mli
+++ b/builder/utils.mli
@@ -29,7 +29,7 @@ and revision =
 val string_of_revision : revision -> string
 (** Convert a {!revision} into a string. *)
 
-val get_image_infos : string -> JSON_parser.json_parser_val
+val get_image_infos : string -> JSON.json_t
 (** [get_image_infos path] Run qemu-img info on the image pointed at
     path as JSON tree. *)
 
diff --git a/common/mltools/JSON_parser-c.c b/common/mltools/JSON_parser-c.c
index 32432dc5b..dce9f6a15 100644
--- a/common/mltools/JSON_parser-c.c
+++ b/common/mltools/JSON_parser-c.c
@@ -28,7 +28,12 @@
 #include <stdio.h>
 #include <string.h>
 
-#define Val_none (Val_int (0))
+#define JSON_STRING_TAG 0
+#define JSON_INT_TAG    1
+#define JSON_FLOAT_TAG  2
+#define JSON_BOOL_TAG   3
+#define JSON_LIST_TAG   4
+#define JSON_DICT_TAG   5
 
 value virt_builder_json_parser_tree_parse (value stringv);
 
@@ -36,60 +41,87 @@ static value
 convert_json_t (json_t *val, int level)
 {
   CAMLparam0 ();
-  CAMLlocal4 (rv, lv, v, sv);
+  CAMLlocal5 (rv, v, tv, sv, consv);
 
   if (level > 20)
     caml_invalid_argument ("too many levels of object/array nesting");
 
   if (json_is_object (val)) {
-    const size_t len = json_object_size (val);
-    size_t i;
     const char *key;
     json_t *jvalue;
-    rv = caml_alloc (1, 3);
-    lv = caml_alloc_tuple (len);
-    i = 0;
+
+    rv = caml_alloc (1, JSON_DICT_TAG);
+    v = Val_int (0);
+    /* This will create the OCaml list backwards, but JSON
+     * dictionaries are supposed to be unordered so that shouldn't
+     * matter, right?  Well except that for some consumers this does
+     * matter (eg. simplestreams which incorrectly uses a dict when it
+     * really should use an array).
+     */
     json_object_foreach (val, key, jvalue) {
-      v = caml_alloc_tuple (2);
+      tv = caml_alloc_tuple (2);
       sv = caml_copy_string (key);
-      Store_field (v, 0, sv);
+      Store_field (tv, 0, sv);
       sv = convert_json_t (jvalue, level + 1);
-      Store_field (v, 1, sv);
-      Store_field (lv, i, v);
-      ++i;
+      Store_field (tv, 1, sv);
+      consv = caml_alloc (2, 0);
+      Store_field (consv, 1, v);
+      Store_field (consv, 0, tv);
+      v = consv;
     }
-    Store_field (rv, 0, lv);
-  } else if (json_is_array (val)) {
+    Store_field (rv, 0, v);
+  }
+  else if (json_is_array (val)) {
     const size_t len = json_array_size (val);
     size_t i;
     json_t *jvalue;
-    rv = caml_alloc (1, 4);
-    lv = caml_alloc_tuple (len);
-    json_array_foreach (val, i, jvalue) {
-      v = convert_json_t (jvalue, level + 1);
-      Store_field (lv, i, v);
+
+    rv = caml_alloc (1, JSON_LIST_TAG);
+    v = Val_int (0);
+    for (i = 0; i < len; ++i) {
+      /* Note we have to create the OCaml list backwards. */
+      jvalue = json_array_get (val, len-i-1);
+      tv = convert_json_t (jvalue, level + 1);
+      consv = caml_alloc (2, 0);
+      Store_field (consv, 1, v);
+      Store_field (consv, 0, tv);
+      v = consv;
     }
-    Store_field (rv, 0, lv);
-  } else if (json_is_string (val)) {
-    rv = caml_alloc (1, 0);
+    Store_field (rv, 0, v);
+  }
+  else if (json_is_string (val)) {
+    rv = caml_alloc (1, JSON_STRING_TAG);
     v = caml_copy_string (json_string_value (val));
     Store_field (rv, 0, v);
-  } else if (json_is_real (val)) {
-    rv = caml_alloc (1, 2);
+  }
+  else if (json_is_real (val)) {
+    rv = caml_alloc (1, JSON_FLOAT_TAG);
     v = caml_copy_double (json_real_value (val));
     Store_field (rv, 0, v);
-  } else if (json_is_integer (val)) {
-    rv = caml_alloc (1, 1);
+  }
+  else if (json_is_integer (val)) {
+    rv = caml_alloc (1, JSON_INT_TAG);
     v = caml_copy_int64 (json_integer_value (val));
     Store_field (rv, 0, v);
-  } else if (json_is_true (val)) {
-    rv = caml_alloc (1, 5);
+  }
+  else if (json_is_true (val)) {
+    rv = caml_alloc (1, JSON_BOOL_TAG);
     Store_field (rv, 0, Val_true);
-  } else if (json_is_false (val)) {
-    rv = caml_alloc (1, 5);
+  }
+  else if (json_is_false (val)) {
+    rv = caml_alloc (1, JSON_BOOL_TAG);
     Store_field (rv, 0, Val_false);
-  } else
-    rv = Val_none;
+  }
+  else {
+    /* Previously we had a special JSON_parser_null value we could
+     * use here, making the returned type (sort of) an option.
+     * This is a best effort which is better than crashing /
+     * throwing an error.
+     */
+    rv = caml_alloc (1, JSON_STRING_TAG);
+    v = caml_copy_string ("");
+    Store_field (rv, 0, v);
+  }
 
   CAMLreturn (rv);
 }
diff --git a/common/mltools/JSON_parser.ml b/common/mltools/JSON_parser.ml
index a82127454..642e24d65 100644
--- a/common/mltools/JSON_parser.ml
+++ b/common/mltools/JSON_parser.ml
@@ -20,20 +20,11 @@ open Std_utils
 open Tools_utils
 open Common_gettext.Gettext
 
-type json_parser_val =
-| JSON_parser_null
-| JSON_parser_string of string
-| JSON_parser_number of int64
-| JSON_parser_double of float
-| JSON_parser_object of (string * json_parser_val) array
-| JSON_parser_array of json_parser_val array
-| JSON_parser_bool of bool
-
-external json_parser_tree_parse : string -> json_parser_val = "virt_builder_json_parser_tree_parse"
+external json_parser_tree_parse : string -> JSON.json_t = "virt_builder_json_parser_tree_parse"
 
 let object_find_optional key = function
-  | JSON_parser_object o ->
-    (match List.filter (fun (k, _) -> k = key) (Array.to_list o) with
+  | JSON.Dict fields ->
+    (match List.filter (fun (k, _) -> k = key) fields with
     | [(k, v)] -> Some v
     | [] -> None
     | _ -> error (f_"more than value for the key ‘%s’") key)
@@ -46,27 +37,27 @@ let object_find key yv =
 
 let object_get_string key yv =
   match object_find key yv with
-  | JSON_parser_string s -> s
+  | JSON.String s -> s
   | _ -> error (f_"the value for the key ‘%s’ is not a string") key
 
 let object_find_object key yv =
   match object_find key yv with
-  | JSON_parser_object _ as o -> o
+  | JSON.Dict _ as o -> o
   | _ -> error (f_"the value for the key ‘%s’ is not an object") key
 
 let object_find_objects fn = function
-  | JSON_parser_object o -> List.filter_map fn (Array.to_list o)
+  | JSON.Dict fields -> List.filter_map fn fields
   | _ -> error (f_"the value is not an object")
 
 let object_get_object key yv =
   match object_find_object key yv with
-  | JSON_parser_object o -> o
+  | JSON.Dict fields -> fields
   | _ -> assert false (* object_find_object already errors out. *)
 
 let object_get_number key yv =
   match object_find key yv with
-  | JSON_parser_number n -> n
-  | JSON_parser_double d -> Int64.of_float d
+  | JSON.Int n -> n
+  | JSON.Float f -> Int64.of_float f
   | _ -> error (f_"the value for the key ‘%s’ is not an integer") key
 
 let objects_get_string key yvs =
@@ -74,7 +65,7 @@ let objects_get_string key yvs =
     | [] -> None
     | x :: xs ->
       (match object_find_optional key x with
-      | Some (JSON_parser_string s) -> Some s
+      | Some (JSON.String s) -> Some s
       | Some _ -> error (f_"the value for key ‘%s’ is not a string as expected") key
       | None -> loop xs
       )
diff --git a/common/mltools/JSON_parser.mli b/common/mltools/JSON_parser.mli
index f505953f2..5ad0ef017 100644
--- a/common/mltools/JSON_parser.mli
+++ b/common/mltools/JSON_parser.mli
@@ -16,43 +16,34 @@
  * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  *)
 
-type json_parser_val =
-| JSON_parser_null
-| JSON_parser_string of string
-| JSON_parser_number of int64
-| JSON_parser_double of float
-| JSON_parser_object of (string * json_parser_val) array
-| JSON_parser_array of json_parser_val array
-| JSON_parser_bool of bool
-
-val json_parser_tree_parse : string -> json_parser_val
+val json_parser_tree_parse : string -> JSON.json_t
 (** Parse the JSON string. *)
 
-val object_get_string : string -> json_parser_val -> string
+val object_get_string : string -> JSON.json_t -> string
 (** [object_get_string key yv] gets the value of the [key] field as a string
     in the [yv] structure *)
 
-val object_find_object : string -> json_parser_val -> json_parser_val
+val object_find_object : string -> JSON.json_t -> JSON.json_t
 (** [object_get_object key yv] gets the value of the [key] field as a JSON
     value in the [yv] structure.
 
     Mind the returned type is different from [object_get_object] *)
 
-val object_get_object : string -> json_parser_val -> (string * json_parser_val) array
+val object_get_object : string -> JSON.json_t -> (string * JSON.json_t) list
 (** [object_get_object key yv] gets the value of the [key] field as a JSON
     object in the [yv] structure *)
 
-val object_get_number : string -> json_parser_val -> int64
+val object_get_number : string -> JSON.json_t -> int64
 (** [object_get_number key yv] gets the value of the [key] field as an
     integer in the [yv] structure *)
 
-val objects_get_string : string -> json_parser_val list -> string
+val objects_get_string : string -> JSON.json_t list -> string
 (** [objects_get_string key yvs] gets the value of the [key] field as a string
-    in an [yvs] list of json_parser_val structure.
+    in an [yvs] list of JSON.json_t structure.
 
     The key may not be found at all in the list, in which case an error
     is raised *)
 
-val object_find_objects : ((string * json_parser_val) -> 'a option) -> json_parser_val -> 'a list
+val object_find_objects : ((string * JSON.json_t) -> 'a option) -> JSON.json_t -> 'a list
 (** [object_find_objects fn obj] returns all the JSON objects matching the [fn]
     function in [obj] list. *)
diff --git a/common/mltools/JSON_parser_tests.ml b/common/mltools/JSON_parser_tests.ml
index 42045122d..e7e3112b5 100644
--- a/common/mltools/JSON_parser_tests.ml
+++ b/common/mltools/JSON_parser_tests.ml
@@ -27,16 +27,15 @@ let assert_equal_int = assert_equal ~printer:(fun x -> string_of_int x)
 let assert_equal_int64 = assert_equal ~printer:(fun x -> Int64.to_string x)
 let assert_equal_bool = assert_equal ~printer:(fun x -> string_of_bool x)
 
-let string_of_json_parser_val_type = function
-  | JSON_parser_null -> "null"
-  | JSON_parser_string _ -> "string"
-  | JSON_parser_number _ -> "number"
-  | JSON_parser_double _ -> "float"
-  | JSON_parser_object _ -> "object"
-  | JSON_parser_array _ -> "array"
-  | JSON_parser_bool _ -> "bool"
+let string_of_json_t = function
+  | JSON.String _ -> "string"
+  | JSON.Int _ -> "int"
+  | JSON.Float _ -> "float"
+  | JSON.Dict _ -> "dict"
+  | JSON.List _ -> "list"
+  | JSON.Bool _ -> "bool"
 let type_mismatch_string exp value =
-  Printf.sprintf "value is not %s but %s" exp (string_of_json_parser_val_type value)
+  Printf.sprintf "value is not %s but %s" exp (string_of_json_t value)
 
 let assert_raises_invalid_argument str =
   (* Replace the Invalid_argument string with a fixed one, just to check
@@ -54,28 +53,28 @@ let assert_raises_nested str =
 let assert_is_object value =
   assert_bool
     (type_mismatch_string "object" value)
-    (match value with | JSON_parser_object _ -> true | _ -> false)
+    (match value with | JSON.Dict _ -> true | _ -> false)
 let assert_is_string exp = function
-  | JSON_parser_string s -> assert_equal_string exp s
+  | JSON.String s -> assert_equal_string exp s
   | _ as v -> assert_failure (type_mismatch_string "string" v)
 let assert_is_number exp = function
-  | JSON_parser_number n -> assert_equal_int64 exp n
-  | JSON_parser_double d -> assert_equal_int64 exp (Int64.of_float d)
+  | JSON.Int i -> assert_equal_int64 exp i
+  | JSON.Float f -> assert_equal_int64 exp (Int64.of_float f)
   | _ as v -> assert_failure (type_mismatch_string "number/double" v)
 let assert_is_array value =
   assert_bool
-    (type_mismatch_string "array" value)
-    (match value with | JSON_parser_array _ -> true | _ -> false)
+    (type_mismatch_string "list" value)
+    (match value with | JSON.List _ -> true | _ -> false)
 let assert_is_bool exp = function
-  | JSON_parser_bool b -> assert_equal_bool exp b
+  | JSON.Bool b -> assert_equal_bool exp b
   | _ as v -> assert_failure (type_mismatch_string "bool" v)
 
-let get_object_list = function
-  | JSON_parser_object x -> x
-  | _ as v -> assert_failure (type_mismatch_string "object" v)
-let get_array = function
-  | JSON_parser_array x -> x
-  | _ as v -> assert_failure (type_mismatch_string "array" v)
+let get_dict = function
+  | JSON.Dict x -> x
+  | _ as v -> assert_failure (type_mismatch_string "dict" v)
+let get_list = function
+  | JSON.List x -> x
+  | _ as v -> assert_failure (type_mismatch_string "list" v)
 
 
 let test_tree_parse_invalid ctx =
@@ -101,28 +100,26 @@ let test_tree_parse_basic ctx =
 
 let test_tree_parse_inspect ctx =
   let value = json_parser_tree_parse "{\"foo\":5}" in
-  let l = get_object_list value in
-  assert_equal_int 1 (Array.length l);
-  assert_equal_string "foo" (fst (l.(0)));
-  assert_is_number 5_L (snd (l.(0)));
+  let l = get_dict value in
+  assert_equal_int 1 (List.length l);
+  assert_equal_string "foo" (fst (List.hd l));
+  assert_is_number 5_L (snd (List.hd l));
 
   let value = json_parser_tree_parse "[\"foo\", true]" in
-  let a = get_array value in
-  assert_equal_int 2 (Array.length a);
-  assert_is_string "foo" (a.(0));
-  assert_is_bool true (a.(1));
+  let a = get_list value in
+  assert_equal_int 2 (List.length a);
+  assert_is_string "foo" (List.hd a);
+  assert_is_bool true (List.nth a 1);
 
   let value = json_parser_tree_parse "{\"foo\":[false, {}, 10], \"second\":2}" in
-  let l = get_object_list value in
-  assert_equal_int 2 (Array.length l);
-  assert_equal_string "foo" (fst (l.(0)));
-  let a = get_array (snd (l.(0))) in
-  assert_equal_int 3 (Array.length a);
-  assert_is_bool false (a.(0));
-  assert_is_object (a.(1));
-  assert_is_number 10_L (a.(2));
-  assert_equal_string "second" (fst (l.(1)));
-  assert_is_number 2_L (snd (l.(1)))
+  let l = get_dict value in
+  assert_equal_int 2 (List.length l);
+  let a = get_list (List.assoc "foo" l) in
+  assert_equal_int 3 (List.length a);
+  assert_is_bool false (List.hd a);
+  assert_is_object (List.nth a 1);
+  assert_is_number 10_L (List.nth a 2);
+  assert_is_number 2_L (List.assoc "second" l)
 
 (* Suites declaration. *)
 let suite =
-- 
2.18.0


[Date Prev][Date Next]   [Thread Prev][Thread Next]   [Thread Index] [Date Index] [Author Index]