From 084933657cae641c59bcffca061bcd63a922481b Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Mon, 29 Sep 2025 15:16:40 +0100 Subject: [PATCH 1/2] idl: Remove apparently unused gen_test.ml Signed-off-by: Andrii Sultanov --- ocaml/idl/ocaml_backend/gen_test.ml | 102 ---------------------------- 1 file changed, 102 deletions(-) delete mode 100644 ocaml/idl/ocaml_backend/gen_test.ml diff --git a/ocaml/idl/ocaml_backend/gen_test.ml b/ocaml/idl/ocaml_backend/gen_test.ml deleted file mode 100644 index 70dc19a0fa6..00000000000 --- a/ocaml/idl/ocaml_backend/gen_test.ml +++ /dev/null @@ -1,102 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -open Printf -module DT = Datamodel_types -module DU = Datamodel_utils -module OU = Ocaml_utils -module O = Ocaml_syntax -module Listext = Xapi_stdext_std.Listext.List - -let print s = output_string stdout (s ^ "\n") - -let rec gen_test_type highapi ty = - let rec aux = function - | DT.String -> - "\"teststring\"" - | DT.Int -> - "123456789123456789L" - | DT.Float -> - "0.123456789" - | DT.Bool -> - "true" - | DT.DateTime -> - "(Date.of_iso8601 \"20120101T00:00:00Z\")" - | DT.Enum (_, (x, _) :: _) -> - Printf.sprintf "(%s)" (OU.constructor_of x) - | DT.Set (DT.Enum (_, y)) -> - Printf.sprintf "[ %s ]" - (String.concat ";" (List.map (fun (x, _) -> OU.constructor_of x) y)) - | DT.Set x -> - Printf.sprintf "[ %s ]" (aux x) - | DT.Map (x, y) -> - Printf.sprintf "[ (%s,%s) ]" (aux x) (aux y) - | DT.Ref _ -> - Printf.sprintf "(Ref.of_string \"OpaqueRef:foo\")" - | DT.Record x -> - gen_record_type highapi x - | _ -> - failwith "Invalid type" - in - aux ty - -(** Generate a list of modules for each record kind *) -and gen_record_type highapi record = - let obj_name = OU.ocaml_of_record_name record in - let all_fields = - DU.fields_of_obj (Dm_api.get_obj_by_name highapi ~objname:record) - in - let field fld = OU.ocaml_of_record_field (obj_name :: fld.DT.full_name) in - let map_fields fn = - String.concat "; " (List.map (fun field -> fn field) all_fields) - in - let regular_def fld = - sprintf "%s=%s" (field fld) (gen_test_type highapi fld.DT.ty) - in - sprintf "{ %s }" (map_fields regular_def) - -let gen_test highapi = - let all_types = DU.Types.of_objects (Dm_api.objects_of_api highapi) in - let all_types = Gen_api.add_set_enums all_types in - ignore all_types ; - List.iter (List.iter print) - (Listext.between [""] - [ - ["open API"] - ; ["let _ ="] - ; List.concat_map - (fun ty -> - [ - sprintf "let oc = open_out \"rpc-light_%s.xml\" in" - (OU.alias_of_ty ty) - ; sprintf "let x = %s in" (gen_test_type highapi ty) - ; sprintf - "Printf.fprintf oc \"%%s\" (Xmlrpc.to_string (API.rpc_of_%s \ - x));" - (OU.alias_of_ty ty) - ; "close_out oc;" - ; sprintf "let oc = open_out \"xml-light2_%s.xml\" in" - (OU.alias_of_ty ty) - ; sprintf - "Printf.fprintf oc \"%%s\" (Xml.to_string (API.Legacy.To.%s \ - x));" - (OU.alias_of_ty ty) - ; "close_out oc;" - (* sprintf "let s = Xml.to_string (API.Legacy.To.%s x) in" (OU.alias_of_ty ty);*) - (* sprintf "let y =" *) - ] - ) - all_types - ] - ) From 197c31945271b67940acca989a092bad972dee1f Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Tue, 30 Sep 2025 10:20:27 +0100 Subject: [PATCH 2/2] idl/gen_client: Don't specify argument values when they're equal to defaults This enables client.ml to skip specifying an arbitrary number of rightmost arguments if they're all equal to their default values (since arguments are positional, once an argument is not skipped, no arguments to its left can be skipped). Generated code for e.g. host.disable looks like the following: let session_id = rpc_of_ref_session session_id in let host = rpc_of_ref_host host in let auto_enable = rpc_of_bool auto_enable in let needed_args, _ = List.fold_right2 (fun param default (acc, skipped)-> (* Since arguments are positional, we can only skip specifying an argument that's equal to its default value if all the arguments to its right were also not specified *) if skipped then (match default with | Some default_value when param = default_value -> (acc, true) | _ -> (param::acc, false)) else (param :: acc, false) ) [ session_id; host; auto_enable ] [ None; None; Some (Rpc.Bool true) ] ([], true) in rpc_wrapper rpc "host.disable" needed_args >>= fun x -> return (ignore x) This fixes an issue with client.ml always specifying values for new parameters that older server.ml did not know about (which happens during an RPU). Fixes: cf5be6222 ("host.disable: Add auto_enabled parameter for persistency") Signed-off-by: Andrii Sultanov --- ocaml/idl/ocaml_backend/gen_client.ml | 82 ++++++++++++++++++++++----- quality-gate.sh | 2 +- 2 files changed, 70 insertions(+), 14 deletions(-) diff --git a/ocaml/idl/ocaml_backend/gen_client.ml b/ocaml/idl/ocaml_backend/gen_client.ml index ee61a09496c..55de939525f 100644 --- a/ocaml/idl/ocaml_backend/gen_client.ml +++ b/ocaml/idl/ocaml_backend/gen_client.ml @@ -92,27 +92,34 @@ let ctor_fields (obj : obj) = (function {DT.qualifier= DT.StaticRO | DT.RW; _} -> true | _ -> false) (DU.fields_of_obj obj) -(* Compute a message parameter list from a message suitable for the client (only!) *) -let args_of_message ?(expand_record = true) (obj : obj) +(* Compute a list of message parameters and their default values from a + message suitable for the client (only!) *) +let args_of_message_with_default ?(expand_record = true) (obj : obj) ({msg_tag= tag; _} as msg) = let arg_of_param = function - | {param_type= Record x; _} -> ( + | {param_type= Record x; param_default= default; _} -> ( match tag with | FromObject Make -> if x <> obj.DT.name then failwith "args_of_message" ; if expand_record then - List.map param_of_field (ctor_fields obj) + List.map + (fun x -> (x, None)) + (List.map param_of_field (ctor_fields obj)) else - [custom _value (Record x)] + [(custom _value (Record x), default)] | _ -> failwith "arg_of_param: encountered a Record in an unexpected place" ) | p -> - [of_param p] + [(of_param p, p.param_default)] in - let session = if msg.msg_session then [session] else [] in + let session = if msg.msg_session then [(session, None)] else [] in List.concat (session :: List.map arg_of_param msg.msg_params) +(* Compute a message parameter list from a message suitable for the client (only!) *) +let args_of_message ?(expand_record = true) obj x = + List.map fst (args_of_message_with_default ~expand_record obj x) + let gen_module api : O.Module.t = (* Generate any additional helper functions for an operation here *) let helper_record_constructor ~sync (obj : obj) (x : message) = @@ -148,7 +155,8 @@ let gen_module api : O.Module.t = in (* Convert an operation into a Let-binding *) let operation ~sync (obj : obj) (x : message) = - let args = args_of_message obj x in + let args_with_default = args_of_message_with_default obj x in + let args = List.map fst args_with_default in let to_rpc (arg : O.param) = let binding = O.string_of_param arg in let converter = O.type_of_param arg in @@ -172,6 +180,31 @@ let gen_module api : O.Module.t = else List.map O.string_of_param args in + let defaults = + List.map + (fun (_, default_value) -> + match default_value with + | Some x -> + Printf.sprintf "Some (%s)" (Datamodel_values.to_ocaml_string x) + | None -> + "None" + ) + args_with_default + in + let rightmost_arg_default = + Some true + = List.fold_right + (fun (_, x) rightmost_arg_default -> + match rightmost_arg_default with + | None when Option.is_some x -> + Some true + | Some true -> + Some true + | _ -> + Some false + ) + args_with_default None + in let task = DT.Ref Datamodel_common._task in let from_xmlrpc t = match (x.msg_custom_marshaller, t, sync) with @@ -203,15 +236,41 @@ let gen_module api : O.Module.t = (List.map to_rpc args @ [ (if is_ctor then ctor_record else "") + ; ( if (not is_ctor) && rightmost_arg_default then + (* Skip specifying arguments which are equal to their default + values. This way, when a newer client talks to an older + server that does not know about a new parameter, it can + silently skip sending it, avoiding an error *) + Printf.sprintf + {| + let needed_args, _ = List.fold_right2 + (fun param default (acc, skipped)-> + (* Since arguments are positional, we can only skip specifying an + argument that's equal to its default value if all the arguments to + its right were also not specified *) + if skipped then + (match default with + | Some default_value when param = default_value -> (acc, true) + | _ -> (param::acc, false)) + else + (param :: acc, false) + ) [ %s ] [ %s ] ([], true) + in + |} + (String.concat "; " rpc_args) + (String.concat "; " defaults) + else + Printf.sprintf "let needed_args = [ %s ] in" + (String.concat "; " rpc_args) + ) ; Printf.sprintf - "rpc_wrapper rpc %s [ %s ] >>= fun x -> return (%s x)" + "rpc_wrapper rpc %s needed_args >>= fun x -> return (%s x)" ( if sync then Printf.sprintf "\"%s\"" wire_name else Printf.sprintf {|(Printf.sprintf "%%s%s" AQ.async_qualifier)|} wire_name ) - (String.concat "; " rpc_args) (from_xmlrpc x.msg_result) ] ) @@ -227,9 +286,6 @@ let gen_module api : O.Module.t = obj.messages in let fields = fields_of (operations @ helpers) in - (* - let fields = List.map (fun x -> O.Module.Let (operation ~sync obj x)) obj.messages in -*) O.Module.make ~name:(OU.ocaml_of_obj_name obj.DT.name) ~elements:fields () in let preamble = diff --git a/quality-gate.sh b/quality-gate.sh index 14725fb6689..84919c51a1c 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=462 + N=461 X="ocaml/tests" X+="|ocaml/quicktest" X+="|ocaml/message-switch/core_test"