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 45733d13565..6b4afe77cd4 100644 --- a/ocaml/idl/ocaml_backend/gen_empty_custom.ml +++ b/ocaml/idl/ocaml_backend/gen_empty_custom.ml @@ -62,20 +62,21 @@ 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 | GetByLabel | GetAll + | GetAllWhere | 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 diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 036c3ce9706..5940803f59e 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -4580,68 +4580,58 @@ 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 + let host = + let expr_match x = + Printf.sprintf + {|(field "hostname"="%s") or (field "name__label"="%s") or (field "uuid"="%s")|} + x x x 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 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 = - Client.Network.get_all_records ~rpc:remote_rpc - ~session_id:remote_session + let network = + let expr x = + Printf.sprintf + {|(field "bridge"="%s") or (field "name__label"="%s") or (field "uuid"="%s")|} + x x x 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 -> - Client.PIF.get_management ~rpc:remote_rpc - ~session_id:remote_session ~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 = - 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 + 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 = @@ -4650,10 +4640,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 +4651,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 +4663,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,19 +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 = - Client.PBD.get_all_records_where ~rpc:remote_rpc - ~session_id:remote_session ~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 - ) - ) - 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 @@ -4807,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 @@ -4822,16 +4805,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 +4827,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 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 *) 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"