From 8689af471e4a60be77fa33cdd8b1d4347c7d99a7 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 28 Mar 2024 09:51:49 +0000 Subject: [PATCH 1/4] gen_empty_custom: avoid wildcards for actions Making all the cases explicit avoids wrong behaviour when adding a new message Signed-off-by: Pau Ruiz Safont --- ocaml/idl/ocaml_backend/gen_empty_custom.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ocaml/idl/ocaml_backend/gen_empty_custom.ml b/ocaml/idl/ocaml_backend/gen_empty_custom.ml index 45733d13565..04aeb465590 100644 --- a/ocaml/idl/ocaml_backend/gen_empty_custom.ml +++ b/ocaml/idl/ocaml_backend/gen_empty_custom.ml @@ -62,6 +62,8 @@ let operation_requires_side_effect ({msg_tag= tag; _} as msg) = match tag with | FromField (Setter, fld) -> fld.DT.field_has_effect + | FromField ((Getter | Add | Remove), _) -> + false | FromObject ( GetRecord | GetByUuid @@ -70,12 +72,10 @@ let operation_requires_side_effect ({msg_tag= tag; _} as msg) = | GetAllRecordsWhere | GetAllRecords ) -> false - | FromObject _ -> + | FromObject (Make | Delete | Private _) -> true | Custom -> msg.DT.msg_has_effect && msg.DT.msg_forward_to = None - | _ -> - false let make_custom_api api = Dm_api.filter From c6984ad298e8bc7bc2481aa1a380d885e71ff4c2 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 28 Mar 2024 09:20:50 +0000 Subject: [PATCH 2/4] CA-390277: Add API to fetch references matching a query This is useful to avoid fetching whole records in vm migrations with different versions. This is because records can contain new variants, which can fail to be serialized. Signed-off-by: Pau Ruiz Safont --- ocaml/idl/datamodel_types.ml | 1 + ocaml/idl/datamodel_types.mli | 1 + ocaml/idl/datamodel_utils.ml | 32 ++++++++++++++++++++- ocaml/idl/ocaml_backend/gen_db_actions.ml | 6 ++++ ocaml/idl/ocaml_backend/gen_empty_custom.ml | 1 + ocaml/xapi/xapi_role.ml | 23 ++++++++------- 6 files changed, 52 insertions(+), 12 deletions(-) diff --git a/ocaml/idl/datamodel_types.ml b/ocaml/idl/datamodel_types.ml index 05ee08f5370..61893c99e01 100644 --- a/ocaml/idl/datamodel_types.ml +++ b/ocaml/idl/datamodel_types.ml @@ -586,6 +586,7 @@ and obj_op = | GetByLabel | GetRecord | GetAll + | GetAllWhere | GetAllRecordsWhere | GetAllRecords | Private of private_op diff --git a/ocaml/idl/datamodel_types.mli b/ocaml/idl/datamodel_types.mli index ef490cc4a66..76ac814eb49 100644 --- a/ocaml/idl/datamodel_types.mli +++ b/ocaml/idl/datamodel_types.mli @@ -210,6 +210,7 @@ and obj_op = | GetByLabel | GetRecord | GetAll + | GetAllWhere | GetAllRecordsWhere | GetAllRecords | Private of private_op diff --git a/ocaml/idl/datamodel_utils.ml b/ocaml/idl/datamodel_utils.ml index 6245f927ba5..6f220c6b53b 100644 --- a/ocaml/idl/datamodel_utils.ml +++ b/ocaml/idl/datamodel_utils.ml @@ -683,6 +683,36 @@ let messages_of_obj (x : obj) document_order : message list = } in + let get_all_where = + { + get_all_public with + msg_name= "get_all_where" + ; msg_tag= FromObject GetAllWhere + ; msg_params= + [ + { + param_type= String + ; param_name= "expr" + ; param_doc= "expression matching records" + ; param_release= x.obj_release + ; param_default= None + } + ] + ; msg_result= Some (Set (Ref x.name), "references to all matching objects") + ; msg_release= + { + opensource= [] + ; internal= + x.obj_release.internal + (* This should be the release of getallwhere, or the class' + introduction, whichever is last. *) + ; internal_deprecated_since= None + } + ; msg_allowed_roles= x.obj_implicit_msg_allowed_roles + ; msg_hide_from_docs= true + } + in + (* And the 'get_all_records_where' semi-public function *) let get_all_records_where = { @@ -738,7 +768,7 @@ let messages_of_obj (x : obj) document_order : message list = in let get_all_public = if List.mem x.name expose_get_all_messages_for then - [get_all_public; get_all_records_where; get_all_records] + [get_all_public; get_all_where; get_all_records_where; get_all_records] else [] in diff --git a/ocaml/idl/ocaml_backend/gen_db_actions.ml b/ocaml/idl/ocaml_backend/gen_db_actions.ml index 13bc14a1f4b..23c3dc8a747 100644 --- a/ocaml/idl/ocaml_backend/gen_db_actions.ml +++ b/ocaml/idl/ocaml_backend/gen_db_actions.ml @@ -536,6 +536,12 @@ let db_action api : O.Module.t = "let expr' = Xapi_database.Db_filter.expr_of_string expr in" ; "get_records_where ~" ^ Gen_common.context ^ " ~expr:expr'" ] + | FromObject GetAllWhere -> + String.concat "\n" + [ + "let expr' = Xapi_database.Db_filter.expr_of_string expr in" + ; "get_refs_where ~" ^ Gen_common.context ^ " ~expr:expr'" + ] | _ -> assert false in diff --git a/ocaml/idl/ocaml_backend/gen_empty_custom.ml b/ocaml/idl/ocaml_backend/gen_empty_custom.ml index 04aeb465590..6b4afe77cd4 100644 --- a/ocaml/idl/ocaml_backend/gen_empty_custom.ml +++ b/ocaml/idl/ocaml_backend/gen_empty_custom.ml @@ -69,6 +69,7 @@ let operation_requires_side_effect ({msg_tag= tag; _} as msg) = | GetByUuid | GetByLabel | GetAll + | GetAllWhere | GetAllRecordsWhere | GetAllRecords ) -> false diff --git a/ocaml/xapi/xapi_role.ml b/ocaml/xapi/xapi_role.ml index a7eaf1112da..fa7124d96f9 100644 --- a/ocaml/xapi/xapi_role.ml +++ b/ocaml/xapi/xapi_role.ml @@ -92,25 +92,26 @@ let get_record ~__context ~self = ~static_fn:(fun static_record -> get_api_record ~static_record) ~db_fn:(fun ~__context ~self -> Db.Role.get_record ~__context ~self) -(* val get_all_records_where : __context:Context.t -> expr:string -> ref_role_to_role_t_map*) let expr_no_permissions = "subroles<>[]" let expr_only_permissions = "subroles=[]" -let get_all_records_where ~__context ~expr = +let get_common_where ~__context ~expr ~f = if expr = expr_no_permissions then (* composite role, ie. not a permission *) - List.map - (fun r -> (ref_of_role ~role:r, get_api_record ~static_record:r)) - Rbac_static.all_static_roles + List.map f Rbac_static.all_static_roles else if expr = expr_only_permissions then (* composite role, ie. a permission *) - List.map - (fun r -> (ref_of_role ~role:r, get_api_record ~static_record:r)) - Rbac_static.all_static_permissions + List.map f Rbac_static.all_static_permissions else (* anything in this table, ie. roles+permissions *) - List.map - (fun r -> (ref_of_role ~role:r, get_api_record ~static_record:r)) - get_all_static_roles + List.map f get_all_static_roles + +let get_all_where ~__context ~expr = + let f r = ref_of_role ~role:r in + get_common_where ~__context ~expr ~f + +let get_all_records_where ~__context ~expr = + let f r = (ref_of_role ~role:r, get_api_record ~static_record:r) in + get_common_where ~__context ~expr ~f (*@ (* concatenate with Db table *) (* TODO: this line is crashing for some unknown reason, but not needed in RBAC 1 *) From caadaf28677f8b9f570f5dd2a58cf176f33a2759 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 3 Jul 2024 11:18:42 +0100 Subject: [PATCH 3/4] xapi-cli-server: use helper remote in migrate function This reduces repetition, makes calls easier to read, and shorter. Signed-off-by: Pau Ruiz Safont --- ocaml/xapi-cli-server/cli_operations.ml | 62 ++++++------------------- 1 file changed, 14 insertions(+), 48 deletions(-) diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 036c3ce9706..74aa55eab66 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -4580,13 +4580,11 @@ let vm_migrate printer rpc session_id params = Client.Session.login_with_password ~rpc:remote_rpc ~uname ~pwd ~version:"1.3" ~originator:Constants.xapi_user_agent in + let remote f = f ~rpc:remote_rpc ~session_id:remote_session in finally (fun () -> let host, host_record = - let all = - Client.Host.get_all_records ~rpc:remote_rpc - ~session_id:remote_session - in + let all = remote Client.Host.get_all_records in if List.mem_assoc "host" params then let x = List.assoc "host" params in try @@ -4603,10 +4601,7 @@ let vm_migrate printer rpc session_id params = List.hd all in let network, network_record = - let all = - Client.Network.get_all_records ~rpc:remote_rpc - ~session_id:remote_session - in + let all = remote Client.Network.get_all_records in if List.mem_assoc "remote-network" params then let x = List.assoc "remote-network" params in try @@ -4623,10 +4618,7 @@ let vm_migrate printer rpc session_id params = let pifs = host_record.API.host_PIFs in let management_pifs = List.filter - (fun self -> - Client.PIF.get_management ~rpc:remote_rpc - ~session_id:remote_session ~self - ) + (fun self -> remote Client.PIF.get_management ~self) pifs in if management_pifs = [] then @@ -4635,14 +4627,8 @@ let vm_migrate printer rpc session_id params = host_record.API.host_uuid ) ; let pif = List.hd management_pifs in - let net = - Client.PIF.get_network ~rpc:remote_rpc ~session_id:remote_session - ~self:pif - in - ( net - , Client.Network.get_record ~rpc:remote_rpc - ~session_id:remote_session ~self:net - ) + let net = remote Client.PIF.get_network ~self:pif in + (net, remote Client.Network.get_record ~self:net) in let vif_map = List.map @@ -4650,10 +4636,7 @@ let vm_migrate printer rpc session_id params = let vif = Client.VIF.get_by_uuid ~rpc ~session_id ~uuid:vif_uuid in - let net = - Client.Network.get_by_uuid ~rpc:remote_rpc - ~session_id:remote_session ~uuid:net_uuid - in + let net = remote Client.Network.get_by_uuid ~uuid:net_uuid in (vif, net) ) (read_map_params "vif" params) @@ -4664,10 +4647,7 @@ let vm_migrate printer rpc session_id params = let vdi = Client.VDI.get_by_uuid ~rpc ~session_id ~uuid:vdi_uuid in - let sr = - Client.SR.get_by_uuid ~rpc:remote_rpc ~session_id:remote_session - ~uuid:sr_uuid - in + let sr = remote Client.SR.get_by_uuid ~uuid:sr_uuid in (vdi, sr) ) (read_map_params "vdi" params) @@ -4679,8 +4659,7 @@ let vm_migrate printer rpc session_id params = Client.VGPU.get_by_uuid ~rpc ~session_id ~uuid:vgpu_uuid in let gpu_group = - Client.GPU_group.get_by_uuid ~rpc:remote_rpc - ~session_id:remote_session ~uuid:gpu_group_uuid + remote Client.GPU_group.get_by_uuid ~uuid:gpu_group_uuid in (vgpu, gpu_group) ) @@ -4696,16 +4675,12 @@ let vm_migrate printer rpc session_id params = {|(field "host"="%s") and (field "currently_attached"="true")|} (Ref.string_of host) in - let host_pbds = - Client.PBD.get_all_records_where ~rpc:remote_rpc - ~session_id:remote_session ~expr - in + let host_pbds = remote Client.PBD.get_all_records_where ~expr in let srs = List.map (fun (_, pbd_rec) -> ( pbd_rec.API.pBD_SR - , Client.SR.get_record ~rpc:remote_rpc - ~session_id:remote_session ~self:pbd_rec.API.pBD_SR + , remote Client.SR.get_record ~self:pbd_rec.API.pBD_SR ) ) host_pbds @@ -4822,16 +4797,13 @@ let vm_migrate printer rpc session_id params = (Cli_printer.PMsg (Printf.sprintf "VDI %s -> SR %s" (Client.VDI.get_uuid ~rpc ~session_id ~self:vdi) - (Client.SR.get_uuid ~rpc:remote_rpc - ~session_id:remote_session ~self:sr - ) + (remote Client.SR.get_uuid ~self:sr) ) ) ) vdi_map ; let token = - Client.Host.migrate_receive ~rpc:remote_rpc ~session_id:remote_session - ~host ~network ~options + remote Client.Host.migrate_receive ~host ~network ~options in let new_vm = do_vm_op ~include_control_vms:false ~include_template_vms:true printer @@ -4847,13 +4819,7 @@ let vm_migrate printer rpc session_id params = |> List.hd in if get_bool_param params "copy" then - printer - (Cli_printer.PList - [ - Client.VM.get_uuid ~rpc:remote_rpc ~session_id:remote_session - ~self:new_vm - ] - ) + printer (Cli_printer.PList [remote Client.VM.get_uuid ~self:new_vm]) ) (fun () -> Client.Session.logout ~rpc:remote_rpc ~session_id:remote_session From ba47a87a51aa544bc20ec333ad76c9f256daa030 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 28 Mar 2024 13:02:32 +0000 Subject: [PATCH 4/4] CA-390277: Reduce record usage on CLI cross-pool migrations Using records in cross-pool migration code is dangerous, as the code interacts with potentially newer hosts. This means that fields in the record might be different from what's expected. In particular adding an enum field can break the deserialization, and removing a field as well. With this change, only SR records are used. This is done to minimize the number of calls done. Signed-off-by: Pau Ruiz Safont --- ocaml/xapi-cli-server/cli_operations.ml | 118 +++++++++++++----------- quality-gate.sh | 2 +- 2 files changed, 64 insertions(+), 56 deletions(-) diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 74aa55eab66..5940803f59e 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -4583,52 +4583,56 @@ let vm_migrate printer rpc session_id params = let remote f = f ~rpc:remote_rpc ~session_id:remote_session in finally (fun () -> - let host, host_record = - let all = remote Client.Host.get_all_records in - if List.mem_assoc "host" params then - let x = List.assoc "host" params in - try - List.find - (fun (_, h) -> - h.API.host_hostname = x - || h.API.host_name_label = x - || h.API.host_uuid = x - ) - all - with Not_found -> - failwith (Printf.sprintf "Failed to find host: %s" x) - else - List.hd all + let host = + let expr_match x = + Printf.sprintf + {|(field "hostname"="%s") or (field "name__label"="%s") or (field "uuid"="%s")|} + x x x + in + let expr, fail_msg = + match List.assoc_opt "host" params with + | Some x -> + (expr_match x, Printf.sprintf "Failed to find host: %s" x) + | None -> + ("true", Printf.sprintf "Failed to find a suitable host") + in + match remote Client.Host.get_all_where ~expr with + | host :: _ -> + host + | [] -> + failwith fail_msg in - let network, network_record = - let all = remote Client.Network.get_all_records in - if List.mem_assoc "remote-network" params then - let x = List.assoc "remote-network" params in - try - List.find - (fun (_, net) -> - net.API.network_bridge = x - || net.API.network_name_label = x - || net.API.network_uuid = x - ) - all - with Not_found -> - failwith (Printf.sprintf "Failed to find network: %s" x) - else - let pifs = host_record.API.host_PIFs in - let management_pifs = - List.filter - (fun self -> remote Client.PIF.get_management ~self) - pifs - in - if management_pifs = [] then - failwith - (Printf.sprintf "Could not find management PIF on host %s" - host_record.API.host_uuid - ) ; - let pif = List.hd management_pifs in - let net = remote Client.PIF.get_network ~self:pif in - (net, remote Client.Network.get_record ~self:net) + let network = + let expr x = + Printf.sprintf + {|(field "bridge"="%s") or (field "name__label"="%s") or (field "uuid"="%s")|} + x x x + in + match List.assoc_opt "remote-network" params with + | Some x -> ( + match remote Client.Network.get_all_where ~expr:(expr x) with + | network :: _ -> + network + | [] -> + failwith (Printf.sprintf "Failed to find network: %s" x) + ) + | None -> ( + let expr = + Printf.sprintf + {|(field "host"="%s") and (field "management"="true")|} + Ref.(string_of host) + in + let management_pifs = remote Client.PIF.get_all_where ~expr in + match management_pifs with + | [] -> + let host_uuid = remote Client.Host.get_uuid ~self:host in + failwith + (Printf.sprintf "Could not find management PIF on host %s" + host_uuid + ) + | pif :: _ -> + remote Client.PIF.get_network ~self:pif + ) in let vif_map = List.map @@ -4675,15 +4679,12 @@ let vm_migrate printer rpc session_id params = {|(field "host"="%s") and (field "currently_attached"="true")|} (Ref.string_of host) in - let host_pbds = remote Client.PBD.get_all_records_where ~expr in let srs = - List.map - (fun (_, pbd_rec) -> - ( pbd_rec.API.pBD_SR - , remote Client.SR.get_record ~self:pbd_rec.API.pBD_SR - ) - ) - host_pbds + remote Client.PBD.get_all_where ~expr + |> List.map (fun pbd -> + let sr = remote Client.PBD.get_SR ~self:pbd in + (sr, remote Client.SR.get_record ~self:sr) + ) in (* In the following loop, the current SR:sr' will be compared with previous checked ones, first if it is an ISO type, then pass this one for selection, then the only shared one from this and @@ -4782,13 +4783,20 @@ let vm_migrate printer rpc session_id params = ) params in + let host_name_label = + Client.Host.get_name_label ~rpc:remote_rpc ~session_id:remote_session + ~self:host + in + let network_name_label = + Client.Network.get_name_label ~rpc:remote_rpc + ~session_id:remote_session ~self:network + in printer (Cli_printer.PMsg (Printf.sprintf "Will migrate to remote host: %s, using remote network: %s. \ Here is the VDI mapping:" - host_record.API.host_name_label - network_record.API.network_name_label + host_name_label network_name_label ) ) ; List.iter diff --git a/quality-gate.sh b/quality-gate.sh index 65b0f39b7f3..8e59aacdc18 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=306 + N=304 LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$LIST_HD" -eq "$N" ]; then echo "OK counted $LIST_HD List.hd usages"