--- builder/simplestreams_parser.ml | 9 +- .../test-virt-builder-list-simplestreams.sh | 64 ++++++------- builder/utils.mli | 2 +- common/mltools/JSON_parser-c.c | 89 ++++++++++++------- common/mltools/JSON_parser.ml | 29 +++--- common/mltools/JSON_parser.mli | 25 ++---- common/mltools/JSON_parser_tests.ml | 78 ++++++++-------- 7 files changed, 150 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..87edebe10 100644 --- a/common/mltools/JSON_parser-c.c +++ b/common/mltools/JSON_parser-c.c @@ -28,7 +28,13 @@ #include <stdio.h> #include <string.h> -#define Val_none (Val_int (0)) +#define JSON_NULL (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 +42,79 @@ 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 + rv = JSON_NULL; 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..024817711 100644 --- a/common/mltools/JSON_parser_tests.ml +++ b/common/mltools/JSON_parser_tests.ml @@ -27,16 +27,16 @@ 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.Null -> "null" + | 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 +54,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 +101,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