[Libguestfs] [PATCH 4/4] mltools: JSON: unify JSON_parser type with JSON.json_t.
Richard W.M. Jones
rjones at redhat.com
Mon Aug 20 16:02:06 UTC 2018
---
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
More information about the Libguestfs
mailing list